sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 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 /* ============================================================================
  28
  29 =head1 Allocation and deallocation of SVs.
  30
  31 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
  32 av, hv...) contains type and reference count information, as well as a
  33 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
  34 specific to each type.
  35
  36 Normally, this allocation is done using arenas, which are approximately
  37 1K chunks of memory parcelled up into N heads or bodies. The first slot
  38 in each arena is reserved, and is used to hold a link to the next arena.
  39 In the case of heads, the unused first slot also contains some flags and
  40 a note of the number of slots.  Snaked through each arena chain is a
  41 linked list of free items; when this becomes empty, an extra arena is
  42 allocated and divided up into N items which are threaded into the free
  43 list.
  44
  45 The following global variables are associated with arenas:
  46
  47     PL_sv_arenaroot     pointer to list of SV arenas
  48     PL_sv_root          pointer to list of free SV structures
  49
  50     PL_foo_arenaroot    pointer to list of foo arenas,
  51     PL_foo_root         pointer to list of free foo bodies
  52                             ... for foo in xiv, xnv, xrv, xpv etc.
  53
  54 Note that some of the larger and more rarely used body types (eg xpvio)
  55 are not allocated using arenas, but are instead just malloc()/free()ed as
  56 required. Also, if PURIFY is defined, arenas are abandoned altogether,
  57 with all items individually malloc()ed. In addition, a few SV heads are
  58 not allocated from an arena, but are instead directly created as static
  59 or auto variables, eg PL_sv_undef.
  60
  61 The SV arena serves the secondary purpose of allowing still-live SVs
  62 to be located and destroyed during final cleanup.
  63
  64 At the lowest level, the macros new_SV() and del_SV() grab and free
  65 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
  66 to return the SV to the free list with error checking.) new_SV() calls
  67 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
  68 SVs in the free list have their SvTYPE field set to all ones.
  69
  70 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
  71 that allocate and return individual body types. Normally these are mapped
  72 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
  73 instead mapped directly to malloc()/free() if PURIFY is defined. The
  74 new/del functions remove from, or add to, the appropriate PL_foo_root
  75 list, and call more_xiv() etc to add a new arena if the list is empty.
  76
  77 At the time of very final cleanup, sv_free_arenas() is called from
  78 perl_destruct() to physically free all the arenas allocated since the
  79 start of the interpreter.  Note that this also clears PL_he_arenaroot,
  80 which is otherwise dealt with in hv.c.
  81
  82 Manipulation of any of the PL_*root pointers is protected by enclosing
  83 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
  84 if threads are enabled.
  85
  86 The function visit() scans the SV arenas list, and calls a specified
  87 function for each SV it finds which is still live - ie which has an SvTYPE
  88 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
  89 following functions (specified as [function that calls visit()] / [function
  90 called by visit() for each SV]):
  91
  92     sv_report_used() / do_report_used()
  93                         dump all remaining SVs (debugging aid)
  94
  95     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
  96                         Attempt to free all objects pointed to by RVs,
  97                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
  98                         try to do the same for all objects indirectly
  99                         referenced by typeglobs too.  Called once from
 100                         perl_destruct(), prior to calling sv_clean_all()
 101                         below.
 102
 103     sv_clean_all() / do_clean_all()
 104                         SvREFCNT_dec(sv) each remaining SV, possibly
 105                         triggering an sv_free(). It also sets the
 106                         SVf_BREAK flag on the SV to indicate that the
 107                         refcnt has been artificially lowered, and thus
 108                         stopping sv_free() from giving spurious warnings
 109                         about SVs which unexpectedly have a refcnt
 110                         of zero.  called repeatedly from perl_destruct()
 111                         until there are no SVs left.
 112
 113 =head2 Summary
 114
 115 Private API to rest of sv.c
 116
 117     new_SV(),  del_SV(),
 118
 119     new_XIV(), del_XIV(),
 120     new_XNV(), del_XNV(),
 121     etc
 122
 123 Public API:
 124
 125     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
 126
 127
 128 =cut
 129
 130 ============================================================================ */
 131
 132
 133
 134 /*
 135  * "A time to plant, and a time to uproot what was planted..."
 136  */
 137
 138 #define plant_SV(p) \
 139     STMT_START {                                        \
 140         SvANY(p) = (void *)PL_sv_root;                  \
 141         SvFLAGS(p) = SVTYPEMASK;                        \
 142         PL_sv_root = (p);                               \
 143         --PL_sv_count;                                  \
 144     } STMT_END
 145
 146 /* sv_mutex must be held while calling uproot_SV() */
 147 #define uproot_SV(p) \
 148     STMT_START {                                        \
 149         (p) = PL_sv_root;                               \
 150         PL_sv_root = (SV*)SvANY(p);                     \
 151         ++PL_sv_count;                                  \
 152     } STMT_END
 153
 154
 155 /* new_SV(): return a new, empty SV head */
 156
 157 #ifdef DEBUG_LEAKING_SCALARS
 158 /* provide a real function for a debugger to play with */
 159 STATIC SV*
 160 S_new_SV(pTHX)
 161 {
 162     SV* sv;
 163
 164     LOCK_SV_MUTEX;
 165     if (PL_sv_root)
 166         uproot_SV(sv);
 167     else
 168         sv = more_sv();
 169     UNLOCK_SV_MUTEX;
 170     SvANY(sv) = 0;
 171     SvREFCNT(sv) = 1;
 172     SvFLAGS(sv) = 0;
 173     return sv;
 174 }
 175 #  define new_SV(p) (p)=S_new_SV(aTHX)
 176
 177 #else
 178 #  define new_SV(p) \
 179     STMT_START {                                        \
 180         LOCK_SV_MUTEX;                                  \
 181         if (PL_sv_root)                                 \
 182             uproot_SV(p);                               \
 183         else                                            \
 184             (p) = more_sv();                            \
 185         UNLOCK_SV_MUTEX;                                \
 186         SvANY(p) = 0;                                   \
 187         SvREFCNT(p) = 1;                                \
 188         SvFLAGS(p) = 0;                                 \
 189     } STMT_END
 190 #endif
 191
 192
 193 /* del_SV(): return an empty SV head to the free list */
 194
 195 #ifdef DEBUGGING
 196
 197 #define del_SV(p) \
 198     STMT_START {                                        \
 199         LOCK_SV_MUTEX;                                  \
 200         if (DEBUG_D_TEST)                               \
 201             del_sv(p);                                  \
 202         else                                            \
 203             plant_SV(p);                                \
 204         UNLOCK_SV_MUTEX;                                \
 205     } STMT_END
 206
 207 STATIC void
 208 S_del_sv(pTHX_ SV *p)
 209 {
 210     if (DEBUG_D_TEST) {
 211         SV* sva;
 212         SV* sv;
 213         SV* svend;
 214         int ok = 0;
 215         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
 216             sv = sva + 1;
 217             svend = &sva[SvREFCNT(sva)];
 218             if (p >= sv && p < svend)
 219                 ok = 1;
 220         }
 221         if (!ok) {
 222             if (ckWARN_d(WARN_INTERNAL))
 223                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 224                             "Attempt to free non-arena SV: 0x%"UVxf,
 225                             PTR2UV(p));
 226             return;
 227         }
 228     }
 229     plant_SV(p);
 230 }
 231
 232 #else /* ! DEBUGGING */
 233
 234 #define del_SV(p)   plant_SV(p)
 235
 236 #endif /* DEBUGGING */
 237
 238
 239 /*
 240 =head1 SV Manipulation Functions
 241
 242 =for apidoc sv_add_arena
 243
 244 Given a chunk of memory, link it to the head of the list of arenas,
 245 and split it into a list of free SVs.
 246
 247 =cut
 248 */
 249
 250 void
 251 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
 252 {
 253     SV* sva = (SV*)ptr;
 254     register SV* sv;
 255     register SV* svend;
 256     Zero(ptr, size, char);
 257
 258     /* The first SV in an arena isn't an SV. */
 259     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 260     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 261     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 262
 263     PL_sv_arenaroot = sva;
 264     PL_sv_root = sva + 1;
 265
 266     svend = &sva[SvREFCNT(sva) - 1];
 267     sv = sva + 1;
 268     while (sv < svend) {
 269         SvANY(sv) = (void *)(SV*)(sv + 1);
 270         SvFLAGS(sv) = SVTYPEMASK;
 271         sv++;
 272     }
 273     SvANY(sv) = 0;
 274     SvFLAGS(sv) = SVTYPEMASK;
 275 }
 276
 277 /* make some more SVs by adding another arena */
 278
 279 /* sv_mutex must be held while calling more_sv() */
 280 STATIC SV*
 281 S_more_sv(pTHX)
 282 {
 283     register SV* sv;
 284
 285     if (PL_nice_chunk) {
 286         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 287         PL_nice_chunk = Nullch;
 288         PL_nice_chunk_size = 0;
 289     }
 290     else {
 291         char *chunk;                /* must use New here to match call to */
 292         New(704,chunk,1008,char);   /* Safefree() in sv_free_arenas()     */
 293         sv_add_arena(chunk, 1008, 0);
 294     }
 295     uproot_SV(sv);
 296     return sv;
 297 }
 298
 299 /* visit(): call the named function for each non-free SV in the arenas. */
 300
 301 STATIC I32
 302 S_visit(pTHX_ SVFUNC_t f)
 303 {
 304     SV* sva;
 305     SV* sv;
 306     register SV* svend;
 307     I32 visited = 0;
 308
 309     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 310         svend = &sva[SvREFCNT(sva)];
 311         for (sv = sva + 1; sv < svend; ++sv) {
 312             if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
 313                 (FCALL)(aTHX_ sv);
 314                 ++visited;
 315             }
 316         }
 317     }
 318     return visited;
 319 }
 320
 321 #ifdef DEBUGGING
 322
 323 /* called by sv_report_used() for each live SV */
 324
 325 static void
 326 do_report_used(pTHX_ SV *sv)
 327 {
 328     if (SvTYPE(sv) != SVTYPEMASK) {
 329         PerlIO_printf(Perl_debug_log, "****\n");
 330         sv_dump(sv);
 331     }
 332 }
 333 #endif
 334
 335 /*
 336 =for apidoc sv_report_used
 337
 338 Dump the contents of all SVs not yet freed. (Debugging aid).
 339
 340 =cut
 341 */
 342
 343 void
 344 Perl_sv_report_used(pTHX)
 345 {
 346 #ifdef DEBUGGING
 347     visit(do_report_used);
 348 #endif
 349 }
 350
 351 /* called by sv_clean_objs() for each live SV */
 352
 353 static void
 354 do_clean_objs(pTHX_ SV *sv)
 355 {
 356     SV* rv;
 357
 358     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
 359         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
 360         if (SvWEAKREF(sv)) {
 361             sv_del_backref(sv);
 362             SvWEAKREF_off(sv);
 363             SvRV(sv) = 0;
 364         } else {
 365             SvROK_off(sv);
 366             SvRV(sv) = 0;
 367             SvREFCNT_dec(rv);
 368         }
 369     }
 370
 371     /* XXX Might want to check arrays, etc. */
 372 }
 373
 374 /* called by sv_clean_objs() for each live SV */
 375
 376 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 377 static void
 378 do_clean_named_objs(pTHX_ SV *sv)
 379 {
 380     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
 381         if ( SvOBJECT(GvSV(sv)) ||
 382              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
 383              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
 384              (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
 385              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
 386         {
 387             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
 388             SvREFCNT_dec(sv);
 389         }
 390     }
 391 }
 392 #endif
 393
 394 /*
 395 =for apidoc sv_clean_objs
 396
 397 Attempt to destroy all objects not yet freed
 398
 399 =cut
 400 */
 401
 402 void
 403 Perl_sv_clean_objs(pTHX)
 404 {
 405     PL_in_clean_objs = TRUE;
 406     visit(do_clean_objs);
 407 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 408     /* some barnacles may yet remain, clinging to typeglobs */
 409     visit(do_clean_named_objs);
 410 #endif
 411     PL_in_clean_objs = FALSE;
 412 }
 413
 414 /* called by sv_clean_all() for each live SV */
 415
 416 static void
 417 do_clean_all(pTHX_ SV *sv)
 418 {
 419     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
 420     SvFLAGS(sv) |= SVf_BREAK;
 421     SvREFCNT_dec(sv);
 422 }
 423
 424 /*
 425 =for apidoc sv_clean_all
 426
 427 Decrement the refcnt of each remaining SV, possibly triggering a
 428 cleanup. This function may have to be called multiple times to free
 429 SVs which are in complex self-referential hierarchies.
 430
 431 =cut
 432 */
 433
 434 I32
 435 Perl_sv_clean_all(pTHX)
 436 {
 437     I32 cleaned;
 438     PL_in_clean_all = TRUE;
 439     cleaned = visit(do_clean_all);
 440     PL_in_clean_all = FALSE;
 441     return cleaned;
 442 }
 443
 444 /*
 445 =for apidoc sv_free_arenas
 446
 447 Deallocate the memory used by all arenas. Note that all the individual SV
 448 heads and bodies within the arenas must already have been freed.
 449
 450 =cut
 451 */
 452
 453 void
 454 Perl_sv_free_arenas(pTHX)
 455 {
 456     SV* sva;
 457     SV* svanext;
 458     XPV *arena, *arenanext;
 459
 460     /* Free arenas here, but be careful about fake ones.  (We assume
 461        contiguity of the fake ones with the corresponding real ones.) */
 462
 463     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 464         svanext = (SV*) SvANY(sva);
 465         while (svanext && SvFAKE(svanext))
 466             svanext = (SV*) SvANY(svanext);
 467
 468         if (!SvFAKE(sva))
 469             Safefree((void *)sva);
 470     }
 471
 472     for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
 473         arenanext = (XPV*)arena->xpv_pv;
 474         Safefree(arena);
 475     }
 476     PL_xiv_arenaroot = 0;
 477
 478     for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
 479         arenanext = (XPV*)arena->xpv_pv;
 480         Safefree(arena);
 481     }
 482     PL_xnv_arenaroot = 0;
 483
 484     for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
 485         arenanext = (XPV*)arena->xpv_pv;
 486         Safefree(arena);
 487     }
 488     PL_xrv_arenaroot = 0;
 489
 490     for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
 491         arenanext = (XPV*)arena->xpv_pv;
 492         Safefree(arena);
 493     }
 494     PL_xpv_arenaroot = 0;
 495
 496     for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
 497         arenanext = (XPV*)arena->xpv_pv;
 498         Safefree(arena);
 499     }
 500     PL_xpviv_arenaroot = 0;
 501
 502     for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
 503         arenanext = (XPV*)arena->xpv_pv;
 504         Safefree(arena);
 505     }
 506     PL_xpvnv_arenaroot = 0;
 507
 508     for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
 509         arenanext = (XPV*)arena->xpv_pv;
 510         Safefree(arena);
 511     }
 512     PL_xpvcv_arenaroot = 0;
 513
 514     for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
 515         arenanext = (XPV*)arena->xpv_pv;
 516         Safefree(arena);
 517     }
 518     PL_xpvav_arenaroot = 0;
 519
 520     for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
 521         arenanext = (XPV*)arena->xpv_pv;
 522         Safefree(arena);
 523     }
 524     PL_xpvhv_arenaroot = 0;
 525
 526     for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
 527         arenanext = (XPV*)arena->xpv_pv;
 528         Safefree(arena);
 529     }
 530     PL_xpvmg_arenaroot = 0;
 531
 532     for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
 533         arenanext = (XPV*)arena->xpv_pv;
 534         Safefree(arena);
 535     }
 536     PL_xpvlv_arenaroot = 0;
 537
 538     for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
 539         arenanext = (XPV*)arena->xpv_pv;
 540         Safefree(arena);
 541     }
 542     PL_xpvbm_arenaroot = 0;
 543
 544     for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
 545         arenanext = (XPV*)arena->xpv_pv;
 546         Safefree(arena);
 547     }
 548     PL_he_arenaroot = 0;
 549
 550     if (PL_nice_chunk)
 551         Safefree(PL_nice_chunk);
 552     PL_nice_chunk = Nullch;
 553     PL_nice_chunk_size = 0;
 554     PL_sv_arenaroot = 0;
 555     PL_sv_root = 0;
 556 }
 557
 558 /*
 559 =for apidoc report_uninit
 560
 561 Print appropriate "Use of uninitialized variable" warning
 562
 563 =cut
 564 */
 565
 566 void
 567 Perl_report_uninit(pTHX)
 568 {
 569     if (PL_op)
 570         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
 571                     " in ", OP_DESC(PL_op));
 572     else
 573         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
 574 }
 575
 576 /* grab a new IV body from the free list, allocating more if necessary */
 577
 578 STATIC XPVIV*
 579 S_new_xiv(pTHX)
 580 {
 581     IV* xiv;
 582     LOCK_SV_MUTEX;
 583     if (!PL_xiv_root)
 584         more_xiv();
 585     xiv = PL_xiv_root;
 586     /*
 587      * See comment in more_xiv() -- RAM.
 588      */
 589     PL_xiv_root = *(IV**)xiv;
 590     UNLOCK_SV_MUTEX;
 591     return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
 592 }
 593
 594 /* return an IV body to the free list */
 595
 596 STATIC void
 597 S_del_xiv(pTHX_ XPVIV *p)
 598 {
 599     IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
 600     LOCK_SV_MUTEX;
 601     *(IV**)xiv = PL_xiv_root;
 602     PL_xiv_root = xiv;
 603     UNLOCK_SV_MUTEX;
 604 }
 605
 606 /* allocate another arena's worth of IV bodies */
 607
 608 STATIC void
 609 S_more_xiv(pTHX)
 610 {
 611     register IV* xiv;
 612     register IV* xivend;
 613     XPV* ptr;
 614     New(705, ptr, 1008/sizeof(XPV), XPV);
 615     ptr->xpv_pv = (char*)PL_xiv_arenaroot;      /* linked list of xiv arenas */
 616     PL_xiv_arenaroot = ptr;                     /* to keep Purify happy */
 617
 618     xiv = (IV*) ptr;
 619     xivend = &xiv[1008 / sizeof(IV) - 1];
 620     xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1;  /* fudge by size of XPV */
 621     PL_xiv_root = xiv;
 622     while (xiv < xivend) {
 623         *(IV**)xiv = (IV *)(xiv + 1);
 624         xiv++;
 625     }
 626     *(IV**)xiv = 0;
 627 }
 628
 629 /* grab a new NV body from the free list, allocating more if necessary */
 630
 631 STATIC XPVNV*
 632 S_new_xnv(pTHX)
 633 {
 634     NV* xnv;
 635     LOCK_SV_MUTEX;
 636     if (!PL_xnv_root)
 637         more_xnv();
 638     xnv = PL_xnv_root;
 639     PL_xnv_root = *(NV**)xnv;
 640     UNLOCK_SV_MUTEX;
 641     return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
 642 }
 643
 644 /* return an NV body to the free list */
 645
 646 STATIC void
 647 S_del_xnv(pTHX_ XPVNV *p)
 648 {
 649     NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
 650     LOCK_SV_MUTEX;
 651     *(NV**)xnv = PL_xnv_root;
 652     PL_xnv_root = xnv;
 653     UNLOCK_SV_MUTEX;
 654 }
 655
 656 /* allocate another arena's worth of NV bodies */
 657
 658 STATIC void
 659 S_more_xnv(pTHX)
 660 {
 661     register NV* xnv;
 662     register NV* xnvend;
 663     XPV *ptr;
 664     New(711, ptr, 1008/sizeof(XPV), XPV);
 665     ptr->xpv_pv = (char*)PL_xnv_arenaroot;
 666     PL_xnv_arenaroot = ptr;
 667
 668     xnv = (NV*) ptr;
 669     xnvend = &xnv[1008 / sizeof(NV) - 1];
 670     xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
 671     PL_xnv_root = xnv;
 672     while (xnv < xnvend) {
 673         *(NV**)xnv = (NV*)(xnv + 1);
 674         xnv++;
 675     }
 676     *(NV**)xnv = 0;
 677 }
 678
 679 /* grab a new struct xrv from the free list, allocating more if necessary */
 680
 681 STATIC XRV*
 682 S_new_xrv(pTHX)
 683 {
 684     XRV* xrv;
 685     LOCK_SV_MUTEX;
 686     if (!PL_xrv_root)
 687         more_xrv();
 688     xrv = PL_xrv_root;
 689     PL_xrv_root = (XRV*)xrv->xrv_rv;
 690     UNLOCK_SV_MUTEX;
 691     return xrv;
 692 }
 693
 694 /* return a struct xrv to the free list */
 695
 696 STATIC void
 697 S_del_xrv(pTHX_ XRV *p)
 698 {
 699     LOCK_SV_MUTEX;
 700     p->xrv_rv = (SV*)PL_xrv_root;
 701     PL_xrv_root = p;
 702     UNLOCK_SV_MUTEX;
 703 }
 704
 705 /* allocate another arena's worth of struct xrv */
 706
 707 STATIC void
 708 S_more_xrv(pTHX)
 709 {
 710     register XRV* xrv;
 711     register XRV* xrvend;
 712     XPV *ptr;
 713     New(712, ptr, 1008/sizeof(XPV), XPV);
 714     ptr->xpv_pv = (char*)PL_xrv_arenaroot;
 715     PL_xrv_arenaroot = ptr;
 716
 717     xrv = (XRV*) ptr;
 718     xrvend = &xrv[1008 / sizeof(XRV) - 1];
 719     xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
 720     PL_xrv_root = xrv;
 721     while (xrv < xrvend) {
 722         xrv->xrv_rv = (SV*)(xrv + 1);
 723         xrv++;
 724     }
 725     xrv->xrv_rv = 0;
 726 }
 727
 728 /* grab a new struct xpv from the free list, allocating more if necessary */
 729
 730 STATIC XPV*
 731 S_new_xpv(pTHX)
 732 {
 733     XPV* xpv;
 734     LOCK_SV_MUTEX;
 735     if (!PL_xpv_root)
 736         more_xpv();
 737     xpv = PL_xpv_root;
 738     PL_xpv_root = (XPV*)xpv->xpv_pv;
 739     UNLOCK_SV_MUTEX;
 740     return xpv;
 741 }
 742
 743 /* return a struct xpv to the free list */
 744
 745 STATIC void
 746 S_del_xpv(pTHX_ XPV *p)
 747 {
 748     LOCK_SV_MUTEX;
 749     p->xpv_pv = (char*)PL_xpv_root;
 750     PL_xpv_root = p;
 751     UNLOCK_SV_MUTEX;
 752 }
 753
 754 /* allocate another arena's worth of struct xpv */
 755
 756 STATIC void
 757 S_more_xpv(pTHX)
 758 {
 759     register XPV* xpv;
 760     register XPV* xpvend;
 761     New(713, xpv, 1008/sizeof(XPV), XPV);
 762     xpv->xpv_pv = (char*)PL_xpv_arenaroot;
 763     PL_xpv_arenaroot = xpv;
 764
 765     xpvend = &xpv[1008 / sizeof(XPV) - 1];
 766     PL_xpv_root = ++xpv;
 767     while (xpv < xpvend) {
 768         xpv->xpv_pv = (char*)(xpv + 1);
 769         xpv++;
 770     }
 771     xpv->xpv_pv = 0;
 772 }
 773
 774 /* grab a new struct xpviv from the free list, allocating more if necessary */
 775
 776 STATIC XPVIV*
 777 S_new_xpviv(pTHX)
 778 {
 779     XPVIV* xpviv;
 780     LOCK_SV_MUTEX;
 781     if (!PL_xpviv_root)
 782         more_xpviv();
 783     xpviv = PL_xpviv_root;
 784     PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
 785     UNLOCK_SV_MUTEX;
 786     return xpviv;
 787 }
 788
 789 /* return a struct xpviv to the free list */
 790
 791 STATIC void
 792 S_del_xpviv(pTHX_ XPVIV *p)
 793 {
 794     LOCK_SV_MUTEX;
 795     p->xpv_pv = (char*)PL_xpviv_root;
 796     PL_xpviv_root = p;
 797     UNLOCK_SV_MUTEX;
 798 }
 799
 800 /* allocate another arena's worth of struct xpviv */
 801
 802 STATIC void
 803 S_more_xpviv(pTHX)
 804 {
 805     register XPVIV* xpviv;
 806     register XPVIV* xpvivend;
 807     New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
 808     xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
 809     PL_xpviv_arenaroot = xpviv;
 810
 811     xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
 812     PL_xpviv_root = ++xpviv;
 813     while (xpviv < xpvivend) {
 814         xpviv->xpv_pv = (char*)(xpviv + 1);
 815         xpviv++;
 816     }
 817     xpviv->xpv_pv = 0;
 818 }
 819
 820 /* grab a new struct xpvnv from the free list, allocating more if necessary */
 821
 822 STATIC XPVNV*
 823 S_new_xpvnv(pTHX)
 824 {
 825     XPVNV* xpvnv;
 826     LOCK_SV_MUTEX;
 827     if (!PL_xpvnv_root)
 828         more_xpvnv();
 829     xpvnv = PL_xpvnv_root;
 830     PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
 831     UNLOCK_SV_MUTEX;
 832     return xpvnv;
 833 }
 834
 835 /* return a struct xpvnv to the free list */
 836
 837 STATIC void
 838 S_del_xpvnv(pTHX_ XPVNV *p)
 839 {
 840     LOCK_SV_MUTEX;
 841     p->xpv_pv = (char*)PL_xpvnv_root;
 842     PL_xpvnv_root = p;
 843     UNLOCK_SV_MUTEX;
 844 }
 845
 846 /* allocate another arena's worth of struct xpvnv */
 847
 848 STATIC void
 849 S_more_xpvnv(pTHX)
 850 {
 851     register XPVNV* xpvnv;
 852     register XPVNV* xpvnvend;
 853     New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
 854     xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
 855     PL_xpvnv_arenaroot = xpvnv;
 856
 857     xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
 858     PL_xpvnv_root = ++xpvnv;
 859     while (xpvnv < xpvnvend) {
 860         xpvnv->xpv_pv = (char*)(xpvnv + 1);
 861         xpvnv++;
 862     }
 863     xpvnv->xpv_pv = 0;
 864 }
 865
 866 /* grab a new struct xpvcv from the free list, allocating more if necessary */
 867
 868 STATIC XPVCV*
 869 S_new_xpvcv(pTHX)
 870 {
 871     XPVCV* xpvcv;
 872     LOCK_SV_MUTEX;
 873     if (!PL_xpvcv_root)
 874         more_xpvcv();
 875     xpvcv = PL_xpvcv_root;
 876     PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
 877     UNLOCK_SV_MUTEX;
 878     return xpvcv;
 879 }
 880
 881 /* return a struct xpvcv to the free list */
 882
 883 STATIC void
 884 S_del_xpvcv(pTHX_ XPVCV *p)
 885 {
 886     LOCK_SV_MUTEX;
 887     p->xpv_pv = (char*)PL_xpvcv_root;
 888     PL_xpvcv_root = p;
 889     UNLOCK_SV_MUTEX;
 890 }
 891
 892 /* allocate another arena's worth of struct xpvcv */
 893
 894 STATIC void
 895 S_more_xpvcv(pTHX)
 896 {
 897     register XPVCV* xpvcv;
 898     register XPVCV* xpvcvend;
 899     New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
 900     xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
 901     PL_xpvcv_arenaroot = xpvcv;
 902
 903     xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
 904     PL_xpvcv_root = ++xpvcv;
 905     while (xpvcv < xpvcvend) {
 906         xpvcv->xpv_pv = (char*)(xpvcv + 1);
 907         xpvcv++;
 908     }
 909     xpvcv->xpv_pv = 0;
 910 }
 911
 912 /* grab a new struct xpvav from the free list, allocating more if necessary */
 913
 914 STATIC XPVAV*
 915 S_new_xpvav(pTHX)
 916 {
 917     XPVAV* xpvav;
 918     LOCK_SV_MUTEX;
 919     if (!PL_xpvav_root)
 920         more_xpvav();
 921     xpvav = PL_xpvav_root;
 922     PL_xpvav_root = (XPVAV*)xpvav->xav_array;
 923     UNLOCK_SV_MUTEX;
 924     return xpvav;
 925 }
 926
 927 /* return a struct xpvav to the free list */
 928
 929 STATIC void
 930 S_del_xpvav(pTHX_ XPVAV *p)
 931 {
 932     LOCK_SV_MUTEX;
 933     p->xav_array = (char*)PL_xpvav_root;
 934     PL_xpvav_root = p;
 935     UNLOCK_SV_MUTEX;
 936 }
 937
 938 /* allocate another arena's worth of struct xpvav */
 939
 940 STATIC void
 941 S_more_xpvav(pTHX)
 942 {
 943     register XPVAV* xpvav;
 944     register XPVAV* xpvavend;
 945     New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
 946     xpvav->xav_array = (char*)PL_xpvav_arenaroot;
 947     PL_xpvav_arenaroot = xpvav;
 948
 949     xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
 950     PL_xpvav_root = ++xpvav;
 951     while (xpvav < xpvavend) {
 952         xpvav->xav_array = (char*)(xpvav + 1);
 953         xpvav++;
 954     }
 955     xpvav->xav_array = 0;
 956 }
 957
 958 /* grab a new struct xpvhv from the free list, allocating more if necessary */
 959
 960 STATIC XPVHV*
 961 S_new_xpvhv(pTHX)
 962 {
 963     XPVHV* xpvhv;
 964     LOCK_SV_MUTEX;
 965     if (!PL_xpvhv_root)
 966         more_xpvhv();
 967     xpvhv = PL_xpvhv_root;
 968     PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
 969     UNLOCK_SV_MUTEX;
 970     return xpvhv;
 971 }
 972
 973 /* return a struct xpvhv to the free list */
 974
 975 STATIC void
 976 S_del_xpvhv(pTHX_ XPVHV *p)
 977 {
 978     LOCK_SV_MUTEX;
 979     p->xhv_array = (char*)PL_xpvhv_root;
 980     PL_xpvhv_root = p;
 981     UNLOCK_SV_MUTEX;
 982 }
 983
 984 /* allocate another arena's worth of struct xpvhv */
 985
 986 STATIC void
 987 S_more_xpvhv(pTHX)
 988 {
 989     register XPVHV* xpvhv;
 990     register XPVHV* xpvhvend;
 991     New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
 992     xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
 993     PL_xpvhv_arenaroot = xpvhv;
 994
 995     xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
 996     PL_xpvhv_root = ++xpvhv;
 997     while (xpvhv < xpvhvend) {
 998         xpvhv->xhv_array = (char*)(xpvhv + 1);
 999         xpvhv++;
1000     }
1001     xpvhv->xhv_array = 0;
1002 }
1003
1004 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1005
1006 STATIC XPVMG*
1007 S_new_xpvmg(pTHX)
1008 {
1009     XPVMG* xpvmg;
1010     LOCK_SV_MUTEX;
1011     if (!PL_xpvmg_root)
1012         more_xpvmg();
1013     xpvmg = PL_xpvmg_root;
1014     PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1015     UNLOCK_SV_MUTEX;
1016     return xpvmg;
1017 }
1018
1019 /* return a struct xpvmg to the free list */
1020
1021 STATIC void
1022 S_del_xpvmg(pTHX_ XPVMG *p)
1023 {
1024     LOCK_SV_MUTEX;
1025     p->xpv_pv = (char*)PL_xpvmg_root;
1026     PL_xpvmg_root = p;
1027     UNLOCK_SV_MUTEX;
1028 }
1029
1030 /* allocate another arena's worth of struct xpvmg */
1031
1032 STATIC void
1033 S_more_xpvmg(pTHX)
1034 {
1035     register XPVMG* xpvmg;
1036     register XPVMG* xpvmgend;
1037     New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1038     xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1039     PL_xpvmg_arenaroot = xpvmg;
1040
1041     xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1042     PL_xpvmg_root = ++xpvmg;
1043     while (xpvmg < xpvmgend) {
1044         xpvmg->xpv_pv = (char*)(xpvmg + 1);
1045         xpvmg++;
1046     }
1047     xpvmg->xpv_pv = 0;
1048 }
1049
1050 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1051
1052 STATIC XPVLV*
1053 S_new_xpvlv(pTHX)
1054 {
1055     XPVLV* xpvlv;
1056     LOCK_SV_MUTEX;
1057     if (!PL_xpvlv_root)
1058         more_xpvlv();
1059     xpvlv = PL_xpvlv_root;
1060     PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1061     UNLOCK_SV_MUTEX;
1062     return xpvlv;
1063 }
1064
1065 /* return a struct xpvlv to the free list */
1066
1067 STATIC void
1068 S_del_xpvlv(pTHX_ XPVLV *p)
1069 {
1070     LOCK_SV_MUTEX;
1071     p->xpv_pv = (char*)PL_xpvlv_root;
1072     PL_xpvlv_root = p;
1073     UNLOCK_SV_MUTEX;
1074 }
1075
1076 /* allocate another arena's worth of struct xpvlv */
1077
1078 STATIC void
1079 S_more_xpvlv(pTHX)
1080 {
1081     register XPVLV* xpvlv;
1082     register XPVLV* xpvlvend;
1083     New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1084     xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1085     PL_xpvlv_arenaroot = xpvlv;
1086
1087     xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1088     PL_xpvlv_root = ++xpvlv;
1089     while (xpvlv < xpvlvend) {
1090         xpvlv->xpv_pv = (char*)(xpvlv + 1);
1091         xpvlv++;
1092     }
1093     xpvlv->xpv_pv = 0;
1094 }
1095
1096 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1097
1098 STATIC XPVBM*
1099 S_new_xpvbm(pTHX)
1100 {
1101     XPVBM* xpvbm;
1102     LOCK_SV_MUTEX;
1103     if (!PL_xpvbm_root)
1104         more_xpvbm();
1105     xpvbm = PL_xpvbm_root;
1106     PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1107     UNLOCK_SV_MUTEX;
1108     return xpvbm;
1109 }
1110
1111 /* return a struct xpvbm to the free list */
1112
1113 STATIC void
1114 S_del_xpvbm(pTHX_ XPVBM *p)
1115 {
1116     LOCK_SV_MUTEX;
1117     p->xpv_pv = (char*)PL_xpvbm_root;
1118     PL_xpvbm_root = p;
1119     UNLOCK_SV_MUTEX;
1120 }
1121
1122 /* allocate another arena's worth of struct xpvbm */
1123
1124 STATIC void
1125 S_more_xpvbm(pTHX)
1126 {
1127     register XPVBM* xpvbm;
1128     register XPVBM* xpvbmend;
1129     New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1130     xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1131     PL_xpvbm_arenaroot = xpvbm;
1132
1133     xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1134     PL_xpvbm_root = ++xpvbm;
1135     while (xpvbm < xpvbmend) {
1136         xpvbm->xpv_pv = (char*)(xpvbm + 1);
1137         xpvbm++;
1138     }
1139     xpvbm->xpv_pv = 0;
1140 }
1141
1142 #define my_safemalloc(s)        (void*)safemalloc(s)
1143 #define my_safefree(p)  safefree((char*)p)
1144
1145 #ifdef PURIFY
1146
1147 #define new_XIV()       my_safemalloc(sizeof(XPVIV))
1148 #define del_XIV(p)      my_safefree(p)
1149
1150 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
1151 #define del_XNV(p)      my_safefree(p)
1152
1153 #define new_XRV()       my_safemalloc(sizeof(XRV))
1154 #define del_XRV(p)      my_safefree(p)
1155
1156 #define new_XPV()       my_safemalloc(sizeof(XPV))
1157 #define del_XPV(p)      my_safefree(p)
1158
1159 #define new_XPVIV()     my_safemalloc(sizeof(XPVIV))
1160 #define del_XPVIV(p)    my_safefree(p)
1161
1162 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
1163 #define del_XPVNV(p)    my_safefree(p)
1164
1165 #define new_XPVCV()     my_safemalloc(sizeof(XPVCV))
1166 #define del_XPVCV(p)    my_safefree(p)
1167
1168 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
1169 #define del_XPVAV(p)    my_safefree(p)
1170
1171 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
1172 #define del_XPVHV(p)    my_safefree(p)
1173
1174 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
1175 #define del_XPVMG(p)    my_safefree(p)
1176
1177 #define new_XPVLV()     my_safemalloc(sizeof(XPVLV))
1178 #define del_XPVLV(p)    my_safefree(p)
1179
1180 #define new_XPVBM()     my_safemalloc(sizeof(XPVBM))
1181 #define del_XPVBM(p)    my_safefree(p)
1182
1183 #else /* !PURIFY */
1184
1185 #define new_XIV()       (void*)new_xiv()
1186 #define del_XIV(p)      del_xiv((XPVIV*) p)
1187
1188 #define new_XNV()       (void*)new_xnv()
1189 #define del_XNV(p)      del_xnv((XPVNV*) p)
1190
1191 #define new_XRV()       (void*)new_xrv()
1192 #define del_XRV(p)      del_xrv((XRV*) p)
1193
1194 #define new_XPV()       (void*)new_xpv()
1195 #define del_XPV(p)      del_xpv((XPV *)p)
1196
1197 #define new_XPVIV()     (void*)new_xpviv()
1198 #define del_XPVIV(p)    del_xpviv((XPVIV *)p)
1199
1200 #define new_XPVNV()     (void*)new_xpvnv()
1201 #define del_XPVNV(p)    del_xpvnv((XPVNV *)p)
1202
1203 #define new_XPVCV()     (void*)new_xpvcv()
1204 #define del_XPVCV(p)    del_xpvcv((XPVCV *)p)
1205
1206 #define new_XPVAV()     (void*)new_xpvav()
1207 #define del_XPVAV(p)    del_xpvav((XPVAV *)p)
1208
1209 #define new_XPVHV()     (void*)new_xpvhv()
1210 #define del_XPVHV(p)    del_xpvhv((XPVHV *)p)
1211
1212 #define new_XPVMG()     (void*)new_xpvmg()
1213 #define del_XPVMG(p)    del_xpvmg((XPVMG *)p)
1214
1215 #define new_XPVLV()     (void*)new_xpvlv()
1216 #define del_XPVLV(p)    del_xpvlv((XPVLV *)p)
1217
1218 #define new_XPVBM()     (void*)new_xpvbm()
1219 #define del_XPVBM(p)    del_xpvbm((XPVBM *)p)
1220
1221 #endif /* PURIFY */
1222
1223 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
1224 #define del_XPVGV(p)    my_safefree(p)
1225
1226 #define new_XPVFM()     my_safemalloc(sizeof(XPVFM))
1227 #define del_XPVFM(p)    my_safefree(p)
1228
1229 #define new_XPVIO()     my_safemalloc(sizeof(XPVIO))
1230 #define del_XPVIO(p)    my_safefree(p)
1231
1232 /*
1233 =for apidoc sv_upgrade
1234
1235 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1236 SV, then copies across as much information as possible from the old body.
1237 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1238
1239 =cut
1240 */
1241
1242 bool
1243 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1244 {
1245     char*       pv = NULL;
1246     U32         cur = 0;
1247     U32         len = 0;
1248     IV          iv = 0;
1249     NV          nv = 0.0;
1250     MAGIC*      magic = NULL;
1251     HV*         stash = Nullhv;
1252
1253     if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
1254         sv_force_normal(sv);
1255     }
1256
1257     if (SvTYPE(sv) == mt)
1258         return TRUE;
1259
1260     if (mt < SVt_PVIV)
1261         (void)SvOOK_off(sv);
1262
1263     switch (SvTYPE(sv)) {
1264     case SVt_NULL:
1265         pv      = 0;
1266         cur     = 0;
1267         len     = 0;
1268         iv      = 0;
1269         nv      = 0.0;
1270         magic   = 0;
1271         stash   = 0;
1272         break;
1273     case SVt_IV:
1274         pv      = 0;
1275         cur     = 0;
1276         len     = 0;
1277         iv      = SvIVX(sv);
1278         nv      = (NV)SvIVX(sv);
1279         del_XIV(SvANY(sv));
1280         magic   = 0;
1281         stash   = 0;
1282         if (mt == SVt_NV)
1283             mt = SVt_PVNV;
1284         else if (mt < SVt_PVIV)
1285             mt = SVt_PVIV;
1286         break;
1287     case SVt_NV:
1288         pv      = 0;
1289         cur     = 0;
1290         len     = 0;
1291         nv      = SvNVX(sv);
1292         iv      = I_V(nv);
1293         magic   = 0;
1294         stash   = 0;
1295         del_XNV(SvANY(sv));
1296         SvANY(sv) = 0;
1297         if (mt < SVt_PVNV)
1298             mt = SVt_PVNV;
1299         break;
1300     case SVt_RV:
1301         pv      = (char*)SvRV(sv);
1302         cur     = 0;
1303         len     = 0;
1304         iv      = PTR2IV(pv);
1305         nv      = PTR2NV(pv);
1306         del_XRV(SvANY(sv));
1307         magic   = 0;
1308         stash   = 0;
1309         break;
1310     case SVt_PV:
1311         pv      = SvPVX(sv);
1312         cur     = SvCUR(sv);
1313         len     = SvLEN(sv);
1314         iv      = 0;
1315         nv      = 0.0;
1316         magic   = 0;
1317         stash   = 0;
1318         del_XPV(SvANY(sv));
1319         if (mt <= SVt_IV)
1320             mt = SVt_PVIV;
1321         else if (mt == SVt_NV)
1322             mt = SVt_PVNV;
1323         break;
1324     case SVt_PVIV:
1325         pv      = SvPVX(sv);
1326         cur     = SvCUR(sv);
1327         len     = SvLEN(sv);
1328         iv      = SvIVX(sv);
1329         nv      = 0.0;
1330         magic   = 0;
1331         stash   = 0;
1332         del_XPVIV(SvANY(sv));
1333         break;
1334     case SVt_PVNV:
1335         pv      = SvPVX(sv);
1336         cur     = SvCUR(sv);
1337         len     = SvLEN(sv);
1338         iv      = SvIVX(sv);
1339         nv      = SvNVX(sv);
1340         magic   = 0;
1341         stash   = 0;
1342         del_XPVNV(SvANY(sv));
1343         break;
1344     case SVt_PVMG:
1345         pv      = SvPVX(sv);
1346         cur     = SvCUR(sv);
1347         len     = SvLEN(sv);
1348         iv      = SvIVX(sv);
1349         nv      = SvNVX(sv);
1350         magic   = SvMAGIC(sv);
1351         stash   = SvSTASH(sv);
1352         del_XPVMG(SvANY(sv));
1353         break;
1354     default:
1355         Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1356     }
1357
1358     switch (mt) {
1359     case SVt_NULL:
1360         Perl_croak(aTHX_ "Can't upgrade to undef");
1361     case SVt_IV:
1362         SvANY(sv) = new_XIV();
1363         SvIVX(sv)       = iv;
1364         break;
1365     case SVt_NV:
1366         SvANY(sv) = new_XNV();
1367         SvNVX(sv)       = nv;
1368         break;
1369     case SVt_RV:
1370         SvANY(sv) = new_XRV();
1371         SvRV(sv) = (SV*)pv;
1372         break;
1373     case SVt_PV:
1374         SvANY(sv) = new_XPV();
1375         SvPVX(sv)       = pv;
1376         SvCUR(sv)       = cur;
1377         SvLEN(sv)       = len;
1378         break;
1379     case SVt_PVIV:
1380         SvANY(sv) = new_XPVIV();
1381         SvPVX(sv)       = pv;
1382         SvCUR(sv)       = cur;
1383         SvLEN(sv)       = len;
1384         SvIVX(sv)       = iv;
1385         if (SvNIOK(sv))
1386             (void)SvIOK_on(sv);
1387         SvNOK_off(sv);
1388         break;
1389     case SVt_PVNV:
1390         SvANY(sv) = new_XPVNV();
1391         SvPVX(sv)       = pv;
1392         SvCUR(sv)       = cur;
1393         SvLEN(sv)       = len;
1394         SvIVX(sv)       = iv;
1395         SvNVX(sv)       = nv;
1396         break;
1397     case SVt_PVMG:
1398         SvANY(sv) = new_XPVMG();
1399         SvPVX(sv)       = pv;
1400         SvCUR(sv)       = cur;
1401         SvLEN(sv)       = len;
1402         SvIVX(sv)       = iv;
1403         SvNVX(sv)       = nv;
1404         SvMAGIC(sv)     = magic;
1405         SvSTASH(sv)     = stash;
1406         break;
1407     case SVt_PVLV:
1408         SvANY(sv) = new_XPVLV();
1409         SvPVX(sv)       = pv;
1410         SvCUR(sv)       = cur;
1411         SvLEN(sv)       = len;
1412         SvIVX(sv)       = iv;
1413         SvNVX(sv)       = nv;
1414         SvMAGIC(sv)     = magic;
1415         SvSTASH(sv)     = stash;
1416         LvTARGOFF(sv)   = 0;
1417         LvTARGLEN(sv)   = 0;
1418         LvTARG(sv)      = 0;
1419         LvTYPE(sv)      = 0;
1420         break;
1421     case SVt_PVAV:
1422         SvANY(sv) = new_XPVAV();
1423         if (pv)
1424             Safefree(pv);
1425         SvPVX(sv)       = 0;
1426         AvMAX(sv)       = -1;
1427         AvFILLp(sv)     = -1;
1428         SvIVX(sv)       = 0;
1429         SvNVX(sv)       = 0.0;
1430         SvMAGIC(sv)     = magic;
1431         SvSTASH(sv)     = stash;
1432         AvALLOC(sv)     = 0;
1433         AvARYLEN(sv)    = 0;
1434         AvFLAGS(sv)     = 0;
1435         break;
1436     case SVt_PVHV:
1437         SvANY(sv) = new_XPVHV();
1438         if (pv)
1439             Safefree(pv);
1440         SvPVX(sv)       = 0;
1441         HvFILL(sv)      = 0;
1442         HvMAX(sv)       = 0;
1443         HvTOTALKEYS(sv) = 0;
1444         HvPLACEHOLDERS(sv) = 0;
1445         SvMAGIC(sv)     = magic;
1446         SvSTASH(sv)     = stash;
1447         HvRITER(sv)     = 0;
1448         HvEITER(sv)     = 0;
1449         HvPMROOT(sv)    = 0;
1450         HvNAME(sv)      = 0;
1451         break;
1452     case SVt_PVCV:
1453         SvANY(sv) = new_XPVCV();
1454         Zero(SvANY(sv), 1, XPVCV);
1455         SvPVX(sv)       = pv;
1456         SvCUR(sv)       = cur;
1457         SvLEN(sv)       = len;
1458         SvIVX(sv)       = iv;
1459         SvNVX(sv)       = nv;
1460         SvMAGIC(sv)     = magic;
1461         SvSTASH(sv)     = stash;
1462         break;
1463     case SVt_PVGV:
1464         SvANY(sv) = new_XPVGV();
1465         SvPVX(sv)       = pv;
1466         SvCUR(sv)       = cur;
1467         SvLEN(sv)       = len;
1468         SvIVX(sv)       = iv;
1469         SvNVX(sv)       = nv;
1470         SvMAGIC(sv)     = magic;
1471         SvSTASH(sv)     = stash;
1472         GvGP(sv)        = 0;
1473         GvNAME(sv)      = 0;
1474         GvNAMELEN(sv)   = 0;
1475         GvSTASH(sv)     = 0;
1476         GvFLAGS(sv)     = 0;
1477         break;
1478     case SVt_PVBM:
1479         SvANY(sv) = new_XPVBM();
1480         SvPVX(sv)       = pv;
1481         SvCUR(sv)       = cur;
1482         SvLEN(sv)       = len;
1483         SvIVX(sv)       = iv;
1484         SvNVX(sv)       = nv;
1485         SvMAGIC(sv)     = magic;
1486         SvSTASH(sv)     = stash;
1487         BmRARE(sv)      = 0;
1488         BmUSEFUL(sv)    = 0;
1489         BmPREVIOUS(sv)  = 0;
1490         break;
1491     case SVt_PVFM:
1492         SvANY(sv) = new_XPVFM();
1493         Zero(SvANY(sv), 1, XPVFM);
1494         SvPVX(sv)       = pv;
1495         SvCUR(sv)       = cur;
1496         SvLEN(sv)       = len;
1497         SvIVX(sv)       = iv;
1498         SvNVX(sv)       = nv;
1499         SvMAGIC(sv)     = magic;
1500         SvSTASH(sv)     = stash;
1501         break;
1502     case SVt_PVIO:
1503         SvANY(sv) = new_XPVIO();
1504         Zero(SvANY(sv), 1, XPVIO);
1505         SvPVX(sv)       = pv;
1506         SvCUR(sv)       = cur;
1507         SvLEN(sv)       = len;
1508         SvIVX(sv)       = iv;
1509         SvNVX(sv)       = nv;
1510         SvMAGIC(sv)     = magic;
1511         SvSTASH(sv)     = stash;
1512         IoPAGE_LEN(sv)  = 60;
1513         break;
1514     }
1515     SvFLAGS(sv) &= ~SVTYPEMASK;
1516     SvFLAGS(sv) |= mt;
1517     return TRUE;
1518 }
1519
1520 /*
1521 =for apidoc sv_backoff
1522
1523 Remove any string offset. You should normally use the C<SvOOK_off> macro
1524 wrapper instead.
1525
1526 =cut
1527 */
1528
1529 int
1530 Perl_sv_backoff(pTHX_ register SV *sv)
1531 {
1532     assert(SvOOK(sv));
1533     if (SvIVX(sv)) {
1534         char *s = SvPVX(sv);
1535         SvLEN(sv) += SvIVX(sv);
1536         SvPVX(sv) -= SvIVX(sv);
1537         SvIV_set(sv, 0);
1538         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1539     }
1540     SvFLAGS(sv) &= ~SVf_OOK;
1541     return 0;
1542 }
1543
1544 /*
1545 =for apidoc sv_grow
1546
1547 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1548 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1549 Use the C<SvGROW> wrapper instead.
1550
1551 =cut
1552 */
1553
1554 char *
1555 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1556 {
1557     register char *s;
1558
1559
1560
1561 #ifdef HAS_64K_LIMIT
1562     if (newlen >= 0x10000) {
1563         PerlIO_printf(Perl_debug_log,
1564                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1565         my_exit(1);
1566     }
1567 #endif /* HAS_64K_LIMIT */
1568     if (SvROK(sv))
1569         sv_unref(sv);
1570     if (SvTYPE(sv) < SVt_PV) {
1571         sv_upgrade(sv, SVt_PV);
1572         s = SvPVX(sv);
1573     }
1574     else if (SvOOK(sv)) {       /* pv is offset? */
1575         sv_backoff(sv);
1576         s = SvPVX(sv);
1577         if (newlen > SvLEN(sv))
1578             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1579 #ifdef HAS_64K_LIMIT
1580         if (newlen >= 0x10000)
1581             newlen = 0xFFFF;
1582 #endif
1583     }
1584     else
1585         s = SvPVX(sv);
1586
1587     if (newlen > SvLEN(sv)) {           /* need more room? */
1588         if (SvLEN(sv) && s) {
1589 #ifdef MYMALLOC
1590             STRLEN l = malloced_size((void*)SvPVX(sv));
1591             if (newlen <= l) {
1592                 SvLEN_set(sv, l);
1593                 return s;
1594             } else
1595 #endif
1596             Renew(s,newlen,char);
1597         }
1598         else {
1599             /* sv_force_normal_flags() must not try to unshare the new
1600                PVX we allocate below. AMS 20010713 */
1601             if (SvREADONLY(sv) && SvFAKE(sv)) {
1602                 SvFAKE_off(sv);
1603                 SvREADONLY_off(sv);
1604             }
1605             New(703, s, newlen, char);
1606             if (SvPVX(sv) && SvCUR(sv)) {
1607                 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1608             }
1609         }
1610         SvPV_set(sv, s);
1611         SvLEN_set(sv, newlen);
1612     }
1613     return s;
1614 }
1615
1616 /*
1617 =for apidoc sv_setiv
1618
1619 Copies an integer into the given SV, upgrading first if necessary.
1620 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1621
1622 =cut
1623 */
1624
1625 void
1626 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1627 {
1628     SV_CHECK_THINKFIRST(sv);
1629     switch (SvTYPE(sv)) {
1630     case SVt_NULL:
1631         sv_upgrade(sv, SVt_IV);
1632         break;
1633     case SVt_NV:
1634         sv_upgrade(sv, SVt_PVNV);
1635         break;
1636     case SVt_RV:
1637     case SVt_PV:
1638         sv_upgrade(sv, SVt_PVIV);
1639         break;
1640
1641     case SVt_PVGV:
1642     case SVt_PVAV:
1643     case SVt_PVHV:
1644     case SVt_PVCV:
1645     case SVt_PVFM:
1646     case SVt_PVIO:
1647         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1648                    OP_DESC(PL_op));
1649     }
1650     (void)SvIOK_only(sv);                       /* validate number */
1651     SvIVX(sv) = i;
1652     SvTAINT(sv);
1653 }
1654
1655 /*
1656 =for apidoc sv_setiv_mg
1657
1658 Like C<sv_setiv>, but also handles 'set' magic.
1659
1660 =cut
1661 */
1662
1663 void
1664 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1665 {
1666     sv_setiv(sv,i);
1667     SvSETMAGIC(sv);
1668 }
1669
1670 /*
1671 =for apidoc sv_setuv
1672
1673 Copies an unsigned integer into the given SV, upgrading first if necessary.
1674 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1675
1676 =cut
1677 */
1678
1679 void
1680 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1681 {
1682     /* With these two if statements:
1683        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1684
1685        without
1686        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1687
1688        If you wish to remove them, please benchmark to see what the effect is
1689     */
1690     if (u <= (UV)IV_MAX) {
1691        sv_setiv(sv, (IV)u);
1692        return;
1693     }
1694     sv_setiv(sv, 0);
1695     SvIsUV_on(sv);
1696     SvUVX(sv) = u;
1697 }
1698
1699 /*
1700 =for apidoc sv_setuv_mg
1701
1702 Like C<sv_setuv>, but also handles 'set' magic.
1703
1704 =cut
1705 */
1706
1707 void
1708 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1709 {
1710     /* With these two if statements:
1711        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1712
1713        without
1714        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1715
1716        If you wish to remove them, please benchmark to see what the effect is
1717     */
1718     if (u <= (UV)IV_MAX) {
1719        sv_setiv(sv, (IV)u);
1720     } else {
1721        sv_setiv(sv, 0);
1722        SvIsUV_on(sv);
1723        sv_setuv(sv,u);
1724     }
1725     SvSETMAGIC(sv);
1726 }
1727
1728 /*
1729 =for apidoc sv_setnv
1730
1731 Copies a double into the given SV, upgrading first if necessary.
1732 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1733
1734 =cut
1735 */
1736
1737 void
1738 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1739 {
1740     SV_CHECK_THINKFIRST(sv);
1741     switch (SvTYPE(sv)) {
1742     case SVt_NULL:
1743     case SVt_IV:
1744         sv_upgrade(sv, SVt_NV);
1745         break;
1746     case SVt_RV:
1747     case SVt_PV:
1748     case SVt_PVIV:
1749         sv_upgrade(sv, SVt_PVNV);
1750         break;
1751
1752     case SVt_PVGV:
1753     case SVt_PVAV:
1754     case SVt_PVHV:
1755     case SVt_PVCV:
1756     case SVt_PVFM:
1757     case SVt_PVIO:
1758         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1759                    OP_NAME(PL_op));
1760     }
1761     SvNVX(sv) = num;
1762     (void)SvNOK_only(sv);                       /* validate number */
1763     SvTAINT(sv);
1764 }
1765
1766 /*
1767 =for apidoc sv_setnv_mg
1768
1769 Like C<sv_setnv>, but also handles 'set' magic.
1770
1771 =cut
1772 */
1773
1774 void
1775 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1776 {
1777     sv_setnv(sv,num);
1778     SvSETMAGIC(sv);
1779 }
1780
1781 /* Print an "isn't numeric" warning, using a cleaned-up,
1782  * printable version of the offending string
1783  */
1784
1785 STATIC void
1786 S_not_a_number(pTHX_ SV *sv)
1787 {
1788      SV *dsv;
1789      char tmpbuf[64];
1790      char *pv;
1791
1792      if (DO_UTF8(sv)) {
1793           dsv = sv_2mortal(newSVpv("", 0));
1794           pv = sv_uni_display(dsv, sv, 10, 0);
1795      } else {
1796           char *d = tmpbuf;
1797           char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1798           /* each *s can expand to 4 chars + "...\0",
1799              i.e. need room for 8 chars */
1800
1801           char *s, *end;
1802           for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1803                int ch = *s & 0xFF;
1804                if (ch & 128 && !isPRINT_LC(ch)) {
1805                     *d++ = 'M';
1806                     *d++ = '-';
1807                     ch &= 127;
1808                }
1809                if (ch == '\n') {
1810                     *d++ = '\\';
1811                     *d++ = 'n';
1812                }
1813                else if (ch == '\r') {
1814                     *d++ = '\\';
1815                     *d++ = 'r';
1816                }
1817                else if (ch == '\f') {
1818                     *d++ = '\\';
1819                     *d++ = 'f';
1820                }
1821                else if (ch == '\\') {
1822                     *d++ = '\\';
1823                     *d++ = '\\';
1824                }
1825                else if (ch == '\0') {
1826                     *d++ = '\\';
1827                     *d++ = '0';
1828                }
1829                else if (isPRINT_LC(ch))
1830                     *d++ = ch;
1831                else {
1832                     *d++ = '^';
1833                     *d++ = toCTRL(ch);
1834                }
1835           }
1836           if (s < end) {
1837                *d++ = '.';
1838                *d++ = '.';
1839                *d++ = '.';
1840           }
1841           *d = '\0';
1842           pv = tmpbuf;
1843     }
1844
1845     if (PL_op)
1846         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1847                     "Argument \"%s\" isn't numeric in %s", pv,
1848                     OP_DESC(PL_op));
1849     else
1850         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1851                     "Argument \"%s\" isn't numeric", pv);
1852 }
1853
1854 /*
1855 =for apidoc looks_like_number
1856
1857 Test if the content of an SV looks like a number (or is a number).
1858 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1859 non-numeric warning), even if your atof() doesn't grok them.
1860
1861 =cut
1862 */
1863
1864 I32
1865 Perl_looks_like_number(pTHX_ SV *sv)
1866 {
1867     register char *sbegin;
1868     STRLEN len;
1869
1870     if (SvPOK(sv)) {
1871         sbegin = SvPVX(sv);
1872         len = SvCUR(sv);
1873     }
1874     else if (SvPOKp(sv))
1875         sbegin = SvPV(sv, len);
1876     else
1877         return 1; /* Historic.  Wrong?  */
1878     return grok_number(sbegin, len, NULL);
1879 }
1880
1881 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1882    until proven guilty, assume that things are not that bad... */
1883
1884 /*
1885    NV_PRESERVES_UV:
1886
1887    As 64 bit platforms often have an NV that doesn't preserve all bits of
1888    an IV (an assumption perl has been based on to date) it becomes necessary
1889    to remove the assumption that the NV always carries enough precision to
1890    recreate the IV whenever needed, and that the NV is the canonical form.
1891    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1892    precision as a side effect of conversion (which would lead to insanity
1893    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1894    1) to distinguish between IV/UV/NV slots that have cached a valid
1895       conversion where precision was lost and IV/UV/NV slots that have a
1896       valid conversion which has lost no precision
1897    2) to ensure that if a numeric conversion to one form is requested that
1898       would lose precision, the precise conversion (or differently
1899       imprecise conversion) is also performed and cached, to prevent
1900       requests for different numeric formats on the same SV causing
1901       lossy conversion chains. (lossless conversion chains are perfectly
1902       acceptable (still))
1903
1904
1905    flags are used:
1906    SvIOKp is true if the IV slot contains a valid value
1907    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1908    SvNOKp is true if the NV slot contains a valid value
1909    SvNOK  is true only if the NV value is accurate
1910
1911    so
1912    while converting from PV to NV, check to see if converting that NV to an
1913    IV(or UV) would lose accuracy over a direct conversion from PV to
1914    IV(or UV). If it would, cache both conversions, return NV, but mark
1915    SV as IOK NOKp (ie not NOK).
1916
1917    While converting from PV to IV, check to see if converting that IV to an
1918    NV would lose accuracy over a direct conversion from PV to NV. If it
1919    would, cache both conversions, flag similarly.
1920
1921    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1922    correctly because if IV & NV were set NV *always* overruled.
1923    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1924    changes - now IV and NV together means that the two are interchangeable:
1925    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1926
1927    The benefit of this is that operations such as pp_add know that if
1928    SvIOK is true for both left and right operands, then integer addition
1929    can be used instead of floating point (for cases where the result won't
1930    overflow). Before, floating point was always used, which could lead to
1931    loss of precision compared with integer addition.
1932
1933    * making IV and NV equal status should make maths accurate on 64 bit
1934      platforms
1935    * may speed up maths somewhat if pp_add and friends start to use
1936      integers when possible instead of fp. (Hopefully the overhead in
1937      looking for SvIOK and checking for overflow will not outweigh the
1938      fp to integer speedup)
1939    * will slow down integer operations (callers of SvIV) on "inaccurate"
1940      values, as the change from SvIOK to SvIOKp will cause a call into
1941      sv_2iv each time rather than a macro access direct to the IV slot
1942    * should speed up number->string conversion on integers as IV is
1943      favoured when IV and NV are equally accurate
1944
1945    ####################################################################
1946    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1947    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1948    On the other hand, SvUOK is true iff UV.
1949    ####################################################################
1950
1951    Your mileage will vary depending your CPU's relative fp to integer
1952    performance ratio.
1953 */
1954
1955 #ifndef NV_PRESERVES_UV
1956 #  define IS_NUMBER_UNDERFLOW_IV 1
1957 #  define IS_NUMBER_UNDERFLOW_UV 2
1958 #  define IS_NUMBER_IV_AND_UV    2
1959 #  define IS_NUMBER_OVERFLOW_IV  4
1960 #  define IS_NUMBER_OVERFLOW_UV  5
1961
1962 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1963
1964 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1965 STATIC int
1966 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1967 {
1968     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));
1969     if (SvNVX(sv) < (NV)IV_MIN) {
1970         (void)SvIOKp_on(sv);
1971         (void)SvNOK_on(sv);
1972         SvIVX(sv) = IV_MIN;
1973         return IS_NUMBER_UNDERFLOW_IV;
1974     }
1975     if (SvNVX(sv) > (NV)UV_MAX) {
1976         (void)SvIOKp_on(sv);
1977         (void)SvNOK_on(sv);
1978         SvIsUV_on(sv);
1979         SvUVX(sv) = UV_MAX;
1980         return IS_NUMBER_OVERFLOW_UV;
1981     }
1982     (void)SvIOKp_on(sv);
1983     (void)SvNOK_on(sv);
1984     /* Can't use strtol etc to convert this string.  (See truth table in
1985        sv_2iv  */
1986     if (SvNVX(sv) <= (UV)IV_MAX) {
1987         SvIVX(sv) = I_V(SvNVX(sv));
1988         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1989             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1990         } else {
1991             /* Integer is imprecise. NOK, IOKp */
1992         }
1993         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1994     }
1995     SvIsUV_on(sv);
1996     SvUVX(sv) = U_V(SvNVX(sv));
1997     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1998         if (SvUVX(sv) == UV_MAX) {
1999             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2000                possibly be preserved by NV. Hence, it must be overflow.
2001                NOK, IOKp */
2002             return IS_NUMBER_OVERFLOW_UV;
2003         }
2004         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2005     } else {
2006         /* Integer is imprecise. NOK, IOKp */
2007     }
2008     return IS_NUMBER_OVERFLOW_IV;
2009 }
2010 #endif /* !NV_PRESERVES_UV*/
2011
2012 /*
2013 =for apidoc sv_2iv
2014
2015 Return the integer value of an SV, doing any necessary string conversion,
2016 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2017
2018 =cut
2019 */
2020
2021 IV
2022 Perl_sv_2iv(pTHX_ register SV *sv)
2023 {
2024     if (!sv)
2025         return 0;
2026     if (SvGMAGICAL(sv)) {
2027         mg_get(sv);
2028         if (SvIOKp(sv))
2029             return SvIVX(sv);
2030         if (SvNOKp(sv)) {
2031             return I_V(SvNVX(sv));
2032         }
2033         if (SvPOKp(sv) && SvLEN(sv))
2034             return asIV(sv);
2035         if (!SvROK(sv)) {
2036             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2037                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2038                     report_uninit();
2039             }
2040             return 0;
2041         }
2042     }
2043     if (SvTHINKFIRST(sv)) {
2044         if (SvROK(sv)) {
2045           SV* tmpstr;
2046           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2047                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2048               return SvIV(tmpstr);
2049           return PTR2IV(SvRV(sv));
2050         }
2051         if (SvREADONLY(sv) && SvFAKE(sv)) {
2052             sv_force_normal(sv);
2053         }
2054         if (SvREADONLY(sv) && !SvOK(sv)) {
2055             if (ckWARN(WARN_UNINITIALIZED))
2056                 report_uninit();
2057             return 0;
2058         }
2059     }
2060     if (SvIOKp(sv)) {
2061         if (SvIsUV(sv)) {
2062             return (IV)(SvUVX(sv));
2063         }
2064         else {
2065             return SvIVX(sv);
2066         }
2067     }
2068     if (SvNOKp(sv)) {
2069         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2070          * without also getting a cached IV/UV from it at the same time
2071          * (ie PV->NV conversion should detect loss of accuracy and cache
2072          * IV or UV at same time to avoid this.  NWC */
2073
2074         if (SvTYPE(sv) == SVt_NV)
2075             sv_upgrade(sv, SVt_PVNV);
2076
2077         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2078         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2079            certainly cast into the IV range at IV_MAX, whereas the correct
2080            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2081            cases go to UV */
2082         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2083             SvIVX(sv) = I_V(SvNVX(sv));
2084             if (SvNVX(sv) == (NV) SvIVX(sv)
2085 #ifndef NV_PRESERVES_UV
2086                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2087                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2088                 /* Don't flag it as "accurately an integer" if the number
2089                    came from a (by definition imprecise) NV operation, and
2090                    we're outside the range of NV integer precision */
2091 #endif
2092                 ) {
2093                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2094                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2095                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2096                                       PTR2UV(sv),
2097                                       SvNVX(sv),
2098                                       SvIVX(sv)));
2099
2100             } else {
2101                 /* IV not precise.  No need to convert from PV, as NV
2102                    conversion would already have cached IV if it detected
2103                    that PV->IV would be better than PV->NV->IV
2104                    flags already correct - don't set public IOK.  */
2105                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2106                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2107                                       PTR2UV(sv),
2108                                       SvNVX(sv),
2109                                       SvIVX(sv)));
2110             }
2111             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2112                but the cast (NV)IV_MIN rounds to a the value less (more
2113                negative) than IV_MIN which happens to be equal to SvNVX ??
2114                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2115                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2116                (NV)UVX == NVX are both true, but the values differ. :-(
2117                Hopefully for 2s complement IV_MIN is something like
2118                0x8000000000000000 which will be exact. NWC */
2119         }
2120         else {
2121             SvUVX(sv) = U_V(SvNVX(sv));
2122             if (
2123                 (SvNVX(sv) == (NV) SvUVX(sv))
2124 #ifndef  NV_PRESERVES_UV
2125                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2126                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2127                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2128                 /* Don't flag it as "accurately an integer" if the number
2129                    came from a (by definition imprecise) NV operation, and
2130                    we're outside the range of NV integer precision */
2131 #endif
2132                 )
2133                 SvIOK_on(sv);
2134             SvIsUV_on(sv);
2135           ret_iv_max:
2136             DEBUG_c(PerlIO_printf(Perl_debug_log,
2137                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2138                                   PTR2UV(sv),
2139                                   SvUVX(sv),
2140                                   SvUVX(sv)));
2141             return (IV)SvUVX(sv);
2142         }
2143     }
2144     else if (SvPOKp(sv) && SvLEN(sv)) {
2145         UV value;
2146         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2147         /* We want to avoid a possible problem when we cache an IV which
2148            may be later translated to an NV, and the resulting NV is not
2149            the same as the direct translation of the initial string
2150            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2151            be careful to ensure that the value with the .456 is around if the
2152            NV value is requested in the future).
2153
2154            This means that if we cache such an IV, we need to cache the
2155            NV as well.  Moreover, we trade speed for space, and do not
2156            cache the NV if we are sure it's not needed.
2157          */
2158
2159         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2160         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2161              == IS_NUMBER_IN_UV) {
2162             /* It's definitely an integer, only upgrade to PVIV */
2163             if (SvTYPE(sv) < SVt_PVIV)
2164                 sv_upgrade(sv, SVt_PVIV);
2165             (void)SvIOK_on(sv);
2166         } else if (SvTYPE(sv) < SVt_PVNV)
2167             sv_upgrade(sv, SVt_PVNV);
2168
2169         /* If NV preserves UV then we only use the UV value if we know that
2170            we aren't going to call atof() below. If NVs don't preserve UVs
2171            then the value returned may have more precision than atof() will
2172            return, even though value isn't perfectly accurate.  */
2173         if ((numtype & (IS_NUMBER_IN_UV
2174 #ifdef NV_PRESERVES_UV
2175                         | IS_NUMBER_NOT_INT
2176 #endif
2177             )) == IS_NUMBER_IN_UV) {
2178             /* This won't turn off the public IOK flag if it was set above  */
2179             (void)SvIOKp_on(sv);
2180
2181             if (!(numtype & IS_NUMBER_NEG)) {
2182                 /* positive */;
2183                 if (value <= (UV)IV_MAX) {
2184                     SvIVX(sv) = (IV)value;
2185                 } else {
2186                     SvUVX(sv) = value;
2187                     SvIsUV_on(sv);
2188                 }
2189             } else {
2190                 /* 2s complement assumption  */
2191                 if (value <= (UV)IV_MIN) {
2192                     SvIVX(sv) = -(IV)value;
2193                 } else {
2194                     /* Too negative for an IV.  This is a double upgrade, but
2195                        I'm assuming it will be rare.  */
2196                     if (SvTYPE(sv) < SVt_PVNV)
2197                         sv_upgrade(sv, SVt_PVNV);
2198                     SvNOK_on(sv);
2199                     SvIOK_off(sv);
2200                     SvIOKp_on(sv);
2201                     SvNVX(sv) = -(NV)value;
2202                     SvIVX(sv) = IV_MIN;
2203                 }
2204             }
2205         }
2206         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2207            will be in the previous block to set the IV slot, and the next
2208            block to set the NV slot.  So no else here.  */
2209
2210         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2211             != IS_NUMBER_IN_UV) {
2212             /* It wasn't an (integer that doesn't overflow the UV). */
2213             SvNVX(sv) = Atof(SvPVX(sv));
2214
2215             if (! numtype && ckWARN(WARN_NUMERIC))
2216                 not_a_number(sv);
2217
2218 #if defined(USE_LONG_DOUBLE)
2219             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2220                                   PTR2UV(sv), SvNVX(sv)));
2221 #else
2222             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2223                                   PTR2UV(sv), SvNVX(sv)));
2224 #endif
2225
2226
2227 #ifdef NV_PRESERVES_UV
2228             (void)SvIOKp_on(sv);
2229             (void)SvNOK_on(sv);
2230             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2231                 SvIVX(sv) = I_V(SvNVX(sv));
2232                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2233                     SvIOK_on(sv);
2234                 } else {
2235                     /* Integer is imprecise. NOK, IOKp */
2236                 }
2237                 /* UV will not work better than IV */
2238             } else {
2239                 if (SvNVX(sv) > (NV)UV_MAX) {
2240                     SvIsUV_on(sv);
2241                     /* Integer is inaccurate. NOK, IOKp, is UV */
2242                     SvUVX(sv) = UV_MAX;
2243                     SvIsUV_on(sv);
2244                 } else {
2245                     SvUVX(sv) = U_V(SvNVX(sv));
2246                     /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2247                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2248                         SvIOK_on(sv);
2249                         SvIsUV_on(sv);
2250                     } else {
2251                         /* Integer is imprecise. NOK, IOKp, is UV */
2252                         SvIsUV_on(sv);
2253                     }
2254                 }
2255                 goto ret_iv_max;
2256             }
2257 #else /* NV_PRESERVES_UV */
2258             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2259                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2260                 /* The IV slot will have been set from value returned by
2261                    grok_number above.  The NV slot has just been set using
2262                    Atof.  */
2263                 SvNOK_on(sv);
2264                 assert (SvIOKp(sv));
2265             } else {
2266                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2267                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2268                     /* Small enough to preserve all bits. */
2269                     (void)SvIOKp_on(sv);
2270                     SvNOK_on(sv);
2271                     SvIVX(sv) = I_V(SvNVX(sv));
2272                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2273                         SvIOK_on(sv);
2274                     /* Assumption: first non-preserved integer is < IV_MAX,
2275                        this NV is in the preserved range, therefore: */
2276                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2277                           < (UV)IV_MAX)) {
2278                         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);
2279                     }
2280                 } else {
2281                     /* IN_UV NOT_INT
2282                          0      0       already failed to read UV.
2283                          0      1       already failed to read UV.
2284                          1      0       you won't get here in this case. IV/UV
2285                                         slot set, public IOK, Atof() unneeded.
2286                          1      1       already read UV.
2287                        so there's no point in sv_2iuv_non_preserve() attempting
2288                        to use atol, strtol, strtoul etc.  */
2289                     if (sv_2iuv_non_preserve (sv, numtype)
2290                         >= IS_NUMBER_OVERFLOW_IV)
2291                     goto ret_iv_max;
2292                 }
2293             }
2294 #endif /* NV_PRESERVES_UV */
2295         }
2296     } else  {
2297         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2298             report_uninit();
2299         if (SvTYPE(sv) < SVt_IV)
2300             /* Typically the caller expects that sv_any is not NULL now.  */
2301             sv_upgrade(sv, SVt_IV);
2302         return 0;
2303     }
2304     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2305         PTR2UV(sv),SvIVX(sv)));
2306     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2307 }
2308
2309 /*
2310 =for apidoc sv_2uv
2311
2312 Return the unsigned integer value of an SV, doing any necessary string
2313 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2314 macros.
2315
2316 =cut
2317 */
2318
2319 UV
2320 Perl_sv_2uv(pTHX_ register SV *sv)
2321 {
2322     if (!sv)
2323         return 0;
2324     if (SvGMAGICAL(sv)) {
2325         mg_get(sv);
2326         if (SvIOKp(sv))
2327             return SvUVX(sv);
2328         if (SvNOKp(sv))
2329             return U_V(SvNVX(sv));
2330         if (SvPOKp(sv) && SvLEN(sv))
2331             return asUV(sv);
2332         if (!SvROK(sv)) {
2333             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2334                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2335                     report_uninit();
2336             }
2337             return 0;
2338         }
2339     }
2340     if (SvTHINKFIRST(sv)) {
2341         if (SvROK(sv)) {
2342           SV* tmpstr;
2343           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2344                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2345               return SvUV(tmpstr);
2346           return PTR2UV(SvRV(sv));
2347         }
2348         if (SvREADONLY(sv) && SvFAKE(sv)) {
2349             sv_force_normal(sv);
2350         }
2351         if (SvREADONLY(sv) && !SvOK(sv)) {
2352             if (ckWARN(WARN_UNINITIALIZED))
2353                 report_uninit();
2354             return 0;
2355         }
2356     }
2357     if (SvIOKp(sv)) {
2358         if (SvIsUV(sv)) {
2359             return SvUVX(sv);
2360         }
2361         else {
2362             return (UV)SvIVX(sv);
2363         }
2364     }
2365     if (SvNOKp(sv)) {
2366         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2367          * without also getting a cached IV/UV from it at the same time
2368          * (ie PV->NV conversion should detect loss of accuracy and cache
2369          * IV or UV at same time to avoid this. */
2370         /* IV-over-UV optimisation - choose to cache IV if possible */
2371
2372         if (SvTYPE(sv) == SVt_NV)
2373             sv_upgrade(sv, SVt_PVNV);
2374
2375         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2376         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2377             SvIVX(sv) = I_V(SvNVX(sv));
2378             if (SvNVX(sv) == (NV) SvIVX(sv)
2379 #ifndef NV_PRESERVES_UV
2380                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2381                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2382                 /* Don't flag it as "accurately an integer" if the number
2383                    came from a (by definition imprecise) NV operation, and
2384                    we're outside the range of NV integer precision */
2385 #endif
2386                 ) {
2387                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2388                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2389                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2390                                       PTR2UV(sv),
2391                                       SvNVX(sv),
2392                                       SvIVX(sv)));
2393
2394             } else {
2395                 /* IV not precise.  No need to convert from PV, as NV
2396                    conversion would already have cached IV if it detected
2397                    that PV->IV would be better than PV->NV->IV
2398                    flags already correct - don't set public IOK.  */
2399                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2400                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2401                                       PTR2UV(sv),
2402                                       SvNVX(sv),
2403                                       SvIVX(sv)));
2404             }
2405             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2406                but the cast (NV)IV_MIN rounds to a the value less (more
2407                negative) than IV_MIN which happens to be equal to SvNVX ??
2408                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2409                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2410                (NV)UVX == NVX are both true, but the values differ. :-(
2411                Hopefully for 2s complement IV_MIN is something like
2412                0x8000000000000000 which will be exact. NWC */
2413         }
2414         else {
2415             SvUVX(sv) = U_V(SvNVX(sv));
2416             if (
2417                 (SvNVX(sv) == (NV) SvUVX(sv))
2418 #ifndef  NV_PRESERVES_UV
2419                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2420                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2421                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2422                 /* Don't flag it as "accurately an integer" if the number
2423                    came from a (by definition imprecise) NV operation, and
2424                    we're outside the range of NV integer precision */
2425 #endif
2426                 )
2427                 SvIOK_on(sv);
2428             SvIsUV_on(sv);
2429             DEBUG_c(PerlIO_printf(Perl_debug_log,
2430                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2431                                   PTR2UV(sv),
2432                                   SvUVX(sv),
2433                                   SvUVX(sv)));
2434         }
2435     }
2436     else if (SvPOKp(sv) && SvLEN(sv)) {
2437         UV value;
2438         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2439
2440         /* We want to avoid a possible problem when we cache a UV which
2441            may be later translated to an NV, and the resulting NV is not
2442            the translation of the initial data.
2443
2444            This means that if we cache such a UV, we need to cache the
2445            NV as well.  Moreover, we trade speed for space, and do not
2446            cache the NV if not needed.
2447          */
2448
2449         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2450         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2451              == IS_NUMBER_IN_UV) {
2452             /* It's definitely an integer, only upgrade to PVIV */
2453             if (SvTYPE(sv) < SVt_PVIV)
2454                 sv_upgrade(sv, SVt_PVIV);
2455             (void)SvIOK_on(sv);
2456         } else if (SvTYPE(sv) < SVt_PVNV)
2457             sv_upgrade(sv, SVt_PVNV);
2458
2459         /* If NV preserves UV then we only use the UV value if we know that
2460            we aren't going to call atof() below. If NVs don't preserve UVs
2461            then the value returned may have more precision than atof() will
2462            return, even though it isn't accurate.  */
2463         if ((numtype & (IS_NUMBER_IN_UV
2464 #ifdef NV_PRESERVES_UV
2465                         | IS_NUMBER_NOT_INT
2466 #endif
2467             )) == IS_NUMBER_IN_UV) {
2468             /* This won't turn off the public IOK flag if it was set above  */
2469             (void)SvIOKp_on(sv);
2470
2471             if (!(numtype & IS_NUMBER_NEG)) {
2472                 /* positive */;
2473                 if (value <= (UV)IV_MAX) {
2474                     SvIVX(sv) = (IV)value;
2475                 } else {
2476                     /* it didn't overflow, and it was positive. */
2477                     SvUVX(sv) = value;
2478                     SvIsUV_on(sv);
2479                 }
2480             } else {
2481                 /* 2s complement assumption  */
2482                 if (value <= (UV)IV_MIN) {
2483                     SvIVX(sv) = -(IV)value;
2484                 } else {
2485                     /* Too negative for an IV.  This is a double upgrade, but
2486                        I'm assuming it will be rare.  */
2487                     if (SvTYPE(sv) < SVt_PVNV)
2488                         sv_upgrade(sv, SVt_PVNV);
2489                     SvNOK_on(sv);
2490                     SvIOK_off(sv);
2491                     SvIOKp_on(sv);
2492                     SvNVX(sv) = -(NV)value;
2493                     SvIVX(sv) = IV_MIN;
2494                 }
2495             }
2496         }
2497
2498         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2499             != IS_NUMBER_IN_UV) {
2500             /* It wasn't an integer, or it overflowed the UV. */
2501             SvNVX(sv) = Atof(SvPVX(sv));
2502
2503             if (! numtype && ckWARN(WARN_NUMERIC))
2504                     not_a_number(sv);
2505
2506 #if defined(USE_LONG_DOUBLE)
2507             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2508                                   PTR2UV(sv), SvNVX(sv)));
2509 #else
2510             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2511                                   PTR2UV(sv), SvNVX(sv)));
2512 #endif
2513
2514 #ifdef NV_PRESERVES_UV
2515             (void)SvIOKp_on(sv);
2516             (void)SvNOK_on(sv);
2517             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2518                 SvIVX(sv) = I_V(SvNVX(sv));
2519                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2520                     SvIOK_on(sv);
2521                 } else {
2522                     /* Integer is imprecise. NOK, IOKp */
2523                 }
2524                 /* UV will not work better than IV */
2525             } else {
2526                 if (SvNVX(sv) > (NV)UV_MAX) {
2527                     SvIsUV_on(sv);
2528                     /* Integer is inaccurate. NOK, IOKp, is UV */
2529                     SvUVX(sv) = UV_MAX;
2530                     SvIsUV_on(sv);
2531                 } else {
2532                     SvUVX(sv) = U_V(SvNVX(sv));
2533                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2534                        NV preservse UV so can do correct comparison.  */
2535                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2536                         SvIOK_on(sv);
2537                         SvIsUV_on(sv);
2538                     } else {
2539                         /* Integer is imprecise. NOK, IOKp, is UV */
2540                         SvIsUV_on(sv);
2541                     }
2542                 }
2543             }
2544 #else /* NV_PRESERVES_UV */
2545             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2546                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2547                 /* The UV slot will have been set from value returned by
2548                    grok_number above.  The NV slot has just been set using
2549                    Atof.  */
2550                 SvNOK_on(sv);
2551                 assert (SvIOKp(sv));
2552             } else {
2553                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2554                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2555                     /* Small enough to preserve all bits. */
2556                     (void)SvIOKp_on(sv);
2557                     SvNOK_on(sv);
2558                     SvIVX(sv) = I_V(SvNVX(sv));
2559                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2560                         SvIOK_on(sv);
2561                     /* Assumption: first non-preserved integer is < IV_MAX,
2562                        this NV is in the preserved range, therefore: */
2563                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2564                           < (UV)IV_MAX)) {
2565                         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);
2566                     }
2567                 } else
2568                     sv_2iuv_non_preserve (sv, numtype);
2569             }
2570 #endif /* NV_PRESERVES_UV */
2571         }
2572     }
2573     else  {
2574         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2575             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2576                 report_uninit();
2577         }
2578         if (SvTYPE(sv) < SVt_IV)
2579             /* Typically the caller expects that sv_any is not NULL now.  */
2580             sv_upgrade(sv, SVt_IV);
2581         return 0;
2582     }
2583
2584     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2585                           PTR2UV(sv),SvUVX(sv)));
2586     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2587 }
2588
2589 /*
2590 =for apidoc sv_2nv
2591
2592 Return the num value of an SV, doing any necessary string or integer
2593 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2594 macros.
2595
2596 =cut
2597 */
2598
2599 NV
2600 Perl_sv_2nv(pTHX_ register SV *sv)
2601 {
2602     if (!sv)
2603         return 0.0;
2604     if (SvGMAGICAL(sv)) {
2605         mg_get(sv);
2606         if (SvNOKp(sv))
2607             return SvNVX(sv);
2608         if (SvPOKp(sv) && SvLEN(sv)) {
2609             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2610                 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2611                 not_a_number(sv);
2612             return Atof(SvPVX(sv));
2613         }
2614         if (SvIOKp(sv)) {
2615             if (SvIsUV(sv))
2616                 return (NV)SvUVX(sv);
2617             else
2618                 return (NV)SvIVX(sv);
2619         }
2620         if (!SvROK(sv)) {
2621             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2622                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2623                     report_uninit();
2624             }
2625             return 0;
2626         }
2627     }
2628     if (SvTHINKFIRST(sv)) {
2629         if (SvROK(sv)) {
2630           SV* tmpstr;
2631           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2632                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2633               return SvNV(tmpstr);
2634           return PTR2NV(SvRV(sv));
2635         }
2636         if (SvREADONLY(sv) && SvFAKE(sv)) {
2637             sv_force_normal(sv);
2638         }
2639         if (SvREADONLY(sv) && !SvOK(sv)) {
2640             if (ckWARN(WARN_UNINITIALIZED))
2641                 report_uninit();
2642             return 0.0;
2643         }
2644     }
2645     if (SvTYPE(sv) < SVt_NV) {
2646         if (SvTYPE(sv) == SVt_IV)
2647             sv_upgrade(sv, SVt_PVNV);
2648         else
2649             sv_upgrade(sv, SVt_NV);
2650 #ifdef USE_LONG_DOUBLE
2651         DEBUG_c({
2652             STORE_NUMERIC_LOCAL_SET_STANDARD();
2653             PerlIO_printf(Perl_debug_log,
2654                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2655                           PTR2UV(sv), SvNVX(sv));
2656             RESTORE_NUMERIC_LOCAL();
2657         });
2658 #else
2659         DEBUG_c({
2660             STORE_NUMERIC_LOCAL_SET_STANDARD();
2661             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2662                           PTR2UV(sv), SvNVX(sv));
2663             RESTORE_NUMERIC_LOCAL();
2664         });
2665 #endif
2666     }
2667     else if (SvTYPE(sv) < SVt_PVNV)
2668         sv_upgrade(sv, SVt_PVNV);
2669     if (SvNOKp(sv)) {
2670         return SvNVX(sv);
2671     }
2672     if (SvIOKp(sv)) {
2673         SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2674 #ifdef NV_PRESERVES_UV
2675         SvNOK_on(sv);
2676 #else
2677         /* Only set the public NV OK flag if this NV preserves the IV  */
2678         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2679         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2680                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2681             SvNOK_on(sv);
2682         else
2683             SvNOKp_on(sv);
2684 #endif
2685     }
2686     else if (SvPOKp(sv) && SvLEN(sv)) {
2687         UV value;
2688         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2689         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2690             not_a_number(sv);
2691 #ifdef NV_PRESERVES_UV
2692         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2693             == IS_NUMBER_IN_UV) {
2694             /* It's definitely an integer */
2695             SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2696         } else
2697             SvNVX(sv) = Atof(SvPVX(sv));
2698         SvNOK_on(sv);
2699 #else
2700         SvNVX(sv) = Atof(SvPVX(sv));
2701         /* Only set the public NV OK flag if this NV preserves the value in
2702            the PV at least as well as an IV/UV would.
2703            Not sure how to do this 100% reliably. */
2704         /* if that shift count is out of range then Configure's test is
2705            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2706            UV_BITS */
2707         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2708             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2709             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2710         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2711             /* Can't use strtol etc to convert this string, so don't try.
2712                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2713             SvNOK_on(sv);
2714         } else {
2715             /* value has been set.  It may not be precise.  */
2716             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2717                 /* 2s complement assumption for (UV)IV_MIN  */
2718                 SvNOK_on(sv); /* Integer is too negative.  */
2719             } else {
2720                 SvNOKp_on(sv);
2721                 SvIOKp_on(sv);
2722
2723                 if (numtype & IS_NUMBER_NEG) {
2724                     SvIVX(sv) = -(IV)value;
2725                 } else if (value <= (UV)IV_MAX) {
2726                     SvIVX(sv) = (IV)value;
2727                 } else {
2728                     SvUVX(sv) = value;
2729                     SvIsUV_on(sv);
2730                 }
2731
2732                 if (numtype & IS_NUMBER_NOT_INT) {
2733                     /* I believe that even if the original PV had decimals,
2734                        they are lost beyond the limit of the FP precision.
2735                        However, neither is canonical, so both only get p
2736                        flags.  NWC, 2000/11/25 */
2737                     /* Both already have p flags, so do nothing */
2738                 } else {
2739                     NV nv = SvNVX(sv);
2740                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2741                         if (SvIVX(sv) == I_V(nv)) {
2742                             SvNOK_on(sv);
2743                             SvIOK_on(sv);
2744                         } else {
2745                             SvIOK_on(sv);
2746                             /* It had no "." so it must be integer.  */
2747                         }
2748                     } else {
2749                         /* between IV_MAX and NV(UV_MAX).
2750                            Could be slightly > UV_MAX */
2751
2752                         if (numtype & IS_NUMBER_NOT_INT) {
2753                             /* UV and NV both imprecise.  */
2754                         } else {
2755                             UV nv_as_uv = U_V(nv);
2756
2757                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2758                                 SvNOK_on(sv);
2759                                 SvIOK_on(sv);
2760                             } else {
2761                                 SvIOK_on(sv);
2762                             }
2763                         }
2764                     }
2765                 }
2766             }
2767         }
2768 #endif /* NV_PRESERVES_UV */
2769     }
2770     else  {
2771         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2772             report_uninit();
2773         if (SvTYPE(sv) < SVt_NV)
2774             /* Typically the caller expects that sv_any is not NULL now.  */
2775             /* XXX Ilya implies that this is a bug in callers that assume this
2776                and ideally should be fixed.  */
2777             sv_upgrade(sv, SVt_NV);
2778         return 0.0;
2779     }
2780 #if defined(USE_LONG_DOUBLE)
2781     DEBUG_c({
2782         STORE_NUMERIC_LOCAL_SET_STANDARD();
2783         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2784                       PTR2UV(sv), SvNVX(sv));
2785         RESTORE_NUMERIC_LOCAL();
2786     });
2787 #else
2788     DEBUG_c({
2789         STORE_NUMERIC_LOCAL_SET_STANDARD();
2790         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2791                       PTR2UV(sv), SvNVX(sv));
2792         RESTORE_NUMERIC_LOCAL();
2793     });
2794 #endif
2795     return SvNVX(sv);
2796 }
2797
2798 /* asIV(): extract an integer from the string value of an SV.
2799  * Caller must validate PVX  */
2800
2801 STATIC IV
2802 S_asIV(pTHX_ SV *sv)
2803 {
2804     UV value;
2805     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2806
2807     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2808         == IS_NUMBER_IN_UV) {
2809         /* It's definitely an integer */
2810         if (numtype & IS_NUMBER_NEG) {
2811             if (value < (UV)IV_MIN)
2812                 return -(IV)value;
2813         } else {
2814             if (value < (UV)IV_MAX)
2815                 return (IV)value;
2816         }
2817     }
2818     if (!numtype) {
2819         if (ckWARN(WARN_NUMERIC))
2820             not_a_number(sv);
2821     }
2822     return I_V(Atof(SvPVX(sv)));
2823 }
2824
2825 /* asUV(): extract an unsigned integer from the string value of an SV
2826  * Caller must validate PVX  */
2827
2828 STATIC UV
2829 S_asUV(pTHX_ SV *sv)
2830 {
2831     UV value;
2832     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2833
2834     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2835         == IS_NUMBER_IN_UV) {
2836         /* It's definitely an integer */
2837         if (!(numtype & IS_NUMBER_NEG))
2838             return value;
2839     }
2840     if (!numtype) {
2841         if (ckWARN(WARN_NUMERIC))
2842             not_a_number(sv);
2843     }
2844     return U_V(Atof(SvPVX(sv)));
2845 }
2846
2847 /*
2848 =for apidoc sv_2pv_nolen
2849
2850 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2851 use the macro wrapper C<SvPV_nolen(sv)> instead.
2852 =cut
2853 */
2854
2855 char *
2856 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2857 {
2858     STRLEN n_a;
2859     return sv_2pv(sv, &n_a);
2860 }
2861
2862 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2863  * UV as a string towards the end of buf, and return pointers to start and
2864  * end of it.
2865  *
2866  * We assume that buf is at least TYPE_CHARS(UV) long.
2867  */
2868
2869 static char *
2870 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2871 {
2872     char *ptr = buf + TYPE_CHARS(UV);
2873     char *ebuf = ptr;
2874     int sign;
2875
2876     if (is_uv)
2877         sign = 0;
2878     else if (iv >= 0) {
2879         uv = iv;
2880         sign = 0;
2881     } else {
2882         uv = -iv;
2883         sign = 1;
2884     }
2885     do {
2886         *--ptr = '0' + (char)(uv % 10);
2887     } while (uv /= 10);
2888     if (sign)
2889         *--ptr = '-';
2890     *peob = ebuf;
2891     return ptr;
2892 }
2893
2894 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
2895  * this function provided for binary compatibility only
2896  */
2897
2898 char *
2899 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2900 {
2901     return sv_2pv_flags(sv, lp, SV_GMAGIC);
2902 }
2903
2904 /*
2905 =for apidoc sv_2pv_flags
2906
2907 Returns a pointer to the string value of an SV, and sets *lp to its length.
2908 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2909 if necessary.
2910 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2911 usually end up here too.
2912
2913 =cut
2914 */
2915
2916 char *
2917 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2918 {
2919     register char *s;
2920     int olderrno;
2921     SV *tsv, *origsv;
2922     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2923     char *tmpbuf = tbuf;
2924
2925     if (!sv) {
2926         *lp = 0;
2927         return "";
2928     }
2929     if (SvGMAGICAL(sv)) {
2930         if (flags & SV_GMAGIC)
2931             mg_get(sv);
2932         if (SvPOKp(sv)) {
2933             *lp = SvCUR(sv);
2934             return SvPVX(sv);
2935         }
2936         if (SvIOKp(sv)) {
2937             if (SvIsUV(sv))
2938                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2939             else
2940                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2941             tsv = Nullsv;
2942             goto tokensave;
2943         }
2944         if (SvNOKp(sv)) {
2945             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2946             tsv = Nullsv;
2947             goto tokensave;
2948         }
2949         if (!SvROK(sv)) {
2950             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2951                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2952                     report_uninit();
2953             }
2954             *lp = 0;
2955             return "";
2956         }
2957     }
2958     if (SvTHINKFIRST(sv)) {
2959         if (SvROK(sv)) {
2960             SV* tmpstr;
2961             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2962                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2963                 char *pv = SvPV(tmpstr, *lp);
2964                 if (SvUTF8(tmpstr))
2965                     SvUTF8_on(sv);
2966                 else
2967                     SvUTF8_off(sv);
2968                 return pv;
2969             }
2970             origsv = sv;
2971             sv = (SV*)SvRV(sv);
2972             if (!sv)
2973                 s = "NULLREF";
2974             else {
2975                 MAGIC *mg;
2976
2977                 switch (SvTYPE(sv)) {
2978                 case SVt_PVMG:
2979                     if ( ((SvFLAGS(sv) &
2980                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2981                           == (SVs_OBJECT|SVs_SMG))
2982                          && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2983                         regexp *re = (regexp *)mg->mg_obj;
2984
2985                         if (!mg->mg_ptr) {
2986                             char *fptr = "msix";
2987                             char reflags[6];
2988                             char ch;
2989                             int left = 0;
2990                             int right = 4;
2991                             char need_newline = 0;
2992                             U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2993
2994                             while((ch = *fptr++)) {
2995                                 if(reganch & 1) {
2996                                     reflags[left++] = ch;
2997                                 }
2998                                 else {
2999                                     reflags[right--] = ch;
3000                                 }
3001                                 reganch >>= 1;
3002                             }
3003                             if(left != 4) {
3004                                 reflags[left] = '-';
3005                                 left = 5;
3006                             }
3007
3008                             mg->mg_len = re->prelen + 4 + left;
3009                             /*
3010                              * If /x was used, we have to worry about a regex
3011                              * ending with a comment later being embedded
3012                              * within another regex. If so, we don't want this
3013                              * regex's "commentization" to leak out to the
3014                              * right part of the enclosing regex, we must cap
3015                              * it with a newline.
3016                              *
3017                              * So, if /x was used, we scan backwards from the
3018                              * end of the regex. If we find a '#' before we
3019                              * find a newline, we need to add a newline
3020                              * ourself. If we find a '\n' first (or if we
3021                              * don't find '#' or '\n'), we don't need to add
3022                              * anything.  -jfriedl
3023                              */
3024                             if (PMf_EXTENDED & re->reganch)
3025                             {
3026                                 char *endptr = re->precomp + re->prelen;
3027                                 while (endptr >= re->precomp)
3028                                 {
3029                                     char c = *(endptr--);
3030                                     if (c == '\n')
3031                                         break; /* don't need another */
3032                                     if (c == '#') {
3033                                         /* we end while in a comment, so we
3034                                            need a newline */
3035                                         mg->mg_len++; /* save space for it */
3036                                         need_newline = 1; /* note to add it */
3037                                         break;
3038                                     }
3039                                 }
3040                             }
3041
3042                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3043                             Copy("(?", mg->mg_ptr, 2, char);
3044                             Copy(reflags, mg->mg_ptr+2, left, char);
3045                             Copy(":", mg->mg_ptr+left+2, 1, char);
3046                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3047                             if (need_newline)
3048                                 mg->mg_ptr[mg->mg_len - 2] = '\n';
3049                             mg->mg_ptr[mg->mg_len - 1] = ')';
3050                             mg->mg_ptr[mg->mg_len] = 0;
3051                         }
3052                         PL_reginterp_cnt += re->program[0].next_off;
3053
3054                         if (re->reganch & ROPT_UTF8)
3055                             SvUTF8_on(origsv);
3056                         else
3057                             SvUTF8_off(origsv);
3058                         *lp = mg->mg_len;
3059                         return mg->mg_ptr;
3060                     }
3061                                         /* Fall through */
3062                 case SVt_NULL:
3063                 case SVt_IV:
3064                 case SVt_NV:
3065                 case SVt_RV:
3066                 case SVt_PV:
3067                 case SVt_PVIV:
3068                 case SVt_PVNV:
3069                 case SVt_PVBM:  if (SvROK(sv))
3070                                     s = "REF";
3071                                 else
3072                                     s = "SCALAR";               break;
3073                 case SVt_PVLV:  s = SvROK(sv) ? "REF":"LVALUE"; break;
3074                 case SVt_PVAV:  s = "ARRAY";                    break;
3075                 case SVt_PVHV:  s = "HASH";                     break;
3076                 case SVt_PVCV:  s = "CODE";                     break;
3077                 case SVt_PVGV:  s = "GLOB";                     break;
3078                 case SVt_PVFM:  s = "FORMAT";                   break;
3079                 case SVt_PVIO:  s = "IO";                       break;
3080                 default:        s = "UNKNOWN";                  break;
3081                 }
3082                 tsv = NEWSV(0,0);
3083                 if (SvOBJECT(sv)) {
3084                     HV *svs = SvSTASH(sv);
3085                     Perl_sv_setpvf(
3086                         aTHX_ tsv, "%s=%s",
3087                         /* [20011101.072] This bandaid for C<package;>
3088                            should eventually be removed. AMS 20011103 */
3089                         (svs ? HvNAME(svs) : "<none>"), s
3090                     );
3091                 }
3092                 else
3093                     sv_setpv(tsv, s);
3094                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3095                 goto tokensaveref;
3096             }
3097             *lp = strlen(s);
3098             return s;
3099         }
3100         if (SvREADONLY(sv) && !SvOK(sv)) {
3101             if (ckWARN(WARN_UNINITIALIZED))
3102                 report_uninit();
3103             *lp = 0;
3104             return "";
3105         }
3106     }
3107     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3108         /* I'm assuming that if both IV and NV are equally valid then
3109            converting the IV is going to be more efficient */
3110         U32 isIOK = SvIOK(sv);
3111         U32 isUIOK = SvIsUV(sv);
3112         char buf[TYPE_CHARS(UV)];
3113         char *ebuf, *ptr;
3114
3115         if (SvTYPE(sv) < SVt_PVIV)
3116             sv_upgrade(sv, SVt_PVIV);
3117         if (isUIOK)
3118             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3119         else
3120             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3121         SvGROW(sv, (STRLEN)(ebuf - ptr + 1));   /* inlined from sv_setpvn */
3122         Move(ptr,SvPVX(sv),ebuf - ptr,char);
3123         SvCUR_set(sv, ebuf - ptr);
3124         s = SvEND(sv);
3125         *s = '\0';
3126         if (isIOK)
3127             SvIOK_on(sv);
3128         else
3129             SvIOKp_on(sv);
3130         if (isUIOK)
3131             SvIsUV_on(sv);
3132     }
3133     else if (SvNOKp(sv)) {
3134         if (SvTYPE(sv) < SVt_PVNV)
3135             sv_upgrade(sv, SVt_PVNV);
3136         /* The +20 is pure guesswork.  Configure test needed. --jhi */
3137         SvGROW(sv, NV_DIG + 20);
3138         s = SvPVX(sv);
3139         olderrno = errno;       /* some Xenix systems wipe out errno here */
3140 #ifdef apollo
3141         if (SvNVX(sv) == 0.0)
3142             (void)strcpy(s,"0");
3143         else
3144 #endif /*apollo*/
3145         {
3146             Gconvert(SvNVX(sv), NV_DIG, 0, s);
3147         }
3148         errno = olderrno;
3149 #ifdef FIXNEGATIVEZERO
3150         if (*s == '-' && s[1] == '0' && !s[2])
3151             strcpy(s,"0");
3152 #endif
3153         while (*s) s++;
3154 #ifdef hcx
3155         if (s[-1] == '.')
3156             *--s = '\0';
3157 #endif
3158     }
3159     else {
3160         if (ckWARN(WARN_UNINITIALIZED)
3161             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3162             report_uninit();
3163         *lp = 0;
3164         if (SvTYPE(sv) < SVt_PV)
3165             /* Typically the caller expects that sv_any is not NULL now.  */
3166             sv_upgrade(sv, SVt_PV);
3167         return "";
3168     }
3169     *lp = s - SvPVX(sv);
3170     SvCUR_set(sv, *lp);
3171     SvPOK_on(sv);
3172     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3173                           PTR2UV(sv),SvPVX(sv)));
3174     return SvPVX(sv);
3175
3176   tokensave:
3177     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
3178         /* Sneaky stuff here */
3179
3180       tokensaveref:
3181         if (!tsv)
3182             tsv = newSVpv(tmpbuf, 0);
3183         sv_2mortal(tsv);
3184         *lp = SvCUR(tsv);
3185         return SvPVX(tsv);
3186     }
3187     else {
3188         STRLEN len;
3189         char *t;
3190
3191         if (tsv) {
3192             sv_2mortal(tsv);
3193             t = SvPVX(tsv);
3194             len = SvCUR(tsv);
3195         }
3196         else {
3197             t = tmpbuf;
3198             len = strlen(tmpbuf);
3199         }
3200 #ifdef FIXNEGATIVEZERO
3201         if (len == 2 && t[0] == '-' && t[1] == '0') {
3202             t = "0";
3203             len = 1;
3204         }
3205 #endif
3206         (void)SvUPGRADE(sv, SVt_PV);
3207         *lp = len;
3208         s = SvGROW(sv, len + 1);
3209         SvCUR_set(sv, len);
3210         (void)strcpy(s, t);
3211         SvPOKp_on(sv);
3212         return s;
3213     }
3214 }
3215
3216 /*
3217 =for apidoc sv_copypv
3218
3219 Copies a stringified representation of the source SV into the
3220 destination SV.  Automatically performs any necessary mg_get and
3221 coercion of numeric values into strings.  Guaranteed to preserve
3222 UTF-8 flag even from overloaded objects.  Similar in nature to
3223 sv_2pv[_flags] but operates directly on an SV instead of just the
3224 string.  Mostly uses sv_2pv_flags to do its work, except when that
3225 would lose the UTF-8'ness of the PV.
3226
3227 =cut
3228 */
3229
3230 void
3231 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3232 {
3233     STRLEN len;
3234     char *s;
3235     s = SvPV(ssv,len);
3236     sv_setpvn(dsv,s,len);
3237     if (SvUTF8(ssv))
3238         SvUTF8_on(dsv);
3239     else
3240         SvUTF8_off(dsv);
3241 }
3242
3243 /*
3244 =for apidoc sv_2pvbyte_nolen
3245
3246 Return a pointer to the byte-encoded representation of the SV.
3247 May cause the SV to be downgraded from UTF8 as a side-effect.
3248
3249 Usually accessed via the C<SvPVbyte_nolen> macro.
3250
3251 =cut
3252 */
3253
3254 char *
3255 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3256 {
3257     STRLEN n_a;
3258     return sv_2pvbyte(sv, &n_a);
3259 }
3260
3261 /*
3262 =for apidoc sv_2pvbyte
3263
3264 Return a pointer to the byte-encoded representation of the SV, and set *lp
3265 to its length.  May cause the SV to be downgraded from UTF8 as a
3266 side-effect.
3267
3268 Usually accessed via the C<SvPVbyte> macro.
3269
3270 =cut
3271 */
3272
3273 char *
3274 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3275 {
3276     sv_utf8_downgrade(sv,0);
3277     return SvPV(sv,*lp);
3278 }
3279
3280 /*
3281 =for apidoc sv_2pvutf8_nolen
3282
3283 Return a pointer to the UTF8-encoded representation of the SV.
3284 May cause the SV to be upgraded to UTF8 as a side-effect.
3285
3286 Usually accessed via the C<SvPVutf8_nolen> macro.
3287
3288 =cut
3289 */
3290
3291 char *
3292 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3293 {
3294     STRLEN n_a;
3295     return sv_2pvutf8(sv, &n_a);
3296 }
3297
3298 /*
3299 =for apidoc sv_2pvutf8
3300
3301 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3302 to its length.  May cause the SV to be upgraded to UTF8 as a side-effect.
3303
3304 Usually accessed via the C<SvPVutf8> macro.
3305
3306 =cut
3307 */
3308
3309 char *
3310 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3311 {
3312     sv_utf8_upgrade(sv);
3313     return SvPV(sv,*lp);
3314 }
3315
3316 /*
3317 =for apidoc sv_2bool
3318
3319 This function is only called on magical items, and is only used by
3320 sv_true() or its macro equivalent.
3321
3322 =cut
3323 */
3324
3325 bool
3326 Perl_sv_2bool(pTHX_ register SV *sv)
3327 {
3328     if (SvGMAGICAL(sv))
3329         mg_get(sv);
3330
3331     if (!SvOK(sv))
3332         return 0;
3333     if (SvROK(sv)) {
3334         SV* tmpsv;
3335         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3336                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3337             return (bool)SvTRUE(tmpsv);
3338       return SvRV(sv) != 0;
3339     }
3340     if (SvPOKp(sv)) {
3341         register XPV* Xpvtmp;
3342         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3343                 (*Xpvtmp->xpv_pv > '0' ||
3344                 Xpvtmp->xpv_cur > 1 ||
3345                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3346             return 1;
3347         else
3348             return 0;
3349     }
3350     else {
3351         if (SvIOKp(sv))
3352             return SvIVX(sv) != 0;
3353         else {
3354             if (SvNOKp(sv))
3355                 return SvNVX(sv) != 0.0;
3356             else
3357                 return FALSE;
3358         }
3359     }
3360 }
3361
3362 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3363  * this function provided for binary compatibility only
3364  */
3365
3366
3367 STRLEN
3368 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3369 {
3370     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3371 }
3372
3373 /*
3374 =for apidoc sv_utf8_upgrade
3375
3376 Convert the PV of an SV to its UTF8-encoded form.
3377 Forces the SV to string form if it is not already.
3378 Always sets the SvUTF8 flag to avoid future validity checks even
3379 if all the bytes have hibit clear.
3380
3381 This is not as a general purpose byte encoding to Unicode interface:
3382 use the Encode extension for that.
3383
3384 =for apidoc sv_utf8_upgrade_flags
3385
3386 Convert the PV of an SV to its UTF8-encoded form.
3387 Forces the SV to string form if it is not already.
3388 Always sets the SvUTF8 flag to avoid future validity checks even
3389 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3390 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3391 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3392
3393 This is not as a general purpose byte encoding to Unicode interface:
3394 use the Encode extension for that.
3395
3396 =cut
3397 */
3398
3399 STRLEN
3400 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3401 {
3402     U8 *s, *t, *e;
3403     int  hibit = 0;
3404
3405     if (!sv)
3406         return 0;
3407
3408     if (!SvPOK(sv)) {
3409         STRLEN len = 0;
3410         (void) sv_2pv_flags(sv,&len, flags);
3411         if (!SvPOK(sv))
3412              return len;
3413     }
3414
3415     if (SvUTF8(sv))
3416         return SvCUR(sv);
3417
3418     if (SvREADONLY(sv) && SvFAKE(sv)) {
3419         sv_force_normal(sv);
3420     }
3421
3422     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3423         sv_recode_to_utf8(sv, PL_encoding);
3424     else { /* Assume Latin-1/EBCDIC */
3425          /* This function could be much more efficient if we
3426           * had a FLAG in SVs to signal if there are any hibit
3427           * chars in the PV.  Given that there isn't such a flag
3428           * make the loop as fast as possible. */
3429          s = (U8 *) SvPVX(sv);
3430          e = (U8 *) SvEND(sv);
3431          t = s;
3432          while (t < e) {
3433               U8 ch = *t++;
3434               if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3435                    break;
3436          }
3437          if (hibit) {
3438               STRLEN len;
3439
3440               len = SvCUR(sv) + 1; /* Plus the \0 */
3441               SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3442               SvCUR(sv) = len - 1;
3443               if (SvLEN(sv) != 0)
3444                    Safefree(s); /* No longer using what was there before. */
3445               SvLEN(sv) = len; /* No longer know the real size. */
3446          }
3447          /* Mark as UTF-8 even if no hibit - saves scanning loop */
3448          SvUTF8_on(sv);
3449     }
3450     return SvCUR(sv);
3451 }
3452
3453 /*
3454 =for apidoc sv_utf8_downgrade
3455
3456 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3457 This may not be possible if the PV contains non-byte encoding characters;
3458 if this is the case, either returns false or, if C<fail_ok> is not
3459 true, croaks.
3460
3461 This is not as a general purpose Unicode to byte encoding interface:
3462 use the Encode extension for that.
3463
3464 =cut
3465 */
3466
3467 bool
3468 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3469 {
3470     if (SvPOK(sv) && SvUTF8(sv)) {
3471         if (SvCUR(sv)) {
3472             U8 *s;
3473             STRLEN len;
3474
3475             if (SvREADONLY(sv) && SvFAKE(sv))
3476                 sv_force_normal(sv);
3477             s = (U8 *) SvPV(sv, len);
3478             if (!utf8_to_bytes(s, &len)) {
3479                 if (fail_ok)
3480                     return FALSE;
3481                 else {
3482                     if (PL_op)
3483                         Perl_croak(aTHX_ "Wide character in %s",
3484                                    OP_DESC(PL_op));
3485                     else
3486                         Perl_croak(aTHX_ "Wide character");
3487                 }
3488             }
3489             SvCUR(sv) = len;
3490         }
3491     }
3492     SvUTF8_off(sv);
3493     return TRUE;
3494 }
3495
3496 /*
3497 =for apidoc sv_utf8_encode
3498
3499 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3500 flag so that it looks like octets again. Used as a building block
3501 for encode_utf8 in Encode.xs
3502
3503 =cut
3504 */
3505
3506 void
3507 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3508 {
3509     (void) sv_utf8_upgrade(sv);
3510     SvUTF8_off(sv);
3511 }
3512
3513 /*
3514 =for apidoc sv_utf8_decode
3515
3516 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3517 turn off SvUTF8 if needed so that we see characters. Used as a building block
3518 for decode_utf8 in Encode.xs
3519
3520 =cut
3521 */
3522
3523 bool
3524 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3525 {
3526     if (SvPOK(sv)) {
3527         U8 *c;
3528         U8 *e;
3529
3530         /* The octets may have got themselves encoded - get them back as
3531          * bytes
3532          */
3533         if (!sv_utf8_downgrade(sv, TRUE))
3534             return FALSE;
3535
3536         /* it is actually just a matter of turning the utf8 flag on, but
3537          * we want to make sure everything inside is valid utf8 first.
3538          */
3539         c = (U8 *) SvPVX(sv);
3540         if (!is_utf8_string(c, SvCUR(sv)+1))
3541             return FALSE;
3542         e = (U8 *) SvEND(sv);
3543         while (c < e) {
3544             U8 ch = *c++;
3545             if (!UTF8_IS_INVARIANT(ch)) {
3546                 SvUTF8_on(sv);
3547                 break;
3548             }
3549         }
3550     }
3551     return TRUE;
3552 }
3553
3554 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
3555  * this function provided for binary compatibility only
3556  */
3557
3558 void
3559 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3560 {
3561     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3562 }
3563
3564 /*
3565 =for apidoc sv_setsv
3566
3567 Copies the contents of the source SV C<ssv> into the destination SV
3568 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3569 function if the source SV needs to be reused. Does not handle 'set' magic.
3570 Loosely speaking, it performs a copy-by-value, obliterating any previous
3571 content of the destination.
3572
3573 You probably want to use one of the assortment of wrappers, such as
3574 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3575 C<SvSetMagicSV_nosteal>.
3576
3577 =for apidoc sv_setsv_flags
3578
3579 Copies the contents of the source SV C<ssv> into the destination SV
3580 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3581 function if the source SV needs to be reused. Does not handle 'set' magic.
3582 Loosely speaking, it performs a copy-by-value, obliterating any previous
3583 content of the destination.
3584 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3585 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3586 implemented in terms of this function.
3587
3588 You probably want to use one of the assortment of wrappers, such as
3589 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3590 C<SvSetMagicSV_nosteal>.
3591
3592 This is the primary function for copying scalars, and most other
3593 copy-ish functions and macros use this underneath.
3594
3595 =cut
3596 */
3597
3598 void
3599 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3600 {
3601     register U32 sflags;
3602     register int dtype;
3603     register int stype;
3604
3605     if (sstr == dstr)
3606         return;
3607     SV_CHECK_THINKFIRST(dstr);
3608     if (!sstr)
3609         sstr = &PL_sv_undef;
3610     stype = SvTYPE(sstr);
3611     dtype = SvTYPE(dstr);
3612
3613     SvAMAGIC_off(dstr);
3614     if ( SvVOK(dstr) )
3615     {
3616         /* need to nuke the magic */
3617         mg_free(dstr);
3618         SvRMAGICAL_off(dstr);
3619     }
3620
3621     /* There's a lot of redundancy below but we're going for speed here */
3622
3623     switch (stype) {
3624     case SVt_NULL:
3625       undef_sstr:
3626         if (dtype != SVt_PVGV) {
3627             (void)SvOK_off(dstr);
3628             return;
3629         }
3630         break;
3631     case SVt_IV:
3632         if (SvIOK(sstr)) {
3633             switch (dtype) {
3634             case SVt_NULL:
3635                 sv_upgrade(dstr, SVt_IV);
3636                 break;
3637             case SVt_NV:
3638                 sv_upgrade(dstr, SVt_PVNV);
3639                 break;
3640             case SVt_RV:
3641             case SVt_PV:
3642                 sv_upgrade(dstr, SVt_PVIV);
3643                 break;
3644             }
3645             (void)SvIOK_only(dstr);
3646             SvIVX(dstr) = SvIVX(sstr);
3647             if (SvIsUV(sstr))
3648                 SvIsUV_on(dstr);
3649             if (SvTAINTED(sstr))
3650                 SvTAINT(dstr);
3651             return;
3652         }
3653         goto undef_sstr;
3654
3655     case SVt_NV:
3656         if (SvNOK(sstr)) {
3657             switch (dtype) {
3658             case SVt_NULL:
3659             case SVt_IV:
3660                 sv_upgrade(dstr, SVt_NV);
3661                 break;
3662             case SVt_RV:
3663             case SVt_PV:
3664             case SVt_PVIV:
3665                 sv_upgrade(dstr, SVt_PVNV);
3666                 break;
3667             }
3668             SvNVX(dstr) = SvNVX(sstr);
3669             (void)SvNOK_only(dstr);
3670             if (SvTAINTED(sstr))
3671                 SvTAINT(dstr);
3672             return;
3673         }
3674         goto undef_sstr;
3675
3676     case SVt_RV:
3677         if (dtype < SVt_RV)
3678             sv_upgrade(dstr, SVt_RV);
3679         else if (dtype == SVt_PVGV &&
3680                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3681             sstr = SvRV(sstr);
3682             if (sstr == dstr) {
3683                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3684                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3685                 {
3686                     GvIMPORTED_on(dstr);
3687                 }
3688                 GvMULTI_on(dstr);
3689                 return;
3690             }
3691             goto glob_assign;
3692         }
3693         break;
3694     case SVt_PV:
3695     case SVt_PVFM:
3696         if (dtype < SVt_PV)
3697             sv_upgrade(dstr, SVt_PV);
3698         break;
3699     case SVt_PVIV:
3700         if (dtype < SVt_PVIV)
3701             sv_upgrade(dstr, SVt_PVIV);
3702         break;
3703     case SVt_PVNV:
3704         if (dtype < SVt_PVNV)
3705             sv_upgrade(dstr, SVt_PVNV);
3706         break;
3707     case SVt_PVAV:
3708     case SVt_PVHV:
3709     case SVt_PVCV:
3710     case SVt_PVIO:
3711         if (PL_op)
3712             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3713                 OP_NAME(PL_op));
3714         else
3715             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3716         break;
3717
3718     case SVt_PVGV:
3719         if (dtype <= SVt_PVGV) {
3720   glob_assign:
3721             if (dtype != SVt_PVGV) {
3722                 char *name = GvNAME(sstr);
3723                 STRLEN len = GvNAMELEN(sstr);
3724                 sv_upgrade(dstr, SVt_PVGV);
3725                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3726                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3727                 GvNAME(dstr) = savepvn(name, len);
3728                 GvNAMELEN(dstr) = len;
3729                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3730             }
3731             /* ahem, death to those who redefine active sort subs */
3732             else if (PL_curstackinfo->si_type == PERLSI_SORT
3733                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3734                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3735                       GvNAME(dstr));
3736
3737 #ifdef GV_UNIQUE_CHECK
3738                 if (GvUNIQUE((GV*)dstr)) {
3739                     Perl_croak(aTHX_ PL_no_modify);
3740                 }
3741 #endif
3742
3743             (void)SvOK_off(dstr);
3744             GvINTRO_off(dstr);          /* one-shot flag */
3745             gp_free((GV*)dstr);
3746             GvGP(dstr) = gp_ref(GvGP(sstr));
3747             if (SvTAINTED(sstr))
3748                 SvTAINT(dstr);
3749             if (GvIMPORTED(dstr) != GVf_IMPORTED
3750                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3751             {
3752                 GvIMPORTED_on(dstr);
3753             }
3754             GvMULTI_on(dstr);
3755             return;
3756         }
3757         /* FALL THROUGH */
3758
3759     default:
3760         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3761             mg_get(sstr);
3762             if ((int)SvTYPE(sstr) != stype) {
3763                 stype = SvTYPE(sstr);
3764                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3765                     goto glob_assign;
3766             }
3767         }
3768         if (stype == SVt_PVLV)
3769             (void)SvUPGRADE(dstr, SVt_PVNV);
3770         else
3771             (void)SvUPGRADE(dstr, (U32)stype);
3772     }
3773
3774     sflags = SvFLAGS(sstr);
3775
3776     if (sflags & SVf_ROK) {
3777         if (dtype >= SVt_PV) {
3778             if (dtype == SVt_PVGV) {
3779                 SV *sref = SvREFCNT_inc(SvRV(sstr));
3780                 SV *dref = 0;
3781                 int intro = GvINTRO(dstr);
3782
3783 #ifdef GV_UNIQUE_CHECK
3784                 if (GvUNIQUE((GV*)dstr)) {
3785                     Perl_croak(aTHX_ PL_no_modify);
3786                 }
3787 #endif
3788
3789                 if (intro) {
3790                     GvINTRO_off(dstr);  /* one-shot flag */
3791                     GvLINE(dstr) = CopLINE(PL_curcop);
3792                     GvEGV(dstr) = (GV*)dstr;
3793                 }
3794                 GvMULTI_on(dstr);
3795                 switch (SvTYPE(sref)) {
3796                 case SVt_PVAV:
3797                     if (intro)
3798                         SAVEGENERICSV(GvAV(dstr));
3799                     else
3800                         dref = (SV*)GvAV(dstr);
3801                     GvAV(dstr) = (AV*)sref;
3802                     if (!GvIMPORTED_AV(dstr)
3803                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3804                     {
3805                         GvIMPORTED_AV_on(dstr);
3806                     }
3807                     break;
3808                 case SVt_PVHV:
3809                     if (intro)
3810                         SAVEGENERICSV(GvHV(dstr));
3811                     else
3812                         dref = (SV*)GvHV(dstr);
3813                     GvHV(dstr) = (HV*)sref;
3814                     if (!GvIMPORTED_HV(dstr)
3815                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3816                     {
3817                         GvIMPORTED_HV_on(dstr);
3818                     }
3819                     break;
3820                 case SVt_PVCV:
3821                     if (intro) {
3822                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3823                             SvREFCNT_dec(GvCV(dstr));
3824                             GvCV(dstr) = Nullcv;
3825                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3826                             PL_sub_generation++;
3827                         }
3828                         SAVEGENERICSV(GvCV(dstr));
3829                     }
3830                     else
3831                         dref = (SV*)GvCV(dstr);
3832                     if (GvCV(dstr) != (CV*)sref) {
3833                         CV* cv = GvCV(dstr);
3834                         if (cv) {
3835                             if (!GvCVGEN((GV*)dstr) &&
3836                                 (CvROOT(cv) || CvXSUB(cv)))
3837                             {
3838                                 /* ahem, death to those who redefine
3839                                  * active sort subs */
3840                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3841                                       PL_sortcop == CvSTART(cv))
3842                                     Perl_croak(aTHX_
3843                                     "Can't redefine active sort subroutine %s",
3844                                           GvENAME((GV*)dstr));
3845                                 /* Redefining a sub - warning is mandatory if
3846                                    it was a const and its value changed. */
3847                                 if (ckWARN(WARN_REDEFINE)
3848                                     || (CvCONST(cv)
3849                                         && (!CvCONST((CV*)sref)
3850                                             || sv_cmp(cv_const_sv(cv),
3851                                                       cv_const_sv((CV*)sref)))))
3852                                 {
3853                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3854                                         CvCONST(cv)
3855                                         ? "Constant subroutine %s::%s redefined"
3856                                         : "Subroutine %s::%s redefined",
3857                                         HvNAME(GvSTASH((GV*)dstr)),
3858                                         GvENAME((GV*)dstr));
3859                                 }
3860                             }
3861                             if (!intro)
3862                                 cv_ckproto(cv, (GV*)dstr,
3863                                         SvPOK(sref) ? SvPVX(sref) : Nullch);
3864                         }
3865                         GvCV(dstr) = (CV*)sref;
3866                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3867                         GvASSUMECV_on(dstr);
3868                         PL_sub_generation++;
3869                     }
3870                     if (!GvIMPORTED_CV(dstr)
3871                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3872                     {
3873                         GvIMPORTED_CV_on(dstr);
3874                     }
3875                     break;
3876                 case SVt_PVIO:
3877                     if (intro)
3878                         SAVEGENERICSV(GvIOp(dstr));
3879                     else
3880                         dref = (SV*)GvIOp(dstr);
3881                     GvIOp(dstr) = (IO*)sref;
3882                     break;
3883                 case SVt_PVFM:
3884                     if (intro)
3885                         SAVEGENERICSV(GvFORM(dstr));
3886                     else
3887                         dref = (SV*)GvFORM(dstr);
3888                     GvFORM(dstr) = (CV*)sref;
3889                     break;
3890                 default:
3891                     if (intro)
3892                         SAVEGENERICSV(GvSV(dstr));
3893                     else
3894                         dref = (SV*)GvSV(dstr);
3895                     GvSV(dstr) = sref;
3896                     if (!GvIMPORTED_SV(dstr)
3897                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3898                     {
3899                         GvIMPORTED_SV_on(dstr);
3900                     }
3901                     break;
3902                 }
3903                 if (dref)
3904                     SvREFCNT_dec(dref);
3905                 if (SvTAINTED(sstr))
3906                     SvTAINT(dstr);
3907                 return;
3908             }
3909             if (SvPVX(dstr)) {
3910                 (void)SvOOK_off(dstr);          /* backoff */
3911                 if (SvLEN(dstr))
3912                     Safefree(SvPVX(dstr));
3913                 SvLEN(dstr)=SvCUR(dstr)=0;
3914             }
3915         }
3916         (void)SvOK_off(dstr);
3917         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3918         SvROK_on(dstr);
3919         if (sflags & SVp_NOK) {
3920             SvNOKp_on(dstr);
3921             /* Only set the public OK flag if the source has public OK.  */
3922             if (sflags & SVf_NOK)
3923                 SvFLAGS(dstr) |= SVf_NOK;
3924             SvNVX(dstr) = SvNVX(sstr);
3925         }
3926         if (sflags & SVp_IOK) {
3927             (void)SvIOKp_on(dstr);
3928             if (sflags & SVf_IOK)
3929                 SvFLAGS(dstr) |= SVf_IOK;
3930             if (sflags & SVf_IVisUV)
3931                 SvIsUV_on(dstr);
3932             SvIVX(dstr) = SvIVX(sstr);
3933         }
3934         if (SvAMAGIC(sstr)) {
3935             SvAMAGIC_on(dstr);
3936         }
3937     }
3938     else if (sflags & SVp_POK) {
3939
3940         /*
3941          * Check to see if we can just swipe the string.  If so, it's a
3942          * possible small lose on short strings, but a big win on long ones.
3943          * It might even be a win on short strings if SvPVX(dstr)
3944          * has to be allocated and SvPVX(sstr) has to be freed.
3945          */
3946
3947         if (SvTEMP(sstr) &&             /* slated for free anyway? */
3948             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
3949             !(sflags & SVf_OOK) &&      /* and not involved in OOK hack? */
3950             SvLEN(sstr)         &&      /* and really is a string */
3951                                 /* and won't be needed again, potentially */
3952             !(PL_op && PL_op->op_type == OP_AASSIGN))
3953         {
3954             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
3955                 if (SvOOK(dstr)) {
3956                     SvFLAGS(dstr) &= ~SVf_OOK;
3957                     Safefree(SvPVX(dstr) - SvIVX(dstr));
3958                 }
3959                 else if (SvLEN(dstr))
3960                     Safefree(SvPVX(dstr));
3961             }
3962             (void)SvPOK_only(dstr);
3963             SvPV_set(dstr, SvPVX(sstr));
3964             SvLEN_set(dstr, SvLEN(sstr));
3965             SvCUR_set(dstr, SvCUR(sstr));
3966
3967             SvTEMP_off(dstr);
3968             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
3969             SvPV_set(sstr, Nullch);
3970             SvLEN_set(sstr, 0);
3971             SvCUR_set(sstr, 0);
3972             SvTEMP_off(sstr);
3973         }
3974         else {                          /* have to copy actual string */
3975             STRLEN len = SvCUR(sstr);
3976             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3977             Move(SvPVX(sstr),SvPVX(dstr),len,char);
3978             SvCUR_set(dstr, len);
3979             *SvEND(dstr) = '\0';
3980             (void)SvPOK_only(dstr);
3981         }
3982         if (sflags & SVf_UTF8)
3983             SvUTF8_on(dstr);
3984         /*SUPPRESS 560*/
3985         if (sflags & SVp_NOK) {
3986             SvNOKp_on(dstr);
3987             if (sflags & SVf_NOK)
3988                 SvFLAGS(dstr) |= SVf_NOK;
3989             SvNVX(dstr) = SvNVX(sstr);
3990         }
3991         if (sflags & SVp_IOK) {
3992             (void)SvIOKp_on(dstr);
3993             if (sflags & SVf_IOK)
3994                 SvFLAGS(dstr) |= SVf_IOK;
3995             if (sflags & SVf_IVisUV)
3996                 SvIsUV_on(dstr);
3997             SvIVX(dstr) = SvIVX(sstr);
3998         }
3999         if ( SvVOK(sstr) ) {
4000             MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4001             sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4002                      smg->mg_ptr, smg->mg_len);
4003             SvRMAGICAL_on(dstr);
4004         }
4005     }
4006     else if (sflags & SVp_IOK) {
4007         if (sflags & SVf_IOK)
4008             (void)SvIOK_only(dstr);
4009         else {
4010             (void)SvOK_off(dstr);
4011             (void)SvIOKp_on(dstr);
4012         }
4013         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4014         if (sflags & SVf_IVisUV)
4015             SvIsUV_on(dstr);
4016         SvIVX(dstr) = SvIVX(sstr);
4017         if (sflags & SVp_NOK) {
4018             if (sflags & SVf_NOK)
4019                 (void)SvNOK_on(dstr);
4020             else
4021                 (void)SvNOKp_on(dstr);
4022             SvNVX(dstr) = SvNVX(sstr);
4023         }
4024     }
4025     else if (sflags & SVp_NOK) {
4026         if (sflags & SVf_NOK)
4027             (void)SvNOK_only(dstr);
4028         else {
4029             (void)SvOK_off(dstr);
4030             SvNOKp_on(dstr);
4031         }
4032         SvNVX(dstr) = SvNVX(sstr);
4033     }
4034     else {
4035         if (dtype == SVt_PVGV) {
4036             if (ckWARN(WARN_MISC))
4037                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4038         }
4039         else
4040             (void)SvOK_off(dstr);
4041     }
4042     if (SvTAINTED(sstr))
4043         SvTAINT(dstr);
4044 }
4045
4046 /*
4047 =for apidoc sv_setsv_mg
4048
4049 Like C<sv_setsv>, but also handles 'set' magic.
4050
4051 =cut
4052 */
4053
4054 void
4055 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4056 {
4057     sv_setsv(dstr,sstr);
4058     SvSETMAGIC(dstr);
4059 }
4060
4061 /*
4062 =for apidoc sv_setpvn
4063
4064 Copies a string into an SV.  The C<len> parameter indicates the number of
4065 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4066
4067 =cut
4068 */
4069
4070 void
4071 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4072 {
4073     register char *dptr;
4074
4075     SV_CHECK_THINKFIRST(sv);
4076     if (!ptr) {
4077         (void)SvOK_off(sv);
4078         return;
4079     }
4080     else {
4081         /* len is STRLEN which is unsigned, need to copy to signed */
4082         IV iv = len;
4083         if (iv < 0)
4084             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4085     }
4086     (void)SvUPGRADE(sv, SVt_PV);
4087
4088     SvGROW(sv, len + 1);
4089     dptr = SvPVX(sv);
4090     Move(ptr,dptr,len,char);
4091     dptr[len] = '\0';
4092     SvCUR_set(sv, len);
4093     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4094     SvTAINT(sv);
4095 }
4096
4097 /*
4098 =for apidoc sv_setpvn_mg
4099
4100 Like C<sv_setpvn>, but also handles 'set' magic.
4101
4102 =cut
4103 */
4104
4105 void
4106 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4107 {
4108     sv_setpvn(sv,ptr,len);
4109     SvSETMAGIC(sv);
4110 }
4111
4112 /*
4113 =for apidoc sv_setpv
4114
4115 Copies a string into an SV.  The string must be null-terminated.  Does not
4116 handle 'set' magic.  See C<sv_setpv_mg>.
4117
4118 =cut
4119 */
4120
4121 void
4122 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4123 {
4124     register STRLEN len;
4125
4126     SV_CHECK_THINKFIRST(sv);
4127     if (!ptr) {
4128         (void)SvOK_off(sv);
4129         return;
4130     }
4131     len = strlen(ptr);
4132     (void)SvUPGRADE(sv, SVt_PV);
4133
4134     SvGROW(sv, len + 1);
4135     Move(ptr,SvPVX(sv),len+1,char);
4136     SvCUR_set(sv, len);
4137     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4138     SvTAINT(sv);
4139 }
4140
4141 /*
4142 =for apidoc sv_setpv_mg
4143
4144 Like C<sv_setpv>, but also handles 'set' magic.
4145
4146 =cut
4147 */
4148
4149 void
4150 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4151 {
4152     sv_setpv(sv,ptr);
4153     SvSETMAGIC(sv);
4154 }
4155
4156 /*
4157 =for apidoc sv_usepvn
4158
4159 Tells an SV to use C<ptr> to find its string value.  Normally the string is
4160 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4161 The C<ptr> should point to memory that was allocated by C<malloc>.  The
4162 string length, C<len>, must be supplied.  This function will realloc the
4163 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4164 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
4165 See C<sv_usepvn_mg>.
4166
4167 =cut
4168 */
4169
4170 void
4171 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4172 {
4173     SV_CHECK_THINKFIRST(sv);
4174     (void)SvUPGRADE(sv, SVt_PV);
4175     if (!ptr) {
4176         (void)SvOK_off(sv);
4177         return;
4178     }
4179     (void)SvOOK_off(sv);
4180     if (SvPVX(sv) && SvLEN(sv))
4181         Safefree(SvPVX(sv));
4182     Renew(ptr, len+1, char);
4183     SvPVX(sv) = ptr;
4184     SvCUR_set(sv, len);
4185     SvLEN_set(sv, len+1);
4186     *SvEND(sv) = '\0';
4187     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4188     SvTAINT(sv);
4189 }
4190
4191 /*
4192 =for apidoc sv_usepvn_mg
4193
4194 Like C<sv_usepvn>, but also handles 'set' magic.
4195
4196 =cut
4197 */
4198
4199 void
4200 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4201 {
4202     sv_usepvn(sv,ptr,len);
4203     SvSETMAGIC(sv);
4204 }
4205
4206 /*
4207 =for apidoc sv_force_normal_flags
4208
4209 Undo various types of fakery on an SV: if the PV is a shared string, make
4210 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4211 an xpvmg. The C<flags> parameter gets passed to  C<sv_unref_flags()>
4212 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4213
4214 =cut
4215 */
4216
4217 void
4218 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4219 {
4220     if (SvREADONLY(sv)) {
4221         if (SvFAKE(sv)) {
4222             char *pvx = SvPVX(sv);
4223             STRLEN len = SvCUR(sv);
4224             U32 hash   = SvUVX(sv);
4225             SvGROW(sv, len + 1);
4226             Move(pvx,SvPVX(sv),len,char);
4227             *SvEND(sv) = '\0';
4228             SvFAKE_off(sv);
4229             SvREADONLY_off(sv);
4230             unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4231         }
4232         else if (PL_curcop != &PL_compiling)
4233             Perl_croak(aTHX_ PL_no_modify);
4234     }
4235     if (SvROK(sv))
4236         sv_unref_flags(sv, flags);
4237     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4238         sv_unglob(sv);
4239 }
4240
4241 /*
4242 =for apidoc sv_force_normal
4243
4244 Undo various types of fakery on an SV: if the PV is a shared string, make
4245 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4246 an xpvmg. See also C<sv_force_normal_flags>.
4247
4248 =cut
4249 */
4250
4251 void
4252 Perl_sv_force_normal(pTHX_ register SV *sv)
4253 {
4254     sv_force_normal_flags(sv, 0);
4255 }
4256
4257 /*
4258 =for apidoc sv_chop
4259
4260 Efficient removal of characters from the beginning of the string buffer.
4261 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4262 the string buffer.  The C<ptr> becomes the first character of the adjusted
4263 string. Uses the "OOK hack".
4264 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
4265 refer to the same chunk of data.
4266
4267 =cut
4268 */
4269
4270 void
4271 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4272 {
4273     register STRLEN delta;
4274     if (!ptr || !SvPOKp(sv))
4275         return;
4276     delta = ptr - SvPVX(sv);
4277     SV_CHECK_THINKFIRST(sv);
4278     if (SvTYPE(sv) < SVt_PVIV)
4279         sv_upgrade(sv,SVt_PVIV);
4280
4281     if (!SvOOK(sv)) {
4282         if (!SvLEN(sv)) { /* make copy of shared string */
4283             char *pvx = SvPVX(sv);
4284             STRLEN len = SvCUR(sv);
4285             SvGROW(sv, len + 1);
4286             Move(pvx,SvPVX(sv),len,char);
4287             *SvEND(sv) = '\0';
4288         }
4289         SvIVX(sv) = 0;
4290         /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4291            and we do that anyway inside the SvNIOK_off
4292         */
4293         SvFLAGS(sv) |= SVf_OOK;
4294     }
4295     SvNIOK_off(sv);
4296     SvLEN(sv) -= delta;
4297     SvCUR(sv) -= delta;
4298     SvPVX(sv) += delta;
4299     SvIVX(sv) += delta;
4300 }
4301
4302 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
4303  * this function provided for binary compatibility only
4304  */
4305
4306 void
4307 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4308 {
4309     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4310 }
4311
4312 /*
4313 =for apidoc sv_catpvn
4314
4315 Concatenates the string onto the end of the string which is in the SV.  The
4316 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4317 status set, then the bytes appended should be valid UTF8.
4318 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4319
4320 =for apidoc sv_catpvn_flags
4321
4322 Concatenates the string onto the end of the string which is in the SV.  The
4323 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4324 status set, then the bytes appended should be valid UTF8.
4325 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4326 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4327 in terms of this function.
4328
4329 =cut
4330 */
4331
4332 void
4333 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4334 {
4335     STRLEN dlen;
4336     char *dstr;
4337
4338     dstr = SvPV_force_flags(dsv, dlen, flags);
4339     SvGROW(dsv, dlen + slen + 1);
4340     if (sstr == dstr)
4341         sstr = SvPVX(dsv);
4342     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4343     SvCUR(dsv) += slen;
4344     *SvEND(dsv) = '\0';
4345     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4346     SvTAINT(dsv);
4347 }
4348
4349 /*
4350 =for apidoc sv_catpvn_mg
4351
4352 Like C<sv_catpvn>, but also handles 'set' magic.
4353
4354 =cut
4355 */
4356
4357 void
4358 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4359 {
4360     sv_catpvn(sv,ptr,len);
4361     SvSETMAGIC(sv);
4362 }
4363
4364 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
4365  * this function provided for binary compatibility only
4366  */
4367
4368 void
4369 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4370 {
4371     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4372 }
4373
4374 /*
4375 =for apidoc sv_catsv
4376
4377 Concatenates the string from SV C<ssv> onto the end of the string in
4378 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4379 not 'set' magic.  See C<sv_catsv_mg>.
4380
4381 =for apidoc sv_catsv_flags
4382
4383 Concatenates the string from SV C<ssv> onto the end of the string in
4384 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4385 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4386 and C<sv_catsv_nomg> are implemented in terms of this function.
4387
4388 =cut */
4389
4390 void
4391 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4392 {
4393     char *spv;
4394     STRLEN slen;
4395     if (!ssv)
4396         return;
4397     if ((spv = SvPV(ssv, slen))) {
4398         /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4399             gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4400             Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4401             get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4402             dsv->sv_flags doesn't have that bit set.
4403                 Andy Dougherty  12 Oct 2001
4404         */
4405         I32 sutf8 = DO_UTF8(ssv);
4406         I32 dutf8;
4407
4408         if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4409             mg_get(dsv);
4410         dutf8 = DO_UTF8(dsv);
4411
4412         if (dutf8 != sutf8) {
4413             if (dutf8) {
4414                 /* Not modifying source SV, so taking a temporary copy. */
4415                 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4416
4417                 sv_utf8_upgrade(csv);
4418                 spv = SvPV(csv, slen);
4419             }
4420             else
4421                 sv_utf8_upgrade_nomg(dsv);
4422         }
4423         sv_catpvn_nomg(dsv, spv, slen);
4424     }
4425 }
4426
4427 /*
4428 =for apidoc sv_catsv_mg
4429
4430 Like C<sv_catsv>, but also handles 'set' magic.
4431
4432 =cut
4433 */
4434
4435 void
4436 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4437 {
4438     sv_catsv(dsv,ssv);
4439     SvSETMAGIC(dsv);
4440 }
4441
4442 /*
4443 =for apidoc sv_catpv
4444
4445 Concatenates the string onto the end of the string which is in the SV.
4446 If the SV has the UTF8 status set, then the bytes appended should be
4447 valid UTF8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4448
4449 =cut */
4450
4451 void
4452 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4453 {
4454     register STRLEN len;
4455     STRLEN tlen;
4456     char *junk;
4457
4458     if (!ptr)
4459         return;
4460     junk = SvPV_force(sv, tlen);
4461     len = strlen(ptr);
4462     SvGROW(sv, tlen + len + 1);
4463     if (ptr == junk)
4464         ptr = SvPVX(sv);
4465     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4466     SvCUR(sv) += len;
4467     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4468     SvTAINT(sv);
4469 }
4470
4471 /*
4472 =for apidoc sv_catpv_mg
4473
4474 Like C<sv_catpv>, but also handles 'set' magic.
4475
4476 =cut
4477 */
4478
4479 void
4480 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4481 {
4482     sv_catpv(sv,ptr);
4483     SvSETMAGIC(sv);
4484 }
4485
4486 /*
4487 =for apidoc newSV
4488
4489 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4490 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4491 macro.
4492
4493 =cut
4494 */
4495
4496 SV *
4497 Perl_newSV(pTHX_ STRLEN len)
4498 {
4499     register SV *sv;
4500
4501     new_SV(sv);
4502     if (len) {
4503         sv_upgrade(sv, SVt_PV);
4504         SvGROW(sv, len + 1);
4505     }
4506     return sv;
4507 }
4508 /*
4509 =for apidoc sv_magicext
4510
4511 Adds magic to an SV, upgrading it if necessary. Applies the
4512 supplied vtable and returns pointer to the magic added.
4513
4514 Note that sv_magicext will allow things that sv_magic will not.
4515 In particular you can add magic to SvREADONLY SVs and and more than
4516 one instance of the same 'how'
4517
4518 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
4519 if C<namelen> is zero then C<name> is stored as-is and - as another special
4520 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
4521 an C<SV*> and has its REFCNT incremented
4522
4523 (This is now used as a subroutine by sv_magic.)
4524
4525 =cut
4526 */
4527 MAGIC *
4528 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4529                  const char* name, I32 namlen)
4530 {
4531     MAGIC* mg;
4532
4533     if (SvTYPE(sv) < SVt_PVMG) {
4534         (void)SvUPGRADE(sv, SVt_PVMG);
4535     }
4536     Newz(702,mg, 1, MAGIC);
4537     mg->mg_moremagic = SvMAGIC(sv);
4538     SvMAGIC(sv) = mg;
4539
4540     /* Some magic sontains a reference loop, where the sv and object refer to
4541        each other.  To prevent a reference loop that would prevent such
4542        objects being freed, we look for such loops and if we find one we
4543        avoid incrementing the object refcount.
4544
4545        Note we cannot do this to avoid self-tie loops as intervening RV must
4546        have its REFCNT incremented to keep it in existence.
4547
4548     */
4549     if (!obj || obj == sv ||
4550         how == PERL_MAGIC_arylen ||
4551         how == PERL_MAGIC_qr ||
4552         (SvTYPE(obj) == SVt_PVGV &&
4553             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4554             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4555             GvFORM(obj) == (CV*)sv)))
4556     {
4557         mg->mg_obj = obj;
4558     }
4559     else {
4560         mg->mg_obj = SvREFCNT_inc(obj);
4561         mg->mg_flags |= MGf_REFCOUNTED;
4562     }
4563
4564     /* Normal self-ties simply pass a null object, and instead of
4565        using mg_obj directly, use the SvTIED_obj macro to produce a
4566        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4567        with an RV obj pointing to the glob containing the PVIO.  In
4568        this case, to avoid a reference loop, we need to weaken the
4569        reference.
4570     */
4571
4572     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4573         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4574     {
4575       sv_rvweaken(obj);
4576     }
4577
4578     mg->mg_type = how;
4579     mg->mg_len = namlen;
4580     if (name) {
4581         if (namlen > 0)
4582             mg->mg_ptr = savepvn(name, namlen);
4583         else if (namlen == HEf_SVKEY)
4584             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4585         else
4586             mg->mg_ptr = (char *) name;
4587     }
4588     mg->mg_virtual = vtable;
4589
4590     mg_magical(sv);
4591     if (SvGMAGICAL(sv))
4592         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4593     return mg;
4594 }
4595
4596 /*
4597 =for apidoc sv_magic
4598
4599 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4600 then adds a new magic item of type C<how> to the head of the magic list.
4601
4602 =cut
4603 */
4604
4605 void
4606 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4607 {
4608     MAGIC* mg;
4609     MGVTBL *vtable = 0;
4610
4611     if (SvREADONLY(sv)) {
4612         if (PL_curcop != &PL_compiling
4613             && how != PERL_MAGIC_regex_global
4614             && how != PERL_MAGIC_bm
4615             && how != PERL_MAGIC_fm
4616             && how != PERL_MAGIC_sv
4617            )
4618         {
4619             Perl_croak(aTHX_ PL_no_modify);
4620         }
4621     }
4622     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4623         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4624             /* sv_magic() refuses to add a magic of the same 'how' as an
4625                existing one
4626              */
4627             if (how == PERL_MAGIC_taint)
4628                 mg->mg_len |= 1;
4629             return;
4630         }
4631     }
4632
4633     switch (how) {
4634     case PERL_MAGIC_sv:
4635         vtable = &PL_vtbl_sv;
4636         break;
4637     case PERL_MAGIC_overload:
4638         vtable = &PL_vtbl_amagic;
4639         break;
4640     case PERL_MAGIC_overload_elem:
4641         vtable = &PL_vtbl_amagicelem;
4642         break;
4643     case PERL_MAGIC_overload_table:
4644         vtable = &PL_vtbl_ovrld;
4645         break;
4646     case PERL_MAGIC_bm:
4647         vtable = &PL_vtbl_bm;
4648         break;
4649     case PERL_MAGIC_regdata:
4650         vtable = &PL_vtbl_regdata;
4651         break;
4652     case PERL_MAGIC_regdatum:
4653         vtable = &PL_vtbl_regdatum;
4654         break;
4655     case PERL_MAGIC_env:
4656         vtable = &PL_vtbl_env;
4657         break;
4658     case PERL_MAGIC_fm:
4659         vtable = &PL_vtbl_fm;
4660         break;
4661     case PERL_MAGIC_envelem:
4662         vtable = &PL_vtbl_envelem;
4663         break;
4664     case PERL_MAGIC_regex_global:
4665         vtable = &PL_vtbl_mglob;
4666         break;
4667     case PERL_MAGIC_isa:
4668         vtable = &PL_vtbl_isa;
4669         break;
4670     case PERL_MAGIC_isaelem:
4671         vtable = &PL_vtbl_isaelem;
4672         break;
4673     case PERL_MAGIC_nkeys:
4674         vtable = &PL_vtbl_nkeys;
4675         break;
4676     case PERL_MAGIC_dbfile:
4677         vtable = 0;
4678         break;
4679     case PERL_MAGIC_dbline:
4680         vtable = &PL_vtbl_dbline;
4681         break;
4682 #ifdef USE_5005THREADS
4683     case PERL_MAGIC_mutex:
4684         vtable = &PL_vtbl_mutex;
4685         break;
4686 #endif /* USE_5005THREADS */
4687 #ifdef USE_LOCALE_COLLATE
4688     case PERL_MAGIC_collxfrm:
4689         vtable = &PL_vtbl_collxfrm;
4690         break;
4691 #endif /* USE_LOCALE_COLLATE */
4692     case PERL_MAGIC_tied:
4693         vtable = &PL_vtbl_pack;
4694         break;
4695     case PERL_MAGIC_tiedelem:
4696     case PERL_MAGIC_tiedscalar:
4697         vtable = &PL_vtbl_packelem;
4698         break;
4699     case PERL_MAGIC_qr:
4700         vtable = &PL_vtbl_regexp;
4701         break;
4702     case PERL_MAGIC_sig:
4703         vtable = &PL_vtbl_sig;
4704         break;
4705     case PERL_MAGIC_sigelem:
4706         vtable = &PL_vtbl_sigelem;
4707         break;
4708     case PERL_MAGIC_taint:
4709         vtable = &PL_vtbl_taint;
4710         break;
4711     case PERL_MAGIC_uvar:
4712         vtable = &PL_vtbl_uvar;
4713         break;
4714     case PERL_MAGIC_vec:
4715         vtable = &PL_vtbl_vec;
4716         break;
4717     case PERL_MAGIC_vstring:
4718         vtable = 0;
4719         break;
4720     case PERL_MAGIC_utf8:
4721         vtable = &PL_vtbl_utf8;
4722         break;
4723     case PERL_MAGIC_substr:
4724         vtable = &PL_vtbl_substr;
4725         break;
4726     case PERL_MAGIC_defelem:
4727         vtable = &PL_vtbl_defelem;
4728         break;
4729     case PERL_MAGIC_glob:
4730         vtable = &PL_vtbl_glob;
4731         break;
4732     case PERL_MAGIC_arylen:
4733         vtable = &PL_vtbl_arylen;
4734         break;
4735     case PERL_MAGIC_pos:
4736         vtable = &PL_vtbl_pos;
4737         break;
4738     case PERL_MAGIC_backref:
4739         vtable = &PL_vtbl_backref;
4740         break;
4741     case PERL_MAGIC_ext:
4742         /* Reserved for use by extensions not perl internals.           */
4743         /* Useful for attaching extension internal data to perl vars.   */
4744         /* Note that multiple extensions may clash if magical scalars   */
4745         /* etc holding private data from one are passed to another.     */
4746         break;
4747     default:
4748         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4749     }
4750
4751     /* Rest of work is done else where */
4752     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4753
4754     switch (how) {
4755     case PERL_MAGIC_taint:
4756         mg->mg_len = 1;
4757         break;
4758     case PERL_MAGIC_ext:
4759     case PERL_MAGIC_dbfile:
4760         SvRMAGICAL_on(sv);
4761         break;
4762     }
4763 }
4764
4765 /*
4766 =for apidoc sv_unmagic
4767
4768 Removes all magic of type C<type> from an SV.
4769
4770 =cut
4771 */
4772
4773 int
4774 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4775 {
4776     MAGIC* mg;
4777     MAGIC** mgp;
4778     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4779         return 0;
4780     mgp = &SvMAGIC(sv);
4781     for (mg = *mgp; mg; mg = *mgp) {
4782         if (mg->mg_type == type) {
4783             MGVTBL* vtbl = mg->mg_virtual;
4784             *mgp = mg->mg_moremagic;
4785             if (vtbl && vtbl->svt_free)
4786                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4787             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4788                 if (mg->mg_len > 0)
4789                     Safefree(mg->mg_ptr);
4790                 else if (mg->mg_len == HEf_SVKEY)
4791                     SvREFCNT_dec((SV*)mg->mg_ptr);
4792                 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4793                     Safefree(mg->mg_ptr);
4794             }
4795             if (mg->mg_flags & MGf_REFCOUNTED)
4796                 SvREFCNT_dec(mg->mg_obj);
4797             Safefree(mg);
4798         }
4799         else
4800             mgp = &mg->mg_moremagic;
4801     }
4802     if (!SvMAGIC(sv)) {
4803         SvMAGICAL_off(sv);
4804        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4805     }
4806
4807     return 0;
4808 }
4809
4810 /*
4811 =for apidoc sv_rvweaken
4812
4813 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4814 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4815 push a back-reference to this RV onto the array of backreferences
4816 associated with that magic.
4817
4818 =cut
4819 */
4820
4821 SV *
4822 Perl_sv_rvweaken(pTHX_ SV *sv)
4823 {
4824     SV *tsv;
4825     if (!SvOK(sv))  /* let undefs pass */
4826         return sv;
4827     if (!SvROK(sv))
4828         Perl_croak(aTHX_ "Can't weaken a nonreference");
4829     else if (SvWEAKREF(sv)) {
4830         if (ckWARN(WARN_MISC))
4831             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4832         return sv;
4833     }
4834     tsv = SvRV(sv);
4835     sv_add_backref(tsv, sv);
4836     SvWEAKREF_on(sv);
4837     SvREFCNT_dec(tsv);
4838     return sv;
4839 }
4840
4841 /* Give tsv backref magic if it hasn't already got it, then push a
4842  * back-reference to sv onto the array associated with the backref magic.
4843  */
4844
4845 STATIC void
4846 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4847 {
4848     AV *av;
4849     MAGIC *mg;
4850     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4851         av = (AV*)mg->mg_obj;
4852     else {
4853         av = newAV();
4854         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4855         SvREFCNT_dec(av);           /* for sv_magic */
4856     }
4857     if (AvFILLp(av) >= AvMAX(av)) {
4858         SV **svp = AvARRAY(av);
4859         I32 i = AvFILLp(av);
4860         while (i >= 0) {
4861             if (svp[i] == &PL_sv_undef) {
4862                 svp[i] = sv;        /* reuse the slot */
4863                 return;
4864             }
4865             i--;
4866         }
4867         av_extend(av, AvFILLp(av)+1);
4868     }
4869     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4870 }
4871
4872 /* delete a back-reference to ourselves from the backref magic associated
4873  * with the SV we point to.
4874  */
4875
4876 STATIC void
4877 S_sv_del_backref(pTHX_ SV *sv)
4878 {
4879     AV *av;
4880     SV **svp;
4881     I32 i;
4882     SV *tsv = SvRV(sv);
4883     MAGIC *mg = NULL;
4884     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4885         Perl_croak(aTHX_ "panic: del_backref");
4886     av = (AV *)mg->mg_obj;
4887     svp = AvARRAY(av);
4888     i = AvFILLp(av);
4889     while (i >= 0) {
4890         if (svp[i] == sv) {
4891             svp[i] = &PL_sv_undef; /* XXX */
4892         }
4893         i--;
4894     }
4895 }
4896
4897 /*
4898 =for apidoc sv_insert
4899
4900 Inserts a string at the specified offset/length within the SV. Similar to
4901 the Perl substr() function.
4902
4903 =cut
4904 */
4905
4906 void
4907 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4908 {
4909     register char *big;
4910     register char *mid;
4911     register char *midend;
4912     register char *bigend;
4913     register I32 i;
4914     STRLEN curlen;
4915
4916
4917     if (!bigstr)
4918         Perl_croak(aTHX_ "Can't modify non-existent substring");
4919     SvPV_force(bigstr, curlen);
4920     (void)SvPOK_only_UTF8(bigstr);
4921     if (offset + len > curlen) {
4922         SvGROW(bigstr, offset+len+1);
4923         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4924         SvCUR_set(bigstr, offset+len);
4925     }
4926
4927     SvTAINT(bigstr);
4928     i = littlelen - len;
4929     if (i > 0) {                        /* string might grow */
4930         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4931         mid = big + offset + len;
4932         midend = bigend = big + SvCUR(bigstr);
4933         bigend += i;
4934         *bigend = '\0';
4935         while (midend > mid)            /* shove everything down */
4936             *--bigend = *--midend;
4937         Move(little,big+offset,littlelen,char);
4938         SvCUR(bigstr) += i;
4939         SvSETMAGIC(bigstr);
4940         return;
4941     }
4942     else if (i == 0) {
4943         Move(little,SvPVX(bigstr)+offset,len,char);
4944         SvSETMAGIC(bigstr);
4945         return;
4946     }
4947
4948     big = SvPVX(bigstr);
4949     mid = big + offset;
4950     midend = mid + len;
4951     bigend = big + SvCUR(bigstr);
4952
4953     if (midend > bigend)
4954         Perl_croak(aTHX_ "panic: sv_insert");
4955
4956     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4957         if (littlelen) {
4958             Move(little, mid, littlelen,char);
4959             mid += littlelen;
4960         }
4961         i = bigend - midend;
4962         if (i > 0) {
4963             Move(midend, mid, i,char);
4964             mid += i;
4965         }
4966         *mid = '\0';
4967         SvCUR_set(bigstr, mid - big);
4968     }
4969     /*SUPPRESS 560*/
4970     else if ((i = mid - big)) { /* faster from front */
4971         midend -= littlelen;
4972         mid = midend;
4973         sv_chop(bigstr,midend-i);
4974         big += i;
4975         while (i--)
4976             *--midend = *--big;
4977         if (littlelen)
4978             Move(little, mid, littlelen,char);
4979     }
4980     else if (littlelen) {
4981         midend -= littlelen;
4982         sv_chop(bigstr,midend);
4983         Move(little,midend,littlelen,char);
4984     }
4985     else {
4986         sv_chop(bigstr,midend);
4987     }
4988     SvSETMAGIC(bigstr);
4989 }
4990
4991 /*
4992 =for apidoc sv_replace
4993
4994 Make the first argument a copy of the second, then delete the original.
4995 The target SV physically takes over ownership of the body of the source SV
4996 and inherits its flags; however, the target keeps any magic it owns,
4997 and any magic in the source is discarded.
4998 Note that this is a rather specialist SV copying operation; most of the
4999 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5000
5001 =cut
5002 */
5003
5004 void
5005 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5006 {
5007     U32 refcnt = SvREFCNT(sv);
5008     SV_CHECK_THINKFIRST(sv);
5009     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5010         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5011     if (SvMAGICAL(sv)) {
5012         if (SvMAGICAL(nsv))
5013             mg_free(nsv);
5014         else
5015             sv_upgrade(nsv, SVt_PVMG);
5016         SvMAGIC(nsv) = SvMAGIC(sv);
5017         SvFLAGS(nsv) |= SvMAGICAL(sv);
5018         SvMAGICAL_off(sv);
5019         SvMAGIC(sv) = 0;
5020     }
5021     SvREFCNT(sv) = 0;
5022     sv_clear(sv);
5023     assert(!SvREFCNT(sv));
5024     StructCopy(nsv,sv,SV);
5025     SvREFCNT(sv) = refcnt;
5026     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5027     del_SV(nsv);
5028 }
5029
5030 /*
5031 =for apidoc sv_clear
5032
5033 Clear an SV: call any destructors, free up any memory used by the body,
5034 and free the body itself. The SV's head is I<not> freed, although
5035 its type is set to all 1's so that it won't inadvertently be assumed
5036 to be live during global destruction etc.
5037 This function should only be called when REFCNT is zero. Most of the time
5038 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5039 instead.
5040
5041 =cut
5042 */
5043
5044 void
5045 Perl_sv_clear(pTHX_ register SV *sv)
5046 {
5047     HV* stash;
5048     assert(sv);
5049     assert(SvREFCNT(sv) == 0);
5050
5051     if (SvOBJECT(sv)) {
5052         if (PL_defstash) {              /* Still have a symbol table? */
5053             dSP;
5054             CV* destructor;
5055
5056
5057
5058             do {
5059                 stash = SvSTASH(sv);
5060                 destructor = StashHANDLER(stash,DESTROY);
5061                 if (destructor) {
5062                     SV* tmpref = newRV(sv);
5063                     SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
5064                     ENTER;
5065                     PUSHSTACKi(PERLSI_DESTROY);
5066                     EXTEND(SP, 2);
5067                     PUSHMARK(SP);
5068                     PUSHs(tmpref);
5069                     PUTBACK;
5070                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5071
5072
5073                     POPSTACK;
5074                     SPAGAIN;
5075                     LEAVE;
5076                     if(SvREFCNT(tmpref) < 2) {
5077                         /* tmpref is not kept alive! */
5078                         SvREFCNT(sv)--;
5079                         SvRV(tmpref) = 0;
5080                         SvROK_off(tmpref);
5081                     }
5082                     SvREFCNT_dec(tmpref);
5083                 }
5084             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5085
5086
5087             if (SvREFCNT(sv)) {
5088                 if (PL_in_clean_objs)
5089                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5090                           HvNAME(stash));
5091                 /* DESTROY gave object new lease on life */
5092                 return;
5093             }
5094         }
5095
5096         if (SvOBJECT(sv)) {
5097             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
5098             SvOBJECT_off(sv);   /* Curse the object. */
5099             if (SvTYPE(sv) != SVt_PVIO)
5100                 --PL_sv_objcount;       /* XXX Might want something more general */
5101         }
5102     }
5103     if (SvTYPE(sv) >= SVt_PVMG) {
5104         if (SvMAGIC(sv))
5105             mg_free(sv);
5106         if (SvFLAGS(sv) & SVpad_TYPED)
5107             SvREFCNT_dec(SvSTASH(sv));
5108     }
5109     stash = NULL;
5110     switch (SvTYPE(sv)) {
5111     case SVt_PVIO:
5112         if (IoIFP(sv) &&
5113             IoIFP(sv) != PerlIO_stdin() &&
5114             IoIFP(sv) != PerlIO_stdout() &&
5115             IoIFP(sv) != PerlIO_stderr())
5116         {
5117             io_close((IO*)sv, FALSE);
5118         }
5119         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5120             PerlDir_close(IoDIRP(sv));
5121         IoDIRP(sv) = (DIR*)NULL;
5122         Safefree(IoTOP_NAME(sv));
5123         Safefree(IoFMT_NAME(sv));
5124         Safefree(IoBOTTOM_NAME(sv));
5125         /* FALL THROUGH */
5126     case SVt_PVBM:
5127         goto freescalar;
5128     case SVt_PVCV:
5129     case SVt_PVFM:
5130         cv_undef((CV*)sv);
5131         goto freescalar;
5132     case SVt_PVHV:
5133         hv_undef((HV*)sv);
5134         break;
5135     case SVt_PVAV:
5136         av_undef((AV*)sv);
5137         break;
5138     case SVt_PVLV:
5139         if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5140             SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5141             HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5142             PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5143         }
5144         else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
5145             SvREFCNT_dec(LvTARG(sv));
5146         goto freescalar;
5147     case SVt_PVGV:
5148         gp_free((GV*)sv);
5149         Safefree(GvNAME(sv));
5150         /* cannot decrease stash refcount yet, as we might recursively delete
5151            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5152            of stash until current sv is completely gone.
5153            -- JohnPC, 27 Mar 1998 */
5154         stash = GvSTASH(sv);
5155         /* FALL THROUGH */
5156     case SVt_PVMG:
5157     case SVt_PVNV:
5158     case SVt_PVIV:
5159       freescalar:
5160         (void)SvOOK_off(sv);
5161         /* FALL THROUGH */
5162     case SVt_PV:
5163     case SVt_RV:
5164         if (SvROK(sv)) {
5165             if (SvWEAKREF(sv))
5166                 sv_del_backref(sv);
5167             else
5168                 SvREFCNT_dec(SvRV(sv));
5169         }
5170         else if (SvPVX(sv) && SvLEN(sv))
5171             Safefree(SvPVX(sv));
5172         else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5173             unsharepvn(SvPVX(sv),
5174                        SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5175                        SvUVX(sv));
5176             SvFAKE_off(sv);
5177         }
5178         break;
5179 /*
5180     case SVt_NV:
5181     case SVt_IV:
5182     case SVt_NULL:
5183         break;
5184 */
5185     }
5186
5187     switch (SvTYPE(sv)) {
5188     case SVt_NULL:
5189         break;
5190     case SVt_IV:
5191         del_XIV(SvANY(sv));
5192         break;
5193     case SVt_NV:
5194         del_XNV(SvANY(sv));
5195         break;
5196     case SVt_RV:
5197         del_XRV(SvANY(sv));
5198         break;
5199     case SVt_PV:
5200         del_XPV(SvANY(sv));
5201         break;
5202     case SVt_PVIV:
5203         del_XPVIV(SvANY(sv));
5204         break;
5205     case SVt_PVNV:
5206         del_XPVNV(SvANY(sv));
5207         break;
5208     case SVt_PVMG:
5209         del_XPVMG(SvANY(sv));
5210         break;
5211     case SVt_PVLV:
5212         del_XPVLV(SvANY(sv));
5213         break;
5214     case SVt_PVAV:
5215         del_XPVAV(SvANY(sv));
5216         break;
5217     case SVt_PVHV:
5218         del_XPVHV(SvANY(sv));
5219         break;
5220     case SVt_PVCV:
5221         del_XPVCV(SvANY(sv));
5222         break;
5223     case SVt_PVGV:
5224         del_XPVGV(SvANY(sv));
5225         /* code duplication for increased performance. */
5226         SvFLAGS(sv) &= SVf_BREAK;
5227         SvFLAGS(sv) |= SVTYPEMASK;
5228         /* decrease refcount of the stash that owns this GV, if any */
5229         if (stash)
5230             SvREFCNT_dec(stash);
5231         return; /* not break, SvFLAGS reset already happened */
5232     case SVt_PVBM:
5233         del_XPVBM(SvANY(sv));
5234         break;
5235     case SVt_PVFM:
5236         del_XPVFM(SvANY(sv));
5237         break;
5238     case SVt_PVIO:
5239         del_XPVIO(SvANY(sv));
5240         break;
5241     }
5242     SvFLAGS(sv) &= SVf_BREAK;
5243     SvFLAGS(sv) |= SVTYPEMASK;
5244 }
5245
5246 /*
5247 =for apidoc sv_newref
5248
5249 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5250 instead.
5251
5252 =cut
5253 */
5254
5255 SV *
5256 Perl_sv_newref(pTHX_ SV *sv)
5257 {
5258     if (sv)
5259         ATOMIC_INC(SvREFCNT(sv));
5260     return sv;
5261 }
5262
5263 /*
5264 =for apidoc sv_free
5265
5266 Decrement an SV's reference count, and if it drops to zero, call
5267 C<sv_clear> to invoke destructors and free up any memory used by
5268 the body; finally, deallocate the SV's head itself.
5269 Normally called via a wrapper macro C<SvREFCNT_dec>.
5270
5271 =cut
5272 */
5273
5274 void
5275 Perl_sv_free(pTHX_ SV *sv)
5276 {
5277     int refcount_is_zero;
5278
5279     if (!sv)
5280         return;
5281     if (SvREFCNT(sv) == 0) {
5282         if (SvFLAGS(sv) & SVf_BREAK)
5283             /* this SV's refcnt has been artificially decremented to
5284              * trigger cleanup */
5285             return;
5286         if (PL_in_clean_all) /* All is fair */
5287             return;
5288         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5289             /* make sure SvREFCNT(sv)==0 happens very seldom */
5290             SvREFCNT(sv) = (~(U32)0)/2;
5291             return;
5292         }
5293         if (ckWARN_d(WARN_INTERNAL))
5294             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
5295         return;
5296     }
5297     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5298     if (!refcount_is_zero)
5299         return;
5300 #ifdef DEBUGGING
5301     if (SvTEMP(sv)) {
5302         if (ckWARN_d(WARN_DEBUGGING))
5303             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5304                         "Attempt to free temp prematurely: SV 0x%"UVxf,
5305                         PTR2UV(sv));
5306         return;
5307     }
5308 #endif
5309     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5310         /* make sure SvREFCNT(sv)==0 happens very seldom */
5311         SvREFCNT(sv) = (~(U32)0)/2;
5312         return;
5313     }
5314     sv_clear(sv);
5315     if (! SvREFCNT(sv))
5316         del_SV(sv);
5317 }
5318
5319 /*
5320 =for apidoc sv_len
5321
5322 Returns the length of the string in the SV. Handles magic and type
5323 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5324
5325 =cut
5326 */
5327
5328 STRLEN
5329 Perl_sv_len(pTHX_ register SV *sv)
5330 {
5331     STRLEN len;
5332
5333     if (!sv)
5334         return 0;
5335
5336     if (SvGMAGICAL(sv))
5337         len = mg_length(sv);
5338     else
5339         (void)SvPV(sv, len);
5340     return len;
5341 }
5342
5343 /*
5344 =for apidoc sv_len_utf8
5345
5346 Returns the number of characters in the string in an SV, counting wide
5347 UTF8 bytes as a single character. Handles magic and type coercion.
5348
5349 =cut
5350 */
5351
5352 /*
5353  * The length is cached in PERL_UTF8_magic, in the mg_len field.  Also the
5354  * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5355  * (Note that the mg_len is not the length of the mg_ptr field.)
5356  *
5357  */
5358
5359 STRLEN
5360 Perl_sv_len_utf8(pTHX_ register SV *sv)
5361 {
5362     if (!sv)
5363         return 0;
5364
5365     if (SvGMAGICAL(sv))
5366         return mg_length(sv);
5367     else
5368     {
5369         STRLEN len, ulen;
5370         U8 *s = (U8*)SvPV(sv, len);
5371         MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5372
5373         if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0))
5374              ulen = mg->mg_len;
5375         else {
5376              ulen = Perl_utf8_length(aTHX_ s, s + len);
5377              if (!mg && !SvREADONLY(sv)) {
5378                   sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5379                   mg = mg_find(sv, PERL_MAGIC_utf8);
5380                   assert(mg);
5381              }
5382              if (mg)
5383                   mg->mg_len = ulen;
5384         }
5385         return ulen;
5386     }
5387 }
5388
5389 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5390  * a PERL_UTF8_magic.  The mg_ptr is used to store the mapping
5391  * between UTF-8 and byte offsets.  There are two (substr offset and substr
5392  * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5393  * and byte offset) cache positions.
5394  *
5395  * The mg_len field is used by sv_len_utf8(), see its comments.
5396  * Note that the mg_len is not the length of the mg_ptr field.
5397  *
5398  */
5399 STATIC bool
5400 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
5401 {
5402     bool found = FALSE;
5403
5404     if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5405         if (!*mgp) {
5406             sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5407             *mgp = mg_find(sv, PERL_MAGIC_utf8);
5408         }
5409         assert(*mgp);
5410
5411         if ((*mgp)->mg_ptr)
5412             *cachep = (STRLEN *) (*mgp)->mg_ptr;
5413         else {
5414             Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5415             (*mgp)->mg_ptr = (char *) *cachep;
5416         }
5417         assert(*cachep);
5418
5419         (*cachep)[i]   = *offsetp;
5420         (*cachep)[i+1] = s - start;
5421         found = TRUE;
5422     }
5423
5424     return found;
5425 }
5426
5427 /*
5428  * S_utf8_mg_pos() is used to query and update mg_ptr field of
5429  * a PERL_UTF8_magic.  The mg_ptr is used to store the mapping
5430  * between UTF-8 and byte offsets.  See also the comments of
5431  * S_utf8_mg_pos_init().
5432  *
5433  */
5434 STATIC bool
5435 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
5436 {
5437     bool found = FALSE;
5438
5439     if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5440         if (!*mgp)
5441             *mgp = mg_find(sv, PERL_MAGIC_utf8);
5442         if (*mgp && (*mgp)->mg_ptr) {
5443             *cachep = (STRLEN *) (*mgp)->mg_ptr;
5444             if ((*cachep)[i] == (STRLEN)uoff)   /* An exact match. */
5445                  found = TRUE;
5446             else {                      /* We will skip to the right spot. */
5447                  STRLEN forw  = 0;
5448                  STRLEN backw = 0;
5449                  U8* p = NULL;
5450
5451                  /* The assumption is that going backward is half
5452                   * the speed of going forward (that's where the
5453                   * 2 * backw in the below comes from).  (The real
5454                   * figure of course depends on the UTF-8 data.) */
5455
5456                  if ((*cachep)[i] > (STRLEN)uoff) {
5457                       forw  = uoff;
5458                       backw = (*cachep)[i] - (STRLEN)uoff;
5459
5460                       if (forw < 2 * backw)
5461                            p = start;
5462                       else
5463                            p = start + (*cachep)[i+1];
5464                  }
5465                  /* Try this only for the substr offset (i == 0),
5466                   * not for the substr length (i == 2). */
5467                  else if (i == 0) { /* (*cachep)[i] < uoff */
5468                       STRLEN ulen = sv_len_utf8(sv);
5469
5470                       if ((STRLEN)uoff < ulen) {
5471                            forw  = (STRLEN)uoff - (*cachep)[i];
5472                            backw = ulen - (STRLEN)uoff;
5473
5474                            if (forw < 2 * backw)
5475                                 p = start + (*cachep)[i+1];
5476                            else
5477                                 p = send;
5478                       }
5479
5480                       /* If the string is not long enough for uoff,
5481                        * we could extend it, but not at this low a level. */
5482                  }
5483
5484                  if (p) {
5485                       if (forw < 2 * backw) {
5486                            while (forw--)
5487                                 p += UTF8SKIP(p);
5488                       }
5489                       else {
5490                            while (backw--) {
5491                                 p--;
5492                                 while (UTF8_IS_CONTINUATION(*p))
5493                                      p--;
5494                            }
5495                       }
5496
5497                       /* Update the cache. */
5498                       (*cachep)[i]   = (STRLEN)uoff;
5499                       (*cachep)[i+1] = p - start;
5500
5501                       found = TRUE;
5502                  }
5503             }
5504             if (found) {        /* Setup the return values. */
5505                  *offsetp = (*cachep)[i+1];
5506                  *sp = start + *offsetp;
5507                  if (*sp >= send) {
5508                       *sp = send;
5509                       *offsetp = send - start;
5510                  }
5511                  else if (*sp < start) {
5512                       *sp = start;
5513                       *offsetp = 0;
5514                  }
5515             }
5516         }
5517     }
5518
5519     return found;
5520 }
5521
5522 /*
5523 =for apidoc sv_pos_u2b
5524
5525 Converts the value pointed to by offsetp from a count of UTF8 chars from
5526 the start of the string, to a count of the equivalent number of bytes; if
5527 lenp is non-zero, it does the same to lenp, but this time starting from
5528 the offset, rather than from the start of the string. Handles magic and
5529 type coercion.
5530
5531 =cut
5532 */
5533
5534 /*
5535  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5536  * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5537  * byte offsets.  See also the comments of S_utf8_mg_pos().
5538  *
5539  */
5540
5541 void
5542 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5543 {
5544     U8 *start;
5545     U8 *s;
5546     STRLEN len;
5547     STRLEN *cache = 0;
5548     STRLEN boffset = 0;
5549
5550     if (!sv)
5551         return;
5552
5553     start = s = (U8*)SvPV(sv, len);
5554     if (len) {
5555          I32 uoffset = *offsetp;
5556          U8 *send = s + len;
5557          MAGIC *mg = 0;
5558          bool found = FALSE;
5559
5560          if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5561              found = TRUE;
5562          if (!found && uoffset > 0) {
5563               while (s < send && uoffset--)
5564                    s += UTF8SKIP(s);
5565               if (s >= send)
5566                    s = send;
5567               if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
5568                   boffset = cache[1];
5569               *offsetp = s - start;
5570          }
5571          if (lenp) {
5572               found = FALSE;
5573               start = s;
5574               if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
5575                   *lenp -= boffset;
5576                   found = TRUE;
5577               }
5578               if (!found && *lenp > 0) {
5579                    I32 ulen = *lenp;
5580                    if (ulen > 0)
5581                         while (s < send && ulen--)
5582                              s += UTF8SKIP(s);
5583                    if (s >= send)
5584                         s = send;
5585                    if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
5586                         cache[2] += *offsetp;
5587               }
5588               *lenp = s - start;
5589          }
5590     }
5591     else {
5592          *offsetp = 0;
5593          if (lenp)
5594               *lenp = 0;
5595     }
5596     return;
5597 }
5598
5599 /*
5600 =for apidoc sv_pos_b2u
5601
5602 Converts the value pointed to by offsetp from a count of bytes from the
5603 start of the string, to a count of the equivalent number of UTF8 chars.
5604 Handles magic and type coercion.
5605
5606 =cut
5607 */
5608
5609 /*
5610  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5611  * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5612  * byte offsets.  See also the comments of S_utf8_mg_pos().
5613  *
5614  */
5615
5616 void
5617 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5618 {
5619     U8* s;
5620     STRLEN len;
5621
5622     if (!sv)
5623         return;
5624
5625     s = (U8*)SvPV(sv, len);
5626     if ((I32)len < *offsetp)
5627         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5628     else {
5629          U8* send = s + *offsetp;
5630          MAGIC* mg = NULL;
5631          STRLEN *cache = NULL;
5632
5633          len = 0;
5634
5635          if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5636               mg = mg_find(sv, PERL_MAGIC_utf8);
5637               if (mg && mg->mg_ptr) {
5638                    cache = (STRLEN *) mg->mg_ptr;
5639                    if (cache[1] == (STRLEN)*offsetp) {
5640                         /* An exact match. */
5641                         *offsetp = cache[0];
5642
5643                         return;
5644                    }
5645                    else if (cache[1] < (STRLEN)*offsetp) {
5646                         /* We already know part of the way. */
5647                         len = cache[0];
5648                         s  += cache[1];
5649                         /* Let the below loop do the rest. */
5650                    }
5651                    else { /* cache[1] > *offsetp */
5652                         /* We already know all of the way, now we may
5653                          * be able to walk back.  The same assumption
5654                          * is made as in S_utf8_mg_pos(), namely that
5655                          * walking backward is twice slower than
5656                          * walking forward. */
5657                         STRLEN forw  = *offsetp;
5658                         STRLEN backw = cache[1] - *offsetp;
5659
5660                         if (!(forw < 2 * backw)) {
5661                              U8 *p = s + cache[1];
5662                              STRLEN ubackw = 0;
5663
5664                              cache[1] -= backw;
5665
5666                              while (backw--) {
5667                             p--;
5668                             while (UTF8_IS_CONTINUATION(*p)) {
5669                                 p--;
5670                                 backw--;
5671                             }
5672                             ubackw++;
5673                         }
5674
5675                         cache[0] -= ubackw;
5676                         *offsetp = cache[0];
5677                         return;
5678                     }
5679                 }
5680             }
5681          }
5682
5683          while (s < send) {
5684               STRLEN n = 1;
5685
5686               /* Call utf8n_to_uvchr() to validate the sequence
5687                * (unless a simple non-UTF character) */
5688               if (!UTF8_IS_INVARIANT(*s))
5689                    utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5690               if (n > 0) {
5691                    s += n;
5692                    len++;
5693               }
5694               else
5695                    break;
5696          }
5697
5698          if (!SvREADONLY(sv)) {
5699               if (!mg) {
5700                    sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5701                    mg = mg_find(sv, PERL_MAGIC_utf8);
5702               }
5703               assert(mg);
5704
5705               if (!mg->mg_ptr) {
5706                    Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5707                    mg->mg_ptr = (char *) cache;
5708               }
5709               assert(cache);
5710
5711               cache[0] = len;
5712               cache[1] = *offsetp;
5713          }
5714
5715          *offsetp = len;
5716     }
5717
5718     return;
5719 }
5720
5721 /*
5722 =for apidoc sv_eq
5723
5724 Returns a boolean indicating whether the strings in the two SVs are
5725 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5726 coerce its args to strings if necessary.
5727
5728 =cut
5729 */
5730
5731 I32
5732 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5733 {
5734     char *pv1;
5735     STRLEN cur1;
5736     char *pv2;
5737     STRLEN cur2;
5738     I32  eq     = 0;
5739     char *tpv   = Nullch;
5740     SV* svrecode = Nullsv;
5741
5742     if (!sv1) {
5743         pv1 = "";
5744         cur1 = 0;
5745     }
5746     else
5747         pv1 = SvPV(sv1, cur1);
5748
5749     if (!sv2){
5750         pv2 = "";
5751         cur2 = 0;
5752     }
5753     else
5754         pv2 = SvPV(sv2, cur2);
5755
5756     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5757         /* Differing utf8ness.
5758          * Do not UTF8size the comparands as a side-effect. */
5759          if (PL_encoding) {
5760               if (SvUTF8(sv1)) {
5761                    svrecode = newSVpvn(pv2, cur2);
5762                    sv_recode_to_utf8(svrecode, PL_encoding);
5763                    pv2 = SvPV(svrecode, cur2);
5764               }
5765               else {
5766                    svrecode = newSVpvn(pv1, cur1);
5767                    sv_recode_to_utf8(svrecode, PL_encoding);
5768                    pv1 = SvPV(svrecode, cur1);
5769               }
5770               /* Now both are in UTF-8. */
5771               if (cur1 != cur2)
5772                    return FALSE;
5773          }
5774          else {
5775               bool is_utf8 = TRUE;
5776
5777               if (SvUTF8(sv1)) {
5778                    /* sv1 is the UTF-8 one,
5779                     * if is equal it must be downgrade-able */
5780                    char *pv = (char*)bytes_from_utf8((U8*)pv1,
5781                                                      &cur1, &is_utf8);
5782                    if (pv != pv1)
5783                         pv1 = tpv = pv;
5784               }
5785               else {
5786                    /* sv2 is the UTF-8 one,
5787                     * if is equal it must be downgrade-able */
5788                    char *pv = (char *)bytes_from_utf8((U8*)pv2,
5789                                                       &cur2, &is_utf8);
5790                    if (pv != pv2)
5791                         pv2 = tpv = pv;
5792               }
5793               if (is_utf8) {
5794                    /* Downgrade not possible - cannot be eq */
5795                    return FALSE;
5796               }
5797          }
5798     }
5799
5800     if (cur1 == cur2)
5801         eq = memEQ(pv1, pv2, cur1);
5802
5803     if (svrecode)
5804          SvREFCNT_dec(svrecode);
5805
5806     if (tpv)
5807         Safefree(tpv);
5808
5809     return eq;
5810 }
5811
5812 /*
5813 =for apidoc sv_cmp
5814
5815 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
5816 string in C<sv1> is less than, equal to, or greater than the string in
5817 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5818 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
5819
5820 =cut
5821 */
5822
5823 I32
5824 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5825 {
5826     STRLEN cur1, cur2;
5827     char *pv1, *pv2, *tpv = Nullch;
5828     I32  cmp;
5829     SV *svrecode = Nullsv;
5830
5831     if (!sv1) {
5832         pv1 = "";
5833         cur1 = 0;
5834     }
5835     else
5836         pv1 = SvPV(sv1, cur1);
5837
5838     if (!sv2) {
5839         pv2 = "";
5840         cur2 = 0;
5841     }
5842     else
5843         pv2 = SvPV(sv2, cur2);
5844
5845     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5846         /* Differing utf8ness.
5847          * Do not UTF8size the comparands as a side-effect. */
5848         if (SvUTF8(sv1)) {
5849             if (PL_encoding) {
5850                  svrecode = newSVpvn(pv2, cur2);
5851                  sv_recode_to_utf8(svrecode, PL_encoding);
5852                  pv2 = SvPV(svrecode, cur2);
5853             }
5854             else {
5855                  pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5856             }
5857         }
5858         else {
5859             if (PL_encoding) {
5860                  svrecode = newSVpvn(pv1, cur1);
5861                  sv_recode_to_utf8(svrecode, PL_encoding);
5862                  pv1 = SvPV(svrecode, cur1);
5863             }
5864             else {
5865                  pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5866             }
5867         }
5868     }
5869
5870     if (!cur1) {
5871         cmp = cur2 ? -1 : 0;
5872     } else if (!cur2) {
5873         cmp = 1;
5874     } else {
5875         I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5876
5877         if (retval) {
5878             cmp = retval < 0 ? -1 : 1;
5879         } else if (cur1 == cur2) {
5880             cmp = 0;
5881         } else {
5882             cmp = cur1 < cur2 ? -1 : 1;
5883         }
5884     }
5885
5886     if (svrecode)
5887          SvREFCNT_dec(svrecode);
5888
5889     if (tpv)
5890         Safefree(tpv);
5891
5892     return cmp;
5893 }
5894
5895 /*
5896 =for apidoc sv_cmp_locale
5897
5898 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5899 'use bytes' aware, handles get magic, and will coerce its args to strings
5900 if necessary.  See also C<sv_cmp_locale>.  See also C<sv_cmp>.
5901
5902 =cut
5903 */
5904
5905 I32
5906 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5907 {
5908 #ifdef USE_LOCALE_COLLATE
5909
5910     char *pv1, *pv2;
5911     STRLEN len1, len2;
5912     I32 retval;
5913
5914     if (PL_collation_standard)
5915         goto raw_compare;
5916
5917     len1 = 0;
5918     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5919     len2 = 0;
5920     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5921
5922     if (!pv1 || !len1) {
5923         if (pv2 && len2)
5924             return -1;
5925         else
5926             goto raw_compare;
5927     }
5928     else {
5929         if (!pv2 || !len2)
5930             return 1;
5931     }
5932
5933     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5934
5935     if (retval)
5936         return retval < 0 ? -1 : 1;
5937
5938     /*
5939      * When the result of collation is equality, that doesn't mean
5940      * that there are no differences -- some locales exclude some
5941      * characters from consideration.  So to avoid false equalities,
5942      * we use the raw string as a tiebreaker.
5943      */
5944
5945   raw_compare:
5946     /* FALL THROUGH */
5947
5948 #endif /* USE_LOCALE_COLLATE */
5949
5950     return sv_cmp(sv1, sv2);
5951 }
5952
5953
5954 #ifdef USE_LOCALE_COLLATE
5955
5956 /*
5957 =for apidoc sv_collxfrm
5958
5959 Add Collate Transform magic to an SV if it doesn't already have it.
5960
5961 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5962 scalar data of the variable, but transformed to such a format that a normal
5963 memory comparison can be used to compare the data according to the locale
5964 settings.
5965
5966 =cut
5967 */
5968
5969 char *
5970 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5971 {
5972     MAGIC *mg;
5973
5974     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5975     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5976         char *s, *xf;
5977         STRLEN len, xlen;
5978
5979         if (mg)
5980             Safefree(mg->mg_ptr);
5981         s = SvPV(sv, len);
5982         if ((xf = mem_collxfrm(s, len, &xlen))) {
5983             if (SvREADONLY(sv)) {
5984                 SAVEFREEPV(xf);
5985                 *nxp = xlen;
5986                 return xf + sizeof(PL_collation_ix);
5987             }
5988             if (! mg) {
5989                 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5990                 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5991                 assert(mg);
5992             }
5993             mg->mg_ptr = xf;
5994             mg->mg_len = xlen;
5995         }
5996         else {
5997             if (mg) {
5998                 mg->mg_ptr = NULL;
5999                 mg->mg_len = -1;
6000             }
6001         }
6002     }
6003     if (mg && mg->mg_ptr) {
6004         *nxp = mg->mg_len;
6005         return mg->mg_ptr + sizeof(PL_collation_ix);
6006     }
6007     else {
6008         *nxp = 0;
6009         return NULL;
6010     }
6011 }
6012
6013 #endif /* USE_LOCALE_COLLATE */
6014
6015 /*
6016 =for apidoc sv_gets
6017
6018 Get a line from the filehandle and store it into the SV, optionally
6019 appending to the currently-stored string.
6020
6021 =cut
6022 */
6023
6024 char *
6025 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6026 {
6027     char *rsptr;
6028     STRLEN rslen;
6029     register STDCHAR rslast;
6030     register STDCHAR *bp;
6031     register I32 cnt;
6032     I32 i = 0;
6033     I32 rspara = 0;
6034     I32 recsize;
6035
6036     SV_CHECK_THINKFIRST(sv);
6037     (void)SvUPGRADE(sv, SVt_PV);
6038
6039     SvSCREAM_off(sv);
6040
6041     if (append) {
6042         if (PerlIO_isutf8(fp)) {
6043             if (!SvUTF8(sv)) {
6044                 sv_utf8_upgrade_nomg(sv);
6045                 sv_pos_u2b(sv,&append,0);
6046             }
6047         } else if (SvUTF8(sv)) {
6048             SV *tsv = NEWSV(0,0);
6049             sv_gets(tsv, fp, 0);
6050             sv_utf8_upgrade_nomg(tsv);
6051             SvCUR_set(sv,append);
6052             sv_catsv(sv,tsv);
6053             sv_free(tsv);
6054             goto return_string_or_null;
6055         }
6056     }
6057
6058     SvPOK_only(sv);
6059     if (PerlIO_isutf8(fp))
6060         SvUTF8_on(sv);
6061
6062     if (PL_curcop == &PL_compiling) {
6063         /* we always read code in line mode */
6064         rsptr = "\n";
6065         rslen = 1;
6066     }
6067     else if (RsSNARF(PL_rs)) {
6068         /* If it is a regular disk file use size from stat() as estimate
6069            of amount we are going to read - may result in malloc-ing
6070            more memory than we realy need if layers bellow reduce
6071            size we read (e.g. CRLF or a gzip layer)
6072          */
6073         Stat_t st;
6074         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
6075             Off_t offset = PerlIO_tell(fp);
6076             if (offset != (Off_t) -1 && st.st_size + append > offset) {
6077                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6078             }
6079         }
6080         rsptr = NULL;
6081         rslen = 0;
6082     }
6083     else if (RsRECORD(PL_rs)) {
6084       I32 bytesread;
6085       char *buffer;
6086
6087       /* Grab the size of the record we're getting */
6088       recsize = SvIV(SvRV(PL_rs));
6089       buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6090       /* Go yank in */
6091 #ifdef VMS
6092       /* VMS wants read instead of fread, because fread doesn't respect */
6093       /* RMS record boundaries. This is not necessarily a good thing to be */
6094       /* doing, but we've got no other real choice - except avoid stdio
6095          as implementation - perhaps write a :vms layer ?
6096        */
6097       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6098 #else
6099       bytesread = PerlIO_read(fp, buffer, recsize);
6100 #endif
6101       if (bytesread < 0)
6102           bytesread = 0;
6103       SvCUR_set(sv, bytesread += append);
6104       buffer[bytesread] = '\0';
6105       goto return_string_or_null;
6106     }
6107     else if (RsPARA(PL_rs)) {
6108         rsptr = "\n\n";
6109         rslen = 2;
6110         rspara = 1;
6111     }
6112     else {
6113         /* Get $/ i.e. PL_rs into same encoding as stream wants */
6114         if (PerlIO_isutf8(fp)) {
6115             rsptr = SvPVutf8(PL_rs, rslen);
6116         }
6117         else {
6118             if (SvUTF8(PL_rs)) {
6119                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6120                     Perl_croak(aTHX_ "Wide character in $/");
6121                 }
6122             }
6123             rsptr = SvPV(PL_rs, rslen);
6124         }
6125     }
6126
6127     rslast = rslen ? rsptr[rslen - 1] : '\0';
6128
6129     if (rspara) {               /* have to do this both before and after */
6130         do {                    /* to make sure file boundaries work right */
6131             if (PerlIO_eof(fp))
6132                 return 0;
6133             i = PerlIO_getc(fp);
6134             if (i != '\n') {
6135                 if (i == -1)
6136                     return 0;
6137                 PerlIO_ungetc(fp,i);
6138                 break;
6139             }
6140         } while (i != EOF);
6141     }
6142
6143     /* See if we know enough about I/O mechanism to cheat it ! */
6144
6145     /* This used to be #ifdef test - it is made run-time test for ease
6146        of abstracting out stdio interface. One call should be cheap
6147        enough here - and may even be a macro allowing compile
6148        time optimization.
6149      */
6150
6151     if (PerlIO_fast_gets(fp)) {
6152
6153     /*
6154      * We're going to steal some values from the stdio struct
6155      * and put EVERYTHING in the innermost loop into registers.
6156      */
6157     register STDCHAR *ptr;
6158     STRLEN bpx;
6159     I32 shortbuffered;
6160
6161 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6162     /* An ungetc()d char is handled separately from the regular
6163      * buffer, so we getc() it back out and stuff it in the buffer.
6164      */
6165     i = PerlIO_getc(fp);
6166     if (i == EOF) return 0;
6167     *(--((*fp)->_ptr)) = (unsigned char) i;
6168     (*fp)->_cnt++;
6169 #endif
6170
6171     /* Here is some breathtakingly efficient cheating */
6172
6173     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
6174     /* make sure we have the room */
6175     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6176         /* Not room for all of it
6177            if we are looking for a separator and room for some
6178          */
6179         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6180             /* just process what we have room for */
6181             shortbuffered = cnt - SvLEN(sv) + append + 1;
6182             cnt -= shortbuffered;
6183         }
6184         else {
6185             shortbuffered = 0;
6186             /* remember that cnt can be negative */
6187             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6188         }
6189     }
6190     else
6191         shortbuffered = 0;
6192     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
6193     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6194     DEBUG_P(PerlIO_printf(Perl_debug_log,
6195         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6196     DEBUG_P(PerlIO_printf(Perl_debug_log,
6197         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6198                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6199                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6200     for (;;) {
6201       screamer:
6202         if (cnt > 0) {
6203             if (rslen) {
6204                 while (cnt > 0) {                    /* this     |  eat */
6205                     cnt--;
6206                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
6207                         goto thats_all_folks;        /* screams  |  sed :-) */
6208                 }
6209             }
6210             else {
6211                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
6212                 bp += cnt;                           /* screams  |  dust */
6213                 ptr += cnt;                          /* louder   |  sed :-) */
6214                 cnt = 0;
6215             }
6216         }
6217
6218         if (shortbuffered) {            /* oh well, must extend */
6219             cnt = shortbuffered;
6220             shortbuffered = 0;
6221             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6222             SvCUR_set(sv, bpx);
6223             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6224             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6225             continue;
6226         }
6227
6228         DEBUG_P(PerlIO_printf(Perl_debug_log,
6229                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6230                               PTR2UV(ptr),(long)cnt));
6231         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6232 #if 0
6233         DEBUG_P(PerlIO_printf(Perl_debug_log,
6234             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6235             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6236             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6237 #endif
6238         /* This used to call 'filbuf' in stdio form, but as that behaves like
6239            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6240            another abstraction.  */
6241         i   = PerlIO_getc(fp);          /* get more characters */
6242 #if 0
6243         DEBUG_P(PerlIO_printf(Perl_debug_log,
6244             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6245             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6246             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6247 #endif
6248         cnt = PerlIO_get_cnt(fp);
6249         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
6250         DEBUG_P(PerlIO_printf(Perl_debug_log,
6251             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6252
6253         if (i == EOF)                   /* all done for ever? */
6254             goto thats_really_all_folks;
6255
6256         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6257         SvCUR_set(sv, bpx);
6258         SvGROW(sv, bpx + cnt + 2);
6259         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6260
6261         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
6262
6263         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
6264             goto thats_all_folks;
6265     }
6266
6267 thats_all_folks:
6268     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
6269           memNE((char*)bp - rslen, rsptr, rslen))
6270         goto screamer;                          /* go back to the fray */
6271 thats_really_all_folks:
6272     if (shortbuffered)
6273         cnt += shortbuffered;
6274         DEBUG_P(PerlIO_printf(Perl_debug_log,
6275             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6276     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
6277     DEBUG_P(PerlIO_printf(Perl_debug_log,
6278         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6279         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6280         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6281     *bp = '\0';
6282     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
6283     DEBUG_P(PerlIO_printf(Perl_debug_log,
6284         "Screamer: done, len=%ld, string=|%.*s|\n",
6285         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
6286     }
6287    else
6288     {
6289 #ifndef EPOC
6290        /*The big, slow, and stupid way */
6291         STDCHAR buf[8192];
6292 #else
6293         /* Need to work around EPOC SDK features          */
6294         /* On WINS: MS VC5 generates calls to _chkstk,    */
6295         /* if a `large' stack frame is allocated          */
6296         /* gcc on MARM does not generate calls like these */
6297         STDCHAR buf[1024];
6298 #endif
6299
6300 screamer2:
6301         if (rslen) {
6302             register STDCHAR *bpe = buf + sizeof(buf);
6303             bp = buf;
6304             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6305                 ; /* keep reading */
6306             cnt = bp - buf;
6307         }
6308         else {
6309             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6310             /* Accomodate broken VAXC compiler, which applies U8 cast to
6311              * both args of ?: operator, causing EOF to change into 255
6312              */
6313             if (cnt > 0)
6314                  i = (U8)buf[cnt - 1];
6315             else
6316                  i = EOF;
6317         }
6318
6319         if (cnt < 0)
6320             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
6321         if (append)
6322              sv_catpvn(sv, (char *) buf, cnt);
6323         else
6324              sv_setpvn(sv, (char *) buf, cnt);
6325
6326         if (i != EOF &&                 /* joy */
6327             (!rslen ||
6328              SvCUR(sv) < rslen ||
6329              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6330         {
6331             append = -1;
6332             /*
6333              * If we're reading from a TTY and we get a short read,
6334              * indicating that the user hit his EOF character, we need
6335              * to notice it now, because if we try to read from the TTY
6336              * again, the EOF condition will disappear.
6337              *
6338              * The comparison of cnt to sizeof(buf) is an optimization
6339              * that prevents unnecessary calls to feof().
6340              *
6341              * - jik 9/25/96
6342              */
6343             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6344                 goto screamer2;
6345         }
6346     }
6347
6348     if (rspara) {               /* have to do this both before and after */
6349         while (i != EOF) {      /* to make sure file boundaries work right */
6350             i = PerlIO_getc(fp);
6351             if (i != '\n') {
6352                 PerlIO_ungetc(fp,i);
6353                 break;
6354             }
6355         }
6356     }
6357
6358 return_string_or_null:
6359     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6360 }
6361
6362 /*
6363 =for apidoc sv_inc
6364
6365 Auto-increment of the value in the SV, doing string to numeric conversion
6366 if necessary. Handles 'get' magic.
6367
6368 =cut
6369 */
6370
6371 void
6372 Perl_sv_inc(pTHX_ register SV *sv)
6373 {
6374     register char *d;
6375     int flags;
6376
6377     if (!sv)
6378         return;
6379     if (SvGMAGICAL(sv))
6380         mg_get(sv);
6381     if (SvTHINKFIRST(sv)) {
6382         if (SvREADONLY(sv) && SvFAKE(sv))
6383             sv_force_normal(sv);
6384         if (SvREADONLY(sv)) {
6385             if (PL_curcop != &PL_compiling)
6386                 Perl_croak(aTHX_ PL_no_modify);
6387         }
6388         if (SvROK(sv)) {
6389             IV i;
6390             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6391                 return;
6392             i = PTR2IV(SvRV(sv));
6393             sv_unref(sv);
6394             sv_setiv(sv, i);
6395         }
6396     }
6397     flags = SvFLAGS(sv);
6398     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6399         /* It's (privately or publicly) a float, but not tested as an
6400            integer, so test it to see. */
6401         (void) SvIV(sv);
6402         flags = SvFLAGS(sv);
6403     }
6404     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6405         /* It's publicly an integer, or privately an integer-not-float */
6406 #ifdef PERL_PRESERVE_IVUV
6407       oops_its_int:
6408 #endif
6409         if (SvIsUV(sv)) {
6410             if (SvUVX(sv) == UV_MAX)
6411                 sv_setnv(sv, UV_MAX_P1);
6412             else
6413                 (void)SvIOK_only_UV(sv);
6414                 ++SvUVX(sv);
6415         } else {
6416             if (SvIVX(sv) == IV_MAX)
6417                 sv_setuv(sv, (UV)IV_MAX + 1);
6418             else {
6419                 (void)SvIOK_only(sv);
6420                 ++SvIVX(sv);
6421             }
6422         }
6423         return;
6424     }
6425     if (flags & SVp_NOK) {
6426         (void)SvNOK_only(sv);
6427         SvNVX(sv) += 1.0;
6428         return;
6429     }
6430
6431     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
6432         if ((flags & SVTYPEMASK) < SVt_PVIV)
6433             sv_upgrade(sv, SVt_IV);
6434         (void)SvIOK_only(sv);
6435         SvIVX(sv) = 1;
6436         return;
6437     }
6438     d = SvPVX(sv);
6439     while (isALPHA(*d)) d++;
6440     while (isDIGIT(*d)) d++;
6441     if (*d) {
6442 #ifdef PERL_PRESERVE_IVUV
6443         /* Got to punt this as an integer if needs be, but we don't issue
6444            warnings. Probably ought to make the sv_iv_please() that does
6445            the conversion if possible, and silently.  */
6446         int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6447         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6448             /* Need to try really hard to see if it's an integer.
6449                9.22337203685478e+18 is an integer.
6450                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6451                so $a="9.22337203685478e+18"; $a+0; $a++
6452                needs to be the same as $a="9.22337203685478e+18"; $a++
6453                or we go insane. */
6454
6455             (void) sv_2iv(sv);
6456             if (SvIOK(sv))
6457                 goto oops_its_int;
6458
6459             /* sv_2iv *should* have made this an NV */
6460             if (flags & SVp_NOK) {
6461                 (void)SvNOK_only(sv);
6462                 SvNVX(sv) += 1.0;
6463                 return;
6464             }
6465             /* I don't think we can get here. Maybe I should assert this
6466                And if we do get here I suspect that sv_setnv will croak. NWC
6467                Fall through. */
6468 #if defined(USE_LONG_DOUBLE)
6469             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
6470                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6471 #else
6472             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6473                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6474 #endif
6475         }
6476 #endif /* PERL_PRESERVE_IVUV */
6477         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
6478         return;
6479     }
6480     d--;
6481     while (d >= SvPVX(sv)) {
6482         if (isDIGIT(*d)) {
6483             if (++*d <= '9')
6484                 return;
6485             *(d--) = '0';
6486         }
6487         else {
6488 #ifdef EBCDIC
6489             /* MKS: The original code here died if letters weren't consecutive.
6490              * at least it didn't have to worry about non-C locales.  The
6491              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6492              * arranged in order (although not consecutively) and that only
6493              * [A-Za-z] are accepted by isALPHA in the C locale.
6494              */
6495             if (*d != 'z' && *d != 'Z') {
6496                 do { ++*d; } while (!isALPHA(*d));
6497                 return;
6498             }
6499             *(d--) -= 'z' - 'a';
6500 #else
6501             ++*d;
6502             if (isALPHA(*d))
6503                 return;
6504             *(d--) -= 'z' - 'a' + 1;
6505 #endif
6506         }
6507     }
6508     /* oh,oh, the number grew */
6509     SvGROW(sv, SvCUR(sv) + 2);
6510     SvCUR(sv)++;
6511     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
6512         *d = d[-1];
6513     if (isDIGIT(d[1]))
6514         *d = '1';
6515     else
6516         *d = d[1];
6517 }
6518
6519 /*
6520 =for apidoc sv_dec
6521
6522 Auto-decrement of the value in the SV, doing string to numeric conversion
6523 if necessary. Handles 'get' magic.
6524
6525 =cut
6526 */
6527
6528 void
6529 Perl_sv_dec(pTHX_ register SV *sv)
6530 {
6531     int flags;
6532
6533     if (!sv)
6534         return;
6535     if (SvGMAGICAL(sv))
6536         mg_get(sv);
6537     if (SvTHINKFIRST(sv)) {
6538         if (SvREADONLY(sv) && SvFAKE(sv))
6539             sv_force_normal(sv);
6540         if (SvREADONLY(sv)) {
6541             if (PL_curcop != &PL_compiling)
6542                 Perl_croak(aTHX_ PL_no_modify);
6543         }
6544         if (SvROK(sv)) {
6545             IV i;
6546             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6547                 return;
6548             i = PTR2IV(SvRV(sv));
6549             sv_unref(sv);
6550             sv_setiv(sv, i);
6551         }
6552     }
6553     /* Unlike sv_inc we don't have to worry about string-never-numbers
6554        and keeping them magic. But we mustn't warn on punting */
6555     flags = SvFLAGS(sv);
6556     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6557         /* It's publicly an integer, or privately an integer-not-float */
6558 #ifdef PERL_PRESERVE_IVUV
6559       oops_its_int:
6560 #endif
6561         if (SvIsUV(sv)) {
6562             if (SvUVX(sv) == 0) {
6563                 (void)SvIOK_only(sv);
6564                 SvIVX(sv) = -1;
6565             }
6566             else {
6567                 (void)SvIOK_only_UV(sv);
6568                 --SvUVX(sv);
6569             }
6570         } else {
6571             if (SvIVX(sv) == IV_MIN)
6572                 sv_setnv(sv, (NV)IV_MIN - 1.0);
6573             else {
6574                 (void)SvIOK_only(sv);
6575                 --SvIVX(sv);
6576             }
6577         }
6578         return;
6579     }
6580     if (flags & SVp_NOK) {
6581         SvNVX(sv) -= 1.0;
6582         (void)SvNOK_only(sv);
6583         return;
6584     }
6585     if (!(flags & SVp_POK)) {
6586         if ((flags & SVTYPEMASK) < SVt_PVNV)
6587             sv_upgrade(sv, SVt_NV);
6588         SvNVX(sv) = -1.0;
6589         (void)SvNOK_only(sv);
6590         return;
6591     }
6592 #ifdef PERL_PRESERVE_IVUV
6593     {
6594         int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6595         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6596             /* Need to try really hard to see if it's an integer.
6597                9.22337203685478e+18 is an integer.
6598                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6599                so $a="9.22337203685478e+18"; $a+0; $a--
6600                needs to be the same as $a="9.22337203685478e+18"; $a--
6601                or we go insane. */
6602
6603             (void) sv_2iv(sv);
6604             if (SvIOK(sv))
6605                 goto oops_its_int;
6606
6607             /* sv_2iv *should* have made this an NV */
6608             if (flags & SVp_NOK) {
6609                 (void)SvNOK_only(sv);
6610                 SvNVX(sv) -= 1.0;
6611                 return;
6612             }
6613             /* I don't think we can get here. Maybe I should assert this
6614                And if we do get here I suspect that sv_setnv will croak. NWC
6615                Fall through. */
6616 #if defined(USE_LONG_DOUBLE)
6617             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
6618                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6619 #else
6620             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6621                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6622 #endif
6623         }
6624     }
6625 #endif /* PERL_PRESERVE_IVUV */
6626     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6627 }
6628
6629 /*
6630 =for apidoc sv_mortalcopy
6631
6632 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6633 The new SV is marked as mortal. It will be destroyed "soon", either by an
6634 explicit call to FREETMPS, or by an implicit call at places such as
6635 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
6636
6637 =cut
6638 */
6639
6640 /* Make a string that will exist for the duration of the expression
6641  * evaluation.  Actually, it may have to last longer than that, but
6642  * hopefully we won't free it until it has been assigned to a
6643  * permanent location. */
6644
6645 SV *
6646 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6647 {
6648     register SV *sv;
6649
6650     new_SV(sv);
6651     sv_setsv(sv,oldstr);
6652     EXTEND_MORTAL(1);
6653     PL_tmps_stack[++PL_tmps_ix] = sv;
6654     SvTEMP_on(sv);
6655     return sv;
6656 }
6657
6658 /*
6659 =for apidoc sv_newmortal
6660
6661 Creates a new null SV which is mortal.  The reference count of the SV is
6662 set to 1. It will be destroyed "soon", either by an explicit call to
6663 FREETMPS, or by an implicit call at places such as statement boundaries.
6664 See also C<sv_mortalcopy> and C<sv_2mortal>.
6665
6666 =cut
6667 */
6668
6669 SV *
6670 Perl_sv_newmortal(pTHX)
6671 {
6672     register SV *sv;
6673
6674     new_SV(sv);
6675     SvFLAGS(sv) = SVs_TEMP;
6676     EXTEND_MORTAL(1);
6677     PL_tmps_stack[++PL_tmps_ix] = sv;
6678     return sv;
6679 }
6680
6681 /*
6682 =for apidoc sv_2mortal
6683
6684 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
6685 by an explicit call to FREETMPS, or by an implicit call at places such as
6686 statement boundaries.  See also C<sv_newmortal> and C<sv_mortalcopy>.
6687
6688 =cut
6689 */
6690
6691 SV *
6692 Perl_sv_2mortal(pTHX_ register SV *sv)
6693 {
6694     if (!sv)
6695         return sv;
6696     if (SvREADONLY(sv) && SvIMMORTAL(sv))
6697         return sv;
6698     EXTEND_MORTAL(1);
6699     PL_tmps_stack[++PL_tmps_ix] = sv;
6700     SvTEMP_on(sv);
6701     return sv;
6702 }
6703
6704 /*
6705 =for apidoc newSVpv
6706
6707 Creates a new SV and copies a string into it.  The reference count for the
6708 SV is set to 1.  If C<len> is zero, Perl will compute the length using
6709 strlen().  For efficiency, consider using C<newSVpvn> instead.
6710
6711 =cut
6712 */
6713
6714 SV *
6715 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6716 {
6717     register SV *sv;
6718
6719     new_SV(sv);
6720     if (!len)
6721         len = strlen(s);
6722     sv_setpvn(sv,s,len);
6723     return sv;
6724 }
6725
6726 /*
6727 =for apidoc newSVpvn
6728
6729 Creates a new SV and copies a string into it.  The reference count for the
6730 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
6731 string.  You are responsible for ensuring that the source string is at least
6732 C<len> bytes long.
6733
6734 =cut
6735 */
6736
6737 SV *
6738 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6739 {
6740     register SV *sv;
6741
6742     new_SV(sv);
6743     sv_setpvn(sv,s,len);
6744     return sv;
6745 }
6746
6747 /*
6748 =for apidoc newSVpvn_share
6749
6750 Creates a new SV with its SvPVX pointing to a shared string in the string
6751 table. If the string does not already exist in the table, it is created
6752 first.  Turns on READONLY and FAKE.  The string's hash is stored in the UV
6753 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6754 otherwise the hash is computed.  The idea here is that as the string table
6755 is used for shared hash keys these strings will have SvPVX == HeKEY and
6756 hash lookup will avoid string compare.
6757
6758 =cut
6759 */
6760
6761 SV *
6762 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6763 {
6764     register SV *sv;
6765     bool is_utf8 = FALSE;
6766     if (len < 0) {
6767         STRLEN tmplen = -len;
6768         is_utf8 = TRUE;
6769         /* See the note in hv.c:hv_fetch() --jhi */
6770         src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6771         len = tmplen;
6772     }
6773     if (!hash)
6774         PERL_HASH(hash, src, len);
6775     new_SV(sv);
6776     sv_upgrade(sv, SVt_PVIV);
6777     SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6778     SvCUR(sv) = len;
6779     SvUVX(sv) = hash;
6780     SvLEN(sv) = 0;
6781     SvREADONLY_on(sv);
6782     SvFAKE_on(sv);
6783     SvPOK_on(sv);
6784     if (is_utf8)
6785         SvUTF8_on(sv);
6786     return sv;
6787 }
6788
6789
6790 #if defined(PERL_IMPLICIT_CONTEXT)
6791
6792 /* pTHX_ magic can't cope with varargs, so this is a no-context
6793  * version of the main function, (which may itself be aliased to us).
6794  * Don't access this version directly.
6795  */
6796
6797 SV *
6798 Perl_newSVpvf_nocontext(const char* pat, ...)
6799 {
6800     dTHX;
6801     register SV *sv;
6802     va_list args;
6803     va_start(args, pat);
6804     sv = vnewSVpvf(pat, &args);
6805     va_end(args);
6806     return sv;
6807 }
6808 #endif
6809
6810 /*
6811 =for apidoc newSVpvf
6812
6813 Creates a new SV and initializes it with the string formatted like
6814 C<sprintf>.
6815
6816 =cut
6817 */
6818
6819 SV *
6820 Perl_newSVpvf(pTHX_ const char* pat, ...)
6821 {
6822     register SV *sv;
6823     va_list args;
6824     va_start(args, pat);
6825     sv = vnewSVpvf(pat, &args);
6826     va_end(args);
6827     return sv;
6828 }
6829
6830 /* backend for newSVpvf() and newSVpvf_nocontext() */
6831
6832 SV *
6833 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6834 {
6835     register SV *sv;
6836     new_SV(sv);
6837     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6838     return sv;
6839 }
6840
6841 /*
6842 =for apidoc newSVnv
6843
6844 Creates a new SV and copies a floating point value into it.
6845 The reference count for the SV is set to 1.
6846
6847 =cut
6848 */
6849
6850 SV *
6851 Perl_newSVnv(pTHX_ NV n)
6852 {
6853     register SV *sv;
6854
6855     new_SV(sv);
6856     sv_setnv(sv,n);
6857     return sv;
6858 }
6859
6860 /*
6861 =for apidoc newSViv
6862
6863 Creates a new SV and copies an integer into it.  The reference count for the
6864 SV is set to 1.
6865
6866 =cut
6867 */
6868
6869 SV *
6870 Perl_newSViv(pTHX_ IV i)
6871 {
6872     register SV *sv;
6873
6874     new_SV(sv);
6875     sv_setiv(sv,i);
6876     return sv;
6877 }
6878
6879 /*
6880 =for apidoc newSVuv
6881
6882 Creates a new SV and copies an unsigned integer into it.
6883 The reference count for the SV is set to 1.
6884
6885 =cut
6886 */
6887
6888 SV *
6889 Perl_newSVuv(pTHX_ UV u)
6890 {
6891     register SV *sv;
6892
6893     new_SV(sv);
6894     sv_setuv(sv,u);
6895     return sv;
6896 }
6897
6898 /*
6899 =for apidoc newRV_noinc
6900
6901 Creates an RV wrapper for an SV.  The reference count for the original
6902 SV is B<not> incremented.
6903
6904 =cut
6905 */
6906
6907 SV *
6908 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6909 {
6910     register SV *sv;
6911
6912     new_SV(sv);
6913     sv_upgrade(sv, SVt_RV);
6914     SvTEMP_off(tmpRef);
6915     SvRV(sv) = tmpRef;
6916     SvROK_on(sv);
6917     return sv;
6918 }
6919
6920 /* newRV_inc is the official function name to use now.
6921  * newRV_inc is in fact #defined to newRV in sv.h
6922  */
6923
6924 SV *
6925 Perl_newRV(pTHX_ SV *tmpRef)
6926 {
6927     return newRV_noinc(SvREFCNT_inc(tmpRef));
6928 }
6929
6930 /*
6931 =for apidoc newSVsv
6932
6933 Creates a new SV which is an exact duplicate of the original SV.
6934 (Uses C<sv_setsv>).
6935
6936 =cut
6937 */
6938
6939 SV *
6940 Perl_newSVsv(pTHX_ register SV *old)
6941 {
6942     register SV *sv;
6943
6944     if (!old)
6945         return Nullsv;
6946     if (SvTYPE(old) == SVTYPEMASK) {
6947         if (ckWARN_d(WARN_INTERNAL))
6948             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
6949         return Nullsv;
6950     }
6951     new_SV(sv);
6952     if (SvTEMP(old)) {
6953         SvTEMP_off(old);
6954         sv_setsv(sv,old);
6955         SvTEMP_on(old);
6956     }
6957     else
6958         sv_setsv(sv,old);
6959     return sv;
6960 }
6961
6962 /*
6963 =for apidoc sv_reset
6964
6965 Underlying implementation for the C<reset> Perl function.
6966 Note that the perl-level function is vaguely deprecated.
6967
6968 =cut
6969 */
6970
6971 void
6972 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6973 {
6974     register HE *entry;
6975     register GV *gv;
6976     register SV *sv;
6977     register I32 i;
6978     register PMOP *pm;
6979     register I32 max;
6980     char todo[PERL_UCHAR_MAX+1];
6981
6982     if (!stash)
6983         return;
6984
6985     if (!*s) {          /* reset ?? searches */
6986         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6987             pm->op_pmdynflags &= ~PMdf_USED;
6988         }
6989         return;
6990     }
6991
6992     /* reset variables */
6993
6994     if (!HvARRAY(stash))
6995         return;
6996
6997     Zero(todo, 256, char);
6998     while (*s) {
6999         i = (unsigned char)*s;
7000         if (s[1] == '-') {
7001             s += 2;
7002         }
7003         max = (unsigned char)*s++;
7004         for ( ; i <= max; i++) {
7005             todo[i] = 1;
7006         }
7007         for (i = 0; i <= (I32) HvMAX(stash); i++) {
7008             for (entry = HvARRAY(stash)[i];
7009                  entry;
7010                  entry = HeNEXT(entry))
7011             {
7012                 if (!todo[(U8)*HeKEY(entry)])
7013                     continue;
7014                 gv = (GV*)HeVAL(entry);
7015                 sv = GvSV(gv);
7016                 if (SvTHINKFIRST(sv)) {
7017                     if (!SvREADONLY(sv) && SvROK(sv))
7018                         sv_unref(sv);
7019                     continue;
7020                 }
7021                 (void)SvOK_off(sv);
7022                 if (SvTYPE(sv) >= SVt_PV) {
7023                     SvCUR_set(sv, 0);
7024                     if (SvPVX(sv) != Nullch)
7025                         *SvPVX(sv) = '\0';
7026                     SvTAINT(sv);
7027                 }
7028                 if (GvAV(gv)) {
7029                     av_clear(GvAV(gv));
7030                 }
7031                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7032                     hv_clear(GvHV(gv));
7033 #ifdef USE_ENVIRON_ARRAY
7034                     if (gv == PL_envgv
7035 #  ifdef USE_ITHREADS
7036                         && PL_curinterp == aTHX
7037 #  endif
7038                     )
7039                     {
7040                         environ[0] = Nullch;
7041                     }
7042 #endif
7043                 }
7044             }
7045         }
7046     }
7047 }
7048
7049 /*
7050 =for apidoc sv_2io
7051
7052 Using various gambits, try to get an IO from an SV: the IO slot if its a
7053 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7054 named after the PV if we're a string.
7055
7056 =cut
7057 */
7058
7059 IO*
7060 Perl_sv_2io(pTHX_ SV *sv)
7061 {
7062     IO* io;
7063     GV* gv;
7064     STRLEN n_a;
7065
7066     switch (SvTYPE(sv)) {
7067     case SVt_PVIO:
7068         io = (IO*)sv;
7069         break;
7070     case SVt_PVGV:
7071         gv = (GV*)sv;
7072         io = GvIO(gv);
7073         if (!io)
7074             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7075         break;
7076     default:
7077         if (!SvOK(sv))
7078             Perl_croak(aTHX_ PL_no_usym, "filehandle");
7079         if (SvROK(sv))
7080             return sv_2io(SvRV(sv));
7081         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
7082         if (gv)
7083             io = GvIO(gv);
7084         else
7085             io = 0;
7086         if (!io)
7087             Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7088         break;
7089     }
7090     return io;
7091 }
7092
7093 /*
7094 =for apidoc sv_2cv
7095
7096 Using various gambits, try to get a CV from an SV; in addition, try if
7097 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7098
7099 =cut
7100 */
7101
7102 CV *
7103 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7104 {
7105     GV *gv = Nullgv;
7106     CV *cv = Nullcv;
7107     STRLEN n_a;
7108
7109     if (!sv)
7110         return *gvp = Nullgv, Nullcv;
7111     switch (SvTYPE(sv)) {
7112     case SVt_PVCV:
7113         *st = CvSTASH(sv);
7114         *gvp = Nullgv;
7115         return (CV*)sv;
7116     case SVt_PVHV:
7117     case SVt_PVAV:
7118         *gvp = Nullgv;
7119         return Nullcv;
7120     case SVt_PVGV:
7121         gv = (GV*)sv;
7122         *gvp = gv;
7123         *st = GvESTASH(gv);
7124         goto fix_gv;
7125
7126     default:
7127         if (SvGMAGICAL(sv))
7128             mg_get(sv);
7129         if (SvROK(sv)) {
7130             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
7131             tryAMAGICunDEREF(to_cv);
7132
7133             sv = SvRV(sv);
7134             if (SvTYPE(sv) == SVt_PVCV) {
7135                 cv = (CV*)sv;
7136                 *gvp = Nullgv;
7137                 *st = CvSTASH(cv);
7138                 return cv;
7139             }
7140             else if(isGV(sv))
7141                 gv = (GV*)sv;
7142             else
7143                 Perl_croak(aTHX_ "Not a subroutine reference");
7144         }
7145         else if (isGV(sv))
7146             gv = (GV*)sv;
7147         else
7148             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
7149         *gvp = gv;
7150         if (!gv)
7151             return Nullcv;
7152         *st = GvESTASH(gv);
7153     fix_gv:
7154         if (lref && !GvCVu(gv)) {
7155             SV *tmpsv;
7156             ENTER;
7157             tmpsv = NEWSV(704,0);
7158             gv_efullname3(tmpsv, gv, Nullch);
7159             /* XXX this is probably not what they think they're getting.
7160              * It has the same effect as "sub name;", i.e. just a forward
7161              * declaration! */
7162             newSUB(start_subparse(FALSE, 0),
7163                    newSVOP(OP_CONST, 0, tmpsv),
7164                    Nullop,
7165                    Nullop);
7166             LEAVE;
7167             if (!GvCVu(gv))
7168                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7169                            sv);
7170         }
7171         return GvCVu(gv);
7172     }
7173 }
7174
7175 /*
7176 =for apidoc sv_true
7177
7178 Returns true if the SV has a true value by Perl's rules.
7179 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7180 instead use an in-line version.
7181
7182 =cut
7183 */
7184
7185 I32
7186 Perl_sv_true(pTHX_ register SV *sv)
7187 {
7188     if (!sv)
7189         return 0;
7190     if (SvPOK(sv)) {
7191         register XPV* tXpv;
7192         if ((tXpv = (XPV*)SvANY(sv)) &&
7193                 (tXpv->xpv_cur > 1 ||
7194                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
7195             return 1;
7196         else
7197             return 0;
7198     }
7199     else {
7200         if (SvIOK(sv))
7201             return SvIVX(sv) != 0;
7202         else {
7203             if (SvNOK(sv))
7204                 return SvNVX(sv) != 0.0;
7205             else
7206                 return sv_2bool(sv);
7207         }
7208     }
7209 }
7210
7211 /*
7212 =for apidoc sv_iv
7213
7214 A private implementation of the C<SvIVx> macro for compilers which can't
7215 cope with complex macro expressions. Always use the macro instead.
7216
7217 =cut
7218 */
7219
7220 IV
7221 Perl_sv_iv(pTHX_ register SV *sv)
7222 {
7223     if (SvIOK(sv)) {
7224         if (SvIsUV(sv))
7225             return (IV)SvUVX(sv);
7226         return SvIVX(sv);
7227     }
7228     return sv_2iv(sv);
7229 }
7230
7231 /*
7232 =for apidoc sv_uv
7233
7234 A private implementation of the C<SvUVx> macro for compilers which can't
7235 cope with complex macro expressions. Always use the macro instead.
7236
7237 =cut
7238 */
7239
7240 UV
7241 Perl_sv_uv(pTHX_ register SV *sv)
7242 {
7243     if (SvIOK(sv)) {
7244         if (SvIsUV(sv))
7245             return SvUVX(sv);
7246         return (UV)SvIVX(sv);
7247     }
7248     return sv_2uv(sv);
7249 }
7250
7251 /*
7252 =for apidoc sv_nv
7253
7254 A private implementation of the C<SvNVx> macro for compilers which can't
7255 cope with complex macro expressions. Always use the macro instead.
7256
7257 =cut
7258 */
7259
7260 NV
7261 Perl_sv_nv(pTHX_ register SV *sv)
7262 {
7263     if (SvNOK(sv))
7264         return SvNVX(sv);
7265     return sv_2nv(sv);
7266 }
7267
7268 /* sv_pv() is now a macro using SvPV_nolen();
7269  * this function provided for binary compatibility only
7270  */
7271
7272 char *
7273 Perl_sv_pv(pTHX_ SV *sv)
7274 {
7275     STRLEN n_a;
7276
7277     if (SvPOK(sv))
7278         return SvPVX(sv);
7279
7280     return sv_2pv(sv, &n_a);
7281 }
7282
7283 /*
7284 =for apidoc sv_pv
7285
7286 Use the C<SvPV_nolen> macro instead
7287
7288 =for apidoc sv_pvn
7289
7290 A private implementation of the C<SvPV> macro for compilers which can't
7291 cope with complex macro expressions. Always use the macro instead.
7292
7293 =cut
7294 */
7295
7296 char *
7297 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7298 {
7299     if (SvPOK(sv)) {
7300         *lp = SvCUR(sv);
7301         return SvPVX(sv);
7302     }
7303     return sv_2pv(sv, lp);
7304 }
7305
7306
7307 char *
7308 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7309 {
7310     if (SvPOK(sv)) {
7311         *lp = SvCUR(sv);
7312         return SvPVX(sv);
7313     }
7314     return sv_2pv_flags(sv, lp, 0);
7315 }
7316
7317 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
7318  * this function provided for binary compatibility only
7319  */
7320
7321 char *
7322 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
7323 {
7324     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
7325 }
7326
7327 /*
7328 =for apidoc sv_pvn_force
7329
7330 Get a sensible string out of the SV somehow.
7331 A private implementation of the C<SvPV_force> macro for compilers which
7332 can't cope with complex macro expressions. Always use the macro instead.
7333
7334 =for apidoc sv_pvn_force_flags
7335
7336 Get a sensible string out of the SV somehow.
7337 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7338 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7339 implemented in terms of this function.
7340 You normally want to use the various wrapper macros instead: see
7341 C<SvPV_force> and C<SvPV_force_nomg>
7342
7343 =cut
7344 */
7345
7346 char *
7347 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7348 {
7349     char *s = NULL;
7350
7351     if (SvTHINKFIRST(sv) && !SvROK(sv))
7352         sv_force_normal(sv);
7353
7354     if (SvPOK(sv)) {
7355         *lp = SvCUR(sv);
7356     }
7357     else {
7358         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
7359             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7360                 OP_NAME(PL_op));
7361         }
7362         else
7363             s = sv_2pv_flags(sv, lp, flags);
7364         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
7365             STRLEN len = *lp;
7366
7367             if (SvROK(sv))
7368                 sv_unref(sv);
7369             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
7370             SvGROW(sv, len + 1);
7371             Move(s,SvPVX(sv),len,char);
7372             SvCUR_set(sv, len);
7373             *SvEND(sv) = '\0';
7374         }
7375         if (!SvPOK(sv)) {
7376             SvPOK_on(sv);               /* validate pointer */
7377             SvTAINT(sv);
7378             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7379                                   PTR2UV(sv),SvPVX(sv)));
7380         }
7381     }
7382     return SvPVX(sv);
7383 }
7384
7385 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
7386  * this function provided for binary compatibility only
7387  */
7388
7389 char *
7390 Perl_sv_pvbyte(pTHX_ SV *sv)
7391 {
7392     sv_utf8_downgrade(sv,0);
7393     return sv_pv(sv);
7394 }
7395
7396 /*
7397 =for apidoc sv_pvbyte
7398
7399 Use C<SvPVbyte_nolen> instead.
7400
7401 =for apidoc sv_pvbyten
7402
7403 A private implementation of the C<SvPVbyte> macro for compilers
7404 which can't cope with complex macro expressions. Always use the macro
7405 instead.
7406
7407 =cut
7408 */
7409
7410 char *
7411 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7412 {
7413     sv_utf8_downgrade(sv,0);
7414     return sv_pvn(sv,lp);
7415 }
7416
7417 /*
7418 =for apidoc sv_pvbyten_force
7419
7420 A private implementation of the C<SvPVbytex_force> macro for compilers
7421 which can't cope with complex macro expressions. Always use the macro
7422 instead.
7423
7424 =cut
7425 */
7426
7427 char *
7428 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7429 {
7430     sv_utf8_downgrade(sv,0);
7431     return sv_pvn_force(sv,lp);
7432 }
7433
7434 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
7435  * this function provided for binary compatibility only
7436  */
7437
7438 char *
7439 Perl_sv_pvutf8(pTHX_ SV *sv)
7440 {
7441     sv_utf8_upgrade(sv);
7442     return sv_pv(sv);
7443 }
7444
7445 /*
7446 =for apidoc sv_pvutf8
7447
7448 Use the C<SvPVutf8_nolen> macro instead
7449
7450 =for apidoc sv_pvutf8n
7451
7452 A private implementation of the C<SvPVutf8> macro for compilers
7453 which can't cope with complex macro expressions. Always use the macro
7454 instead.
7455
7456 =cut
7457 */
7458
7459 char *
7460 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
7461 {
7462     sv_utf8_upgrade(sv);
7463     return sv_pvn(sv,lp);
7464 }
7465
7466 /*
7467 =for apidoc sv_pvutf8n_force
7468
7469 A private implementation of the C<SvPVutf8_force> macro for compilers
7470 which can't cope with complex macro expressions. Always use the macro
7471 instead.
7472
7473 =cut
7474 */
7475
7476 char *
7477 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7478 {
7479     sv_utf8_upgrade(sv);
7480     return sv_pvn_force(sv,lp);
7481 }
7482
7483 /*
7484 =for apidoc sv_reftype
7485
7486 Returns a string describing what the SV is a reference to.
7487
7488 =cut
7489 */
7490
7491 char *
7492 Perl_sv_reftype(pTHX_ SV *sv, int ob)
7493 {
7494     if (ob && SvOBJECT(sv)) {
7495         HV *svs = SvSTASH(sv);
7496         /* [20011101.072] This bandaid for C<package;> should eventually
7497            be removed. AMS 20011103 */
7498         return (svs ? HvNAME(svs) : "<none>");
7499     }
7500     else {
7501         switch (SvTYPE(sv)) {
7502         case SVt_NULL:
7503         case SVt_IV:
7504         case SVt_NV:
7505         case SVt_RV:
7506         case SVt_PV:
7507         case SVt_PVIV:
7508         case SVt_PVNV:
7509         case SVt_PVMG:
7510         case SVt_PVBM:
7511                                 if (SvROK(sv))
7512                                     return "REF";
7513                                 else
7514                                     return "SCALAR";
7515         case SVt_PVLV:          return SvROK(sv) ? "REF" : "LVALUE";
7516         case SVt_PVAV:          return "ARRAY";
7517         case SVt_PVHV:          return "HASH";
7518         case SVt_PVCV:          return "CODE";
7519         case SVt_PVGV:          return "GLOB";
7520         case SVt_PVFM:          return "FORMAT";
7521         case SVt_PVIO:          return "IO";
7522         default:                return "UNKNOWN";
7523         }
7524     }
7525 }
7526
7527 /*
7528 =for apidoc sv_isobject
7529
7530 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7531 object.  If the SV is not an RV, or if the object is not blessed, then this
7532 will return false.
7533
7534 =cut
7535 */
7536
7537 int
7538 Perl_sv_isobject(pTHX_ SV *sv)
7539 {
7540     if (!sv)
7541         return 0;
7542     if (SvGMAGICAL(sv))
7543         mg_get(sv);
7544     if (!SvROK(sv))
7545         return 0;
7546     sv = (SV*)SvRV(sv);
7547     if (!SvOBJECT(sv))
7548         return 0;
7549     return 1;
7550 }
7551
7552 /*
7553 =for apidoc sv_isa
7554
7555 Returns a boolean indicating whether the SV is blessed into the specified
7556 class.  This does not check for subtypes; use C<sv_derived_from> to verify
7557 an inheritance relationship.
7558
7559 =cut
7560 */
7561
7562 int
7563 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7564 {
7565     if (!sv)
7566         return 0;
7567     if (SvGMAGICAL(sv))
7568         mg_get(sv);
7569     if (!SvROK(sv))
7570         return 0;
7571     sv = (SV*)SvRV(sv);
7572     if (!SvOBJECT(sv))
7573         return 0;
7574
7575     return strEQ(HvNAME(SvSTASH(sv)), name);
7576 }
7577
7578 /*
7579 =for apidoc newSVrv
7580
7581 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
7582 it will be upgraded to one.  If C<classname> is non-null then the new SV will
7583 be blessed in the specified package.  The new SV is returned and its
7584 reference count is 1.
7585
7586 =cut
7587 */
7588
7589 SV*
7590 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7591 {
7592     SV *sv;
7593
7594     new_SV(sv);
7595
7596     SV_CHECK_THINKFIRST(rv);
7597     SvAMAGIC_off(rv);
7598
7599     if (SvTYPE(rv) >= SVt_PVMG) {
7600         U32 refcnt = SvREFCNT(rv);
7601         SvREFCNT(rv) = 0;
7602         sv_clear(rv);
7603         SvFLAGS(rv) = 0;
7604         SvREFCNT(rv) = refcnt;
7605     }
7606
7607     if (SvTYPE(rv) < SVt_RV)
7608         sv_upgrade(rv, SVt_RV);
7609     else if (SvTYPE(rv) > SVt_RV) {
7610         (void)SvOOK_off(rv);
7611         if (SvPVX(rv) && SvLEN(rv))
7612             Safefree(SvPVX(rv));
7613         SvCUR_set(rv, 0);
7614         SvLEN_set(rv, 0);
7615     }
7616
7617     (void)SvOK_off(rv);
7618     SvRV(rv) = sv;
7619     SvROK_on(rv);
7620
7621     if (classname) {
7622         HV* stash = gv_stashpv(classname, TRUE);
7623         (void)sv_bless(rv, stash);
7624     }
7625     return sv;
7626 }
7627
7628 /*
7629 =for apidoc sv_setref_pv
7630
7631 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
7632 argument will be upgraded to an RV.  That RV will be modified to point to
7633 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7634 into the SV.  The C<classname> argument indicates the package for the
7635 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7636 will be returned and will have a reference count of 1.
7637
7638 Do not use with other Perl types such as HV, AV, SV, CV, because those
7639 objects will become corrupted by the pointer copy process.
7640
7641 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7642
7643 =cut
7644 */
7645
7646 SV*
7647 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7648 {
7649     if (!pv) {
7650         sv_setsv(rv, &PL_sv_undef);
7651         SvSETMAGIC(rv);
7652     }
7653     else
7654         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7655     return rv;
7656 }
7657
7658 /*
7659 =for apidoc sv_setref_iv
7660
7661 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
7662 argument will be upgraded to an RV.  That RV will be modified to point to
7663 the new SV.  The C<classname> argument indicates the package for the
7664 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7665 will be returned and will have a reference count of 1.
7666
7667 =cut
7668 */
7669
7670 SV*
7671 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7672 {
7673     sv_setiv(newSVrv(rv,classname), iv);
7674     return rv;
7675 }
7676
7677 /*
7678 =for apidoc sv_setref_uv
7679
7680 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
7681 argument will be upgraded to an RV.  That RV will be modified to point to
7682 the new SV.  The C<classname> argument indicates the package for the
7683 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7684 will be returned and will have a reference count of 1.
7685
7686 =cut
7687 */
7688
7689 SV*
7690 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7691 {
7692     sv_setuv(newSVrv(rv,classname), uv);
7693     return rv;
7694 }
7695
7696 /*
7697 =for apidoc sv_setref_nv
7698
7699 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
7700 argument will be upgraded to an RV.  That RV will be modified to point to
7701 the new SV.  The C<classname> argument indicates the package for the
7702 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7703 will be returned and will have a reference count of 1.
7704
7705 =cut
7706 */
7707
7708 SV*
7709 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7710 {
7711     sv_setnv(newSVrv(rv,classname), nv);
7712     return rv;
7713 }
7714
7715 /*
7716 =for apidoc sv_setref_pvn
7717
7718 Copies a string into a new SV, optionally blessing the SV.  The length of the
7719 string must be specified with C<n>.  The C<rv> argument will be upgraded to
7720 an RV.  That RV will be modified to point to the new SV.  The C<classname>
7721 argument indicates the package for the blessing.  Set C<classname> to
7722 C<Nullch> to avoid the blessing.  The new SV will be returned and will have
7723 a reference count of 1.
7724
7725 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7726
7727 =cut
7728 */
7729
7730 SV*
7731 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7732 {
7733     sv_setpvn(newSVrv(rv,classname), pv, n);
7734     return rv;
7735 }
7736
7737 /*
7738 =for apidoc sv_bless
7739
7740 Blesses an SV into a specified package.  The SV must be an RV.  The package
7741 must be designated by its stash (see C<gv_stashpv()>).  The reference count
7742 of the SV is unaffected.
7743
7744 =cut
7745 */
7746
7747 SV*
7748 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7749 {
7750     SV *tmpRef;
7751     if (!SvROK(sv))
7752         Perl_croak(aTHX_ "Can't bless non-reference value");
7753     tmpRef = SvRV(sv);
7754     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7755         if (SvREADONLY(tmpRef))
7756             Perl_croak(aTHX_ PL_no_modify);
7757         if (SvOBJECT(tmpRef)) {
7758             if (SvTYPE(tmpRef) != SVt_PVIO)
7759                 --PL_sv_objcount;
7760             SvREFCNT_dec(SvSTASH(tmpRef));
7761         }
7762     }
7763     SvOBJECT_on(tmpRef);
7764     if (SvTYPE(tmpRef) != SVt_PVIO)
7765         ++PL_sv_objcount;
7766     (void)SvUPGRADE(tmpRef, SVt_PVMG);
7767     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7768
7769     if (Gv_AMG(stash))
7770         SvAMAGIC_on(sv);
7771     else
7772         SvAMAGIC_off(sv);
7773
7774     if(SvSMAGICAL(tmpRef))
7775         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7776             mg_set(tmpRef);
7777
7778
7779
7780     return sv;
7781 }
7782
7783 /* Downgrades a PVGV to a PVMG.
7784  */
7785
7786 STATIC void
7787 S_sv_unglob(pTHX_ SV *sv)
7788 {
7789     void *xpvmg;
7790
7791     assert(SvTYPE(sv) == SVt_PVGV);
7792     SvFAKE_off(sv);
7793     if (GvGP(sv))
7794         gp_free((GV*)sv);
7795     if (GvSTASH(sv)) {
7796         SvREFCNT_dec(GvSTASH(sv));
7797         GvSTASH(sv) = Nullhv;
7798     }
7799     sv_unmagic(sv, PERL_MAGIC_glob);
7800     Safefree(GvNAME(sv));
7801     GvMULTI_off(sv);
7802
7803     /* need to keep SvANY(sv) in the right arena */
7804     xpvmg = new_XPVMG();
7805     StructCopy(SvANY(sv), xpvmg, XPVMG);
7806     del_XPVGV(SvANY(sv));
7807     SvANY(sv) = xpvmg;
7808
7809     SvFLAGS(sv) &= ~SVTYPEMASK;
7810     SvFLAGS(sv) |= SVt_PVMG;
7811 }
7812
7813 /*
7814 =for apidoc sv_unref_flags
7815
7816 Unsets the RV status of the SV, and decrements the reference count of
7817 whatever was being referenced by the RV.  This can almost be thought of
7818 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
7819 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7820 (otherwise the decrementing is conditional on the reference count being
7821 different from one or the reference being a readonly SV).
7822 See C<SvROK_off>.
7823
7824 =cut
7825 */
7826
7827 void
7828 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7829 {
7830     SV* rv = SvRV(sv);
7831
7832     if (SvWEAKREF(sv)) {
7833         sv_del_backref(sv);
7834         SvWEAKREF_off(sv);
7835         SvRV(sv) = 0;
7836         return;
7837     }
7838     SvRV(sv) = 0;
7839     SvROK_off(sv);
7840     if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7841         SvREFCNT_dec(rv);
7842     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7843         sv_2mortal(rv);         /* Schedule for freeing later */
7844 }
7845
7846 /*
7847 =for apidoc sv_unref
7848
7849 Unsets the RV status of the SV, and decrements the reference count of
7850 whatever was being referenced by the RV.  This can almost be thought of
7851 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
7852 being zero.  See C<SvROK_off>.
7853
7854 =cut
7855 */
7856
7857 void
7858 Perl_sv_unref(pTHX_ SV *sv)
7859 {
7860     sv_unref_flags(sv, 0);
7861 }
7862
7863 /*
7864 =for apidoc sv_taint
7865
7866 Taint an SV. Use C<SvTAINTED_on> instead.
7867 =cut
7868 */
7869
7870 void
7871 Perl_sv_taint(pTHX_ SV *sv)
7872 {
7873     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7874 }
7875
7876 /*
7877 =for apidoc sv_untaint
7878
7879 Untaint an SV. Use C<SvTAINTED_off> instead.
7880 =cut
7881 */
7882
7883 void
7884 Perl_sv_untaint(pTHX_ SV *sv)
7885 {
7886     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7887         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7888         if (mg)
7889             mg->mg_len &= ~1;
7890     }
7891 }
7892
7893 /*
7894 =for apidoc sv_tainted
7895
7896 Test an SV for taintedness. Use C<SvTAINTED> instead.
7897 =cut
7898 */
7899
7900 bool
7901 Perl_sv_tainted(pTHX_ SV *sv)
7902 {
7903     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7904         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7905         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7906             return TRUE;
7907     }
7908     return FALSE;
7909 }
7910
7911 /*
7912 =for apidoc sv_setpviv
7913
7914 Copies an integer into the given SV, also updating its string value.
7915 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
7916
7917 =cut
7918 */
7919
7920 void
7921 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7922 {
7923     char buf[TYPE_CHARS(UV)];
7924     char *ebuf;
7925     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7926
7927     sv_setpvn(sv, ptr, ebuf - ptr);
7928 }
7929
7930 /*
7931 =for apidoc sv_setpviv_mg
7932
7933 Like C<sv_setpviv>, but also handles 'set' magic.
7934
7935 =cut
7936 */
7937
7938 void
7939 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7940 {
7941     char buf[TYPE_CHARS(UV)];
7942     char *ebuf;
7943     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7944
7945     sv_setpvn(sv, ptr, ebuf - ptr);
7946     SvSETMAGIC(sv);
7947 }
7948
7949 #if defined(PERL_IMPLICIT_CONTEXT)
7950
7951 /* pTHX_ magic can't cope with varargs, so this is a no-context
7952  * version of the main function, (which may itself be aliased to us).
7953  * Don't access this version directly.
7954  */
7955
7956 void
7957 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7958 {
7959     dTHX;
7960     va_list args;
7961     va_start(args, pat);
7962     sv_vsetpvf(sv, pat, &args);
7963     va_end(args);
7964 }
7965
7966 /* pTHX_ magic can't cope with varargs, so this is a no-context
7967  * version of the main function, (which may itself be aliased to us).
7968  * Don't access this version directly.
7969  */
7970
7971 void
7972 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7973 {
7974     dTHX;
7975     va_list args;
7976     va_start(args, pat);
7977     sv_vsetpvf_mg(sv, pat, &args);
7978     va_end(args);
7979 }
7980 #endif
7981
7982 /*
7983 =for apidoc sv_setpvf
7984
7985 Processes its arguments like C<sprintf> and sets an SV to the formatted
7986 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
7987
7988 =cut
7989 */
7990
7991 void
7992 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7993 {
7994     va_list args;
7995     va_start(args, pat);
7996     sv_vsetpvf(sv, pat, &args);
7997     va_end(args);
7998 }
7999
8000 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
8001
8002 void
8003 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8004 {
8005     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8006 }
8007
8008 /*
8009 =for apidoc sv_setpvf_mg
8010
8011 Like C<sv_setpvf>, but also handles 'set' magic.
8012
8013 =cut
8014 */
8015
8016 void
8017 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8018 {
8019     va_list args;
8020     va_start(args, pat);
8021     sv_vsetpvf_mg(sv, pat, &args);
8022     va_end(args);
8023 }
8024
8025 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
8026
8027 void
8028 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8029 {
8030     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8031     SvSETMAGIC(sv);
8032 }
8033
8034 #if defined(PERL_IMPLICIT_CONTEXT)
8035
8036 /* pTHX_ magic can't cope with varargs, so this is a no-context
8037  * version of the main function, (which may itself be aliased to us).
8038  * Don't access this version directly.
8039  */
8040
8041 void
8042 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8043 {
8044     dTHX;
8045     va_list args;
8046     va_start(args, pat);
8047     sv_vcatpvf(sv, pat, &args);
8048     va_end(args);
8049 }
8050
8051 /* pTHX_ magic can't cope with varargs, so this is a no-context
8052  * version of the main function, (which may itself be aliased to us).
8053  * Don't access this version directly.
8054  */
8055
8056 void
8057 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8058 {
8059     dTHX;
8060     va_list args;
8061     va_start(args, pat);
8062     sv_vcatpvf_mg(sv, pat, &args);
8063     va_end(args);
8064 }
8065 #endif
8066
8067 /*
8068 =for apidoc sv_catpvf
8069
8070 Processes its arguments like C<sprintf> and appends the formatted
8071 output to an SV.  If the appended data contains "wide" characters
8072 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8073 and characters >255 formatted with %c), the original SV might get
8074 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.
8075 C<SvSETMAGIC()> must typically be called after calling this function
8076 to handle 'set' magic.
8077
8078 =cut */
8079
8080 void
8081 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8082 {
8083     va_list args;
8084     va_start(args, pat);
8085     sv_vcatpvf(sv, pat, &args);
8086     va_end(args);
8087 }
8088
8089 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
8090
8091 void
8092 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8093 {
8094     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8095 }
8096
8097 /*
8098 =for apidoc sv_catpvf_mg
8099
8100 Like C<sv_catpvf>, but also handles 'set' magic.
8101
8102 =cut
8103 */
8104
8105 void
8106 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8107 {
8108     va_list args;
8109     va_start(args, pat);
8110     sv_vcatpvf_mg(sv, pat, &args);
8111     va_end(args);
8112 }
8113
8114 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
8115
8116 void
8117 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8118 {
8119     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8120     SvSETMAGIC(sv);
8121 }
8122
8123 /*
8124 =for apidoc sv_vsetpvfn
8125
8126 Works like C<vcatpvfn> but copies the text into the SV instead of
8127 appending it.
8128
8129 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
8130
8131 =cut
8132 */
8133
8134 void
8135 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8136 {
8137     sv_setpvn(sv, "", 0);
8138     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8139 }
8140
8141 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8142
8143 STATIC I32
8144 S_expect_number(pTHX_ char** pattern)
8145 {
8146     I32 var = 0;
8147     switch (**pattern) {
8148     case '1': case '2': case '3':
8149     case '4': case '5': case '6':
8150     case '7': case '8': case '9':
8151         while (isDIGIT(**pattern))
8152             var = var * 10 + (*(*pattern)++ - '0');
8153     }
8154     return var;
8155 }
8156 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8157
8158 /*
8159 =for apidoc sv_vcatpvfn
8160
8161 Processes its arguments like C<vsprintf> and appends the formatted output
8162 to an SV.  Uses an array of SVs if the C style variable argument list is
8163 missing (NULL).  When running with taint checks enabled, indicates via
8164 C<maybe_tainted> if results are untrustworthy (often due to the use of
8165 locales).
8166
8167 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
8168
8169 =cut
8170 */
8171
8172 void
8173 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8174 {
8175     char *p;
8176     char *q;
8177     char *patend;
8178     STRLEN origlen;
8179     I32 svix = 0;
8180     static char nullstr[] = "(null)";
8181     SV *argsv = Nullsv;
8182     bool has_utf8; /* has the result utf8? */
8183     bool pat_utf8; /* the pattern is in utf8? */
8184     SV *nsv = Nullsv;
8185
8186     has_utf8 = pat_utf8 = DO_UTF8(sv);
8187
8188     /* no matter what, this is a string now */
8189     (void)SvPV_force(sv, origlen);
8190
8191     /* special-case "", "%s", and "%_" */
8192     if (patlen == 0)
8193         return;
8194     if (patlen == 2 && pat[0] == '%') {
8195         switch (pat[1]) {
8196         case 's':
8197             if (args) {
8198                 char *s = va_arg(*args, char*);
8199                 sv_catpv(sv, s ? s : nullstr);
8200             }
8201             else if (svix < svmax) {
8202                 sv_catsv(sv, *svargs);
8203                 if (DO_UTF8(*svargs))
8204                     SvUTF8_on(sv);
8205             }
8206             return;
8207         case '_':
8208             if (args) {
8209                 argsv = va_arg(*args, SV*);
8210                 sv_catsv(sv, argsv);
8211                 if (DO_UTF8(argsv))
8212                     SvUTF8_on(sv);
8213                 return;
8214             }
8215             /* See comment on '_' below */
8216             break;
8217         }
8218     }
8219
8220     if (!args && svix < svmax && DO_UTF8(*svargs))
8221         has_utf8 = TRUE;
8222
8223     patend = (char*)pat + patlen;
8224     for (p = (char*)pat; p < patend; p = q) {
8225         bool alt = FALSE;
8226         bool left = FALSE;
8227         bool vectorize = FALSE;
8228         bool vectorarg = FALSE;
8229         bool vec_utf8 = FALSE;
8230         char fill = ' ';
8231         char plus = 0;
8232         char intsize = 0;
8233         STRLEN width = 0;
8234         STRLEN zeros = 0;
8235         bool has_precis = FALSE;
8236         STRLEN precis = 0;
8237         I32 osvix = svix;
8238         bool is_utf8 = FALSE;  /* is this item utf8?   */
8239 #ifdef HAS_LDBL_SPRINTF_BUG
8240         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8241            with sfio - Allen <allens@cpan.org> */
8242         bool fix_ldbl_sprintf_bug = FALSE;
8243 #endif
8244
8245         char esignbuf[4];
8246         U8 utf8buf[UTF8_MAXLEN+1];
8247         STRLEN esignlen = 0;
8248
8249         char *eptr = Nullch;
8250         STRLEN elen = 0;
8251         /* Times 4: a decimal digit takes more than 3 binary digits.
8252          * NV_DIG: mantissa takes than many decimal digits.
8253          * Plus 32: Playing safe. */
8254         char ebuf[IV_DIG * 4 + NV_DIG + 32];
8255         /* large enough for "%#.#f" --chip */
8256         /* what about long double NVs? --jhi */
8257
8258         SV *vecsv = Nullsv;
8259         U8 *vecstr = Null(U8*);
8260         STRLEN veclen = 0;
8261         char c = 0;
8262         int i;
8263         unsigned base = 0;
8264         IV iv = 0;
8265         UV uv = 0;
8266         /* we need a long double target in case HAS_LONG_DOUBLE but
8267            not USE_LONG_DOUBLE
8268         */
8269 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8270         long double nv;
8271 #else
8272         NV nv;
8273 #endif
8274         STRLEN have;
8275         STRLEN need;
8276         STRLEN gap;
8277         char *dotstr = ".";
8278         STRLEN dotstrlen = 1;
8279         I32 efix = 0; /* explicit format parameter index */
8280         I32 ewix = 0; /* explicit width index */
8281         I32 epix = 0; /* explicit precision index */
8282         I32 evix = 0; /* explicit vector index */
8283         bool asterisk = FALSE;
8284
8285         /* echo everything up to the next format specification */
8286         for (q = p; q < patend && *q != '%'; ++q) ;
8287         if (q > p) {
8288             if (has_utf8 && !pat_utf8)
8289                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8290             else
8291                 sv_catpvn(sv, p, q - p);
8292             p = q;
8293         }
8294         if (q++ >= patend)
8295             break;
8296
8297 /*
8298     We allow format specification elements in this order:
8299         \d+\$              explicit format parameter index
8300         [-+ 0#]+           flags
8301         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
8302         0                  flag (as above): repeated to allow "v02"
8303         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
8304         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8305         [hlqLV]            size
8306     [%bcdefginopsux_DFOUX] format (mandatory)
8307 */
8308         if (EXPECT_NUMBER(q, width)) {
8309             if (*q == '$') {
8310                 ++q;
8311                 efix = width;
8312             } else {
8313                 goto gotwidth;
8314             }
8315         }
8316
8317         /* FLAGS */
8318
8319         while (*q) {
8320             switch (*q) {
8321             case ' ':
8322             case '+':
8323                 plus = *q++;
8324                 continue;
8325
8326             case '-':
8327                 left = TRUE;
8328                 q++;
8329                 continue;
8330
8331             case '0':
8332                 fill = *q++;
8333                 continue;
8334
8335             case '#':
8336                 alt = TRUE;
8337                 q++;
8338                 continue;
8339
8340             default:
8341                 break;
8342             }
8343             break;
8344         }
8345
8346       tryasterisk:
8347         if (*q == '*') {
8348             q++;
8349             if (EXPECT_NUMBER(q, ewix))
8350                 if (*q++ != '$')
8351                     goto unknown;
8352             asterisk = TRUE;
8353         }
8354         if (*q == 'v') {
8355             q++;
8356             if (vectorize)
8357                 goto unknown;
8358             if ((vectorarg = asterisk)) {
8359                 evix = ewix;
8360                 ewix = 0;
8361                 asterisk = FALSE;
8362             }
8363             vectorize = TRUE;
8364             goto tryasterisk;
8365         }
8366
8367         if (!asterisk)
8368             if( *q == '0' )
8369                 fill = *q++;
8370             EXPECT_NUMBER(q, width);
8371
8372         if (vectorize) {
8373             if (vectorarg) {
8374                 if (args)
8375                     vecsv = va_arg(*args, SV*);
8376                 else
8377                     vecsv = (evix ? evix <= svmax : svix < svmax) ?
8378                         svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
8379                 dotstr = SvPVx(vecsv, dotstrlen);
8380                 if (DO_UTF8(vecsv))
8381                     is_utf8 = TRUE;
8382             }
8383             if (args) {
8384                 vecsv = va_arg(*args, SV*);
8385                 vecstr = (U8*)SvPVx(vecsv,veclen);
8386                 vec_utf8 = DO_UTF8(vecsv);
8387             }
8388             else if (efix ? efix <= svmax : svix < svmax) {
8389                 vecsv = svargs[efix ? efix-1 : svix++];
8390                 vecstr = (U8*)SvPVx(vecsv,veclen);
8391                 vec_utf8 = DO_UTF8(vecsv);
8392             }
8393             else {
8394                 vecstr = (U8*)"";
8395                 veclen = 0;
8396             }
8397         }
8398
8399         if (asterisk) {
8400             if (args)
8401                 i = va_arg(*args, int);
8402             else
8403                 i = (ewix ? ewix <= svmax : svix < svmax) ?
8404                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8405             left |= (i < 0);
8406             width = (i < 0) ? -i : i;
8407         }
8408       gotwidth:
8409
8410         /* PRECISION */
8411
8412         if (*q == '.') {
8413             q++;
8414             if (*q == '*') {
8415                 q++;
8416                 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8417                     goto unknown;
8418                 /* XXX: todo, support specified precision parameter */
8419                 if (epix)
8420                     goto unknown;
8421                 if (args)
8422                     i = va_arg(*args, int);
8423                 else
8424                     i = (ewix ? ewix <= svmax : svix < svmax)
8425                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8426                 precis = (i < 0) ? 0 : i;
8427             }
8428             else {
8429                 precis = 0;
8430                 while (isDIGIT(*q))
8431                     precis = precis * 10 + (*q++ - '0');
8432             }
8433             has_precis = TRUE;
8434         }
8435
8436         /* SIZE */
8437
8438         switch (*q) {
8439 #ifdef WIN32
8440         case 'I':                       /* Ix, I32x, and I64x */
8441 #  ifdef WIN64
8442             if (q[1] == '6' && q[2] == '4') {
8443                 q += 3;
8444                 intsize = 'q';
8445                 break;
8446             }
8447 #  endif
8448             if (q[1] == '3' && q[2] == '2') {
8449                 q += 3;
8450                 break;
8451             }
8452 #  ifdef WIN64
8453             intsize = 'q';
8454 #  endif
8455             q++;
8456             break;
8457 #endif
8458 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8459         case 'L':                       /* Ld */
8460             /* FALL THROUGH */
8461 #ifdef HAS_QUAD
8462         case 'q':                       /* qd */
8463 #endif
8464             intsize = 'q';
8465             q++;
8466             break;
8467 #endif
8468         case 'l':
8469 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8470             if (*(q + 1) == 'l') {      /* lld, llf */
8471                 intsize = 'q';
8472                 q += 2;
8473                 break;
8474              }
8475 #endif
8476             /* FALL THROUGH */
8477         case 'h':
8478             /* FALL THROUGH */
8479         case 'V':
8480             intsize = *q++;
8481             break;
8482         }
8483
8484         /* CONVERSION */
8485
8486         if (*q == '%') {
8487             eptr = q++;
8488             elen = 1;
8489             goto string;
8490         }
8491
8492         if (vectorize)
8493             argsv = vecsv;
8494         else if (!args)
8495             argsv = (efix ? efix <= svmax : svix < svmax) ?
8496                     svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8497
8498         switch (c = *q++) {
8499
8500             /* STRINGS */
8501
8502         case 'c':
8503             uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8504             if ((uv > 255 ||
8505                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8506                 && !IN_BYTES) {
8507                 eptr = (char*)utf8buf;
8508                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8509                 is_utf8 = TRUE;
8510             }
8511             else {
8512                 c = (char)uv;
8513                 eptr = &c;
8514                 elen = 1;
8515             }
8516             goto string;
8517
8518         case 's':
8519             if (args && !vectorize) {
8520                 eptr = va_arg(*args, char*);
8521                 if (eptr)
8522 #ifdef MACOS_TRADITIONAL
8523                   /* On MacOS, %#s format is used for Pascal strings */
8524                   if (alt)
8525                     elen = *eptr++;
8526                   else
8527 #endif
8528                     elen = strlen(eptr);
8529                 else {
8530                     eptr = nullstr;
8531                     elen = sizeof nullstr - 1;
8532                 }
8533             }
8534             else {
8535                 eptr = SvPVx(argsv, elen);
8536                 if (DO_UTF8(argsv)) {
8537                     if (has_precis && precis < elen) {
8538                         I32 p = precis;
8539                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8540                         precis = p;
8541                     }
8542                     if (width) { /* fudge width (can't fudge elen) */
8543                         width += elen - sv_len_utf8(argsv);
8544                     }
8545                     is_utf8 = TRUE;
8546                 }
8547             }
8548             goto string;
8549
8550         case '_':
8551             /*
8552              * The "%_" hack might have to be changed someday,
8553              * if ISO or ANSI decide to use '_' for something.
8554              * So we keep it hidden from users' code.
8555              */
8556             if (!args || vectorize)
8557                 goto unknown;
8558             argsv = va_arg(*args, SV*);
8559             eptr = SvPVx(argsv, elen);
8560             if (DO_UTF8(argsv))
8561                 is_utf8 = TRUE;
8562
8563         string:
8564             vectorize = FALSE;
8565             if (has_precis && elen > precis)
8566                 elen = precis;
8567             break;
8568
8569             /* INTEGERS */
8570
8571         case 'p':
8572             if (alt || vectorize)
8573                 goto unknown;
8574             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8575             base = 16;
8576             goto integer;
8577
8578         case 'D':
8579 #ifdef IV_IS_QUAD
8580             intsize = 'q';
8581 #else
8582             intsize = 'l';
8583 #endif
8584             /* FALL THROUGH */
8585         case 'd':
8586         case 'i':
8587             if (vectorize) {
8588                 STRLEN ulen;
8589                 if (!veclen)
8590                     continue;
8591                 if (vec_utf8)
8592                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8593                                         UTF8_ALLOW_ANYUV);
8594                 else {
8595                     uv = *vecstr;
8596                     ulen = 1;
8597                 }
8598                 vecstr += ulen;
8599                 veclen -= ulen;
8600                 if (plus)
8601                      esignbuf[esignlen++] = plus;
8602             }
8603             else if (args) {
8604                 switch (intsize) {
8605                 case 'h':       iv = (short)va_arg(*args, int); break;
8606                 default:        iv = va_arg(*args, int); break;
8607                 case 'l':       iv = va_arg(*args, long); break;
8608                 case 'V':       iv = va_arg(*args, IV); break;
8609 #ifdef HAS_QUAD
8610                 case 'q':       iv = va_arg(*args, Quad_t); break;
8611 #endif
8612                 }
8613             }
8614             else {
8615                 iv = SvIVx(argsv);
8616                 switch (intsize) {
8617                 case 'h':       iv = (short)iv; break;
8618                 default:        break;
8619                 case 'l':       iv = (long)iv; break;
8620                 case 'V':       break;
8621 #ifdef HAS_QUAD
8622                 case 'q':       iv = (Quad_t)iv; break;
8623 #endif
8624                 }
8625             }
8626             if ( !vectorize )   /* we already set uv above */
8627             {
8628                 if (iv >= 0) {
8629                     uv = iv;
8630                     if (plus)
8631                         esignbuf[esignlen++] = plus;
8632                 }
8633                 else {
8634                     uv = -iv;
8635                     esignbuf[esignlen++] = '-';
8636                 }
8637             }
8638             base = 10;
8639             goto integer;
8640
8641         case 'U':
8642 #ifdef IV_IS_QUAD
8643             intsize = 'q';
8644 #else
8645             intsize = 'l';
8646 #endif
8647             /* FALL THROUGH */
8648         case 'u':
8649             base = 10;
8650             goto uns_integer;
8651
8652         case 'b':
8653             base = 2;
8654             goto uns_integer;
8655
8656         case 'O':
8657 #ifdef IV_IS_QUAD
8658             intsize = 'q';
8659 #else
8660             intsize = 'l';
8661 #endif
8662             /* FALL THROUGH */
8663         case 'o':
8664             base = 8;
8665             goto uns_integer;
8666
8667         case 'X':
8668         case 'x':
8669             base = 16;
8670
8671         uns_integer:
8672             if (vectorize) {
8673                 STRLEN ulen;
8674         vector:
8675                 if (!veclen)
8676                     continue;
8677                 if (vec_utf8)
8678                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8679                                         UTF8_ALLOW_ANYUV);
8680                 else {
8681                     uv = *vecstr;
8682                     ulen = 1;
8683                 }
8684                 vecstr += ulen;
8685                 veclen -= ulen;
8686             }
8687             else if (args) {
8688                 switch (intsize) {
8689                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
8690                 default:   uv = va_arg(*args, unsigned); break;
8691                 case 'l':  uv = va_arg(*args, unsigned long); break;
8692                 case 'V':  uv = va_arg(*args, UV); break;
8693 #ifdef HAS_QUAD
8694                 case 'q':  uv = va_arg(*args, Quad_t); break;
8695 #endif
8696                 }
8697             }
8698             else {
8699                 uv = SvUVx(argsv);
8700                 switch (intsize) {
8701                 case 'h':       uv = (unsigned short)uv; break;
8702                 default:        break;
8703                 case 'l':       uv = (unsigned long)uv; break;
8704                 case 'V':       break;
8705 #ifdef HAS_QUAD
8706                 case 'q':       uv = (Quad_t)uv; break;
8707 #endif
8708                 }
8709             }
8710
8711         integer:
8712             eptr = ebuf + sizeof ebuf;
8713             switch (base) {
8714                 unsigned dig;
8715             case 16:
8716                 if (!uv)
8717                     alt = FALSE;
8718                 p = (char*)((c == 'X')
8719                             ? "0123456789ABCDEF" : "0123456789abcdef");
8720                 do {
8721                     dig = uv & 15;
8722                     *--eptr = p[dig];
8723                 } while (uv >>= 4);
8724                 if (alt) {
8725                     esignbuf[esignlen++] = '0';
8726                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
8727                 }
8728                 break;
8729             case 8:
8730                 do {
8731                     dig = uv & 7;
8732                     *--eptr = '0' + dig;
8733                 } while (uv >>= 3);
8734                 if (alt && *eptr != '0')
8735                     *--eptr = '0';
8736                 break;
8737             case 2:
8738                 do {
8739                     dig = uv & 1;
8740                     *--eptr = '0' + dig;
8741                 } while (uv >>= 1);
8742                 if (alt) {
8743                     esignbuf[esignlen++] = '0';
8744                     esignbuf[esignlen++] = 'b';
8745                 }
8746                 break;
8747             default:            /* it had better be ten or less */
8748 #if defined(PERL_Y2KWARN)
8749                 if (ckWARN(WARN_Y2K)) {
8750                     STRLEN n;
8751                     char *s = SvPV(sv,n);
8752                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8753                         && (n == 2 || !isDIGIT(s[n-3])))
8754                     {
8755                         Perl_warner(aTHX_ packWARN(WARN_Y2K),
8756                                     "Possible Y2K bug: %%%c %s",
8757                                     c, "format string following '19'");
8758                     }
8759                 }
8760 #endif
8761                 do {
8762                     dig = uv % base;
8763                     *--eptr = '0' + dig;
8764                 } while (uv /= base);
8765                 break;
8766             }
8767             elen = (ebuf + sizeof ebuf) - eptr;
8768             if (has_precis) {
8769                 if (precis > elen)
8770                     zeros = precis - elen;
8771                 else if (precis == 0 && elen == 1 && *eptr == '0')
8772                     elen = 0;
8773             }
8774             break;
8775
8776             /* FLOATING POINT */
8777
8778         case 'F':
8779             c = 'f';            /* maybe %F isn't supported here */
8780             /* FALL THROUGH */
8781         case 'e': case 'E':
8782         case 'f':
8783         case 'g': case 'G':
8784
8785             /* This is evil, but floating point is even more evil */
8786
8787             /* for SV-style calling, we can only get NV
8788                for C-style calling, we assume %f is double;
8789                for simplicity we allow any of %Lf, %llf, %qf for long double
8790             */
8791             switch (intsize) {
8792             case 'V':
8793 #if defined(USE_LONG_DOUBLE)
8794                 intsize = 'q';
8795 #endif
8796                 break;
8797 /* [perl #20339] - we should accept and ignore %lf rather than die */
8798             case 'l':
8799                 /* FALL THROUGH */
8800             default:
8801 #if defined(USE_LONG_DOUBLE)
8802                 intsize = args ? 0 : 'q';
8803 #endif
8804                 break;
8805             case 'q':
8806 #if defined(HAS_LONG_DOUBLE)
8807                 break;
8808 #else
8809                 /* FALL THROUGH */
8810 #endif
8811             case 'h':
8812                 goto unknown;
8813             }
8814
8815             /* now we need (long double) if intsize == 'q', else (double) */
8816             nv = (args && !vectorize) ?
8817 #if LONG_DOUBLESIZE > DOUBLESIZE
8818                 intsize == 'q' ?
8819                     va_arg(*args, long double) :
8820                     va_arg(*args, double)
8821 #else
8822                     va_arg(*args, double)
8823 #endif
8824                 : SvNVx(argsv);
8825
8826             need = 0;
8827             vectorize = FALSE;
8828             if (c != 'e' && c != 'E') {
8829                 i = PERL_INT_MIN;
8830                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
8831                    will cast our (long double) to (double) */
8832                 (void)Perl_frexp(nv, &i);
8833                 if (i == PERL_INT_MIN)
8834                     Perl_die(aTHX_ "panic: frexp");
8835                 if (i > 0)
8836                     need = BIT_DIGITS(i);
8837             }
8838             need += has_precis ? precis : 6; /* known default */
8839
8840             if (need < width)
8841                 need = width;
8842
8843 #ifdef HAS_LDBL_SPRINTF_BUG
8844             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8845                with sfio - Allen <allens@cpan.org> */
8846
8847 #  ifdef DBL_MAX
8848 #    define MY_DBL_MAX DBL_MAX
8849 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
8850 #    if DOUBLESIZE >= 8
8851 #      define MY_DBL_MAX 1.7976931348623157E+308L
8852 #    else
8853 #      define MY_DBL_MAX 3.40282347E+38L
8854 #    endif
8855 #  endif
8856
8857 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
8858 #    define MY_DBL_MAX_BUG 1L
8859 #  else
8860 #    define MY_DBL_MAX_BUG MY_DBL_MAX
8861 #  endif
8862
8863 #  ifdef DBL_MIN
8864 #    define MY_DBL_MIN DBL_MIN
8865 #  else  /* XXX guessing! -Allen */
8866 #    if DOUBLESIZE >= 8
8867 #      define MY_DBL_MIN 2.2250738585072014E-308L
8868 #    else
8869 #      define MY_DBL_MIN 1.17549435E-38L
8870 #    endif
8871 #  endif
8872
8873             if ((intsize == 'q') && (c == 'f') &&
8874                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
8875                 (need < DBL_DIG)) {
8876                 /* it's going to be short enough that
8877                  * long double precision is not needed */
8878
8879                 if ((nv <= 0L) && (nv >= -0L))
8880                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
8881                 else {
8882                     /* would use Perl_fp_class as a double-check but not
8883                      * functional on IRIX - see perl.h comments */
8884
8885                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
8886                         /* It's within the range that a double can represent */
8887 #if defined(DBL_MAX) && !defined(DBL_MIN)
8888                         if ((nv >= ((long double)1/DBL_MAX)) ||
8889                             (nv <= (-(long double)1/DBL_MAX)))
8890 #endif
8891                         fix_ldbl_sprintf_bug = TRUE;
8892                     }
8893                 }
8894                 if (fix_ldbl_sprintf_bug == TRUE) {
8895                     double temp;
8896
8897                     intsize = 0;
8898                     temp = (double)nv;
8899                     nv = (NV)temp;
8900                 }
8901             }
8902
8903 #  undef MY_DBL_MAX
8904 #  undef MY_DBL_MAX_BUG
8905 #  undef MY_DBL_MIN
8906
8907 #endif /* HAS_LDBL_SPRINTF_BUG */
8908
8909             need += 20; /* fudge factor */
8910             if (PL_efloatsize < need) {
8911                 Safefree(PL_efloatbuf);
8912                 PL_efloatsize = need + 20; /* more fudge */
8913                 New(906, PL_efloatbuf, PL_efloatsize, char);
8914                 PL_efloatbuf[0] = '\0';
8915             }
8916
8917             eptr = ebuf + sizeof ebuf;
8918             *--eptr = '\0';
8919             *--eptr = c;
8920             /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
8921 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8922             if (intsize == 'q') {
8923                 /* Copy the one or more characters in a long double
8924                  * format before the 'base' ([efgEFG]) character to
8925                  * the format string. */
8926                 static char const prifldbl[] = PERL_PRIfldbl;
8927                 char const *p = prifldbl + sizeof(prifldbl) - 3;
8928                 while (p >= prifldbl) { *--eptr = *p--; }
8929             }
8930 #endif
8931             if (has_precis) {
8932                 base = precis;
8933                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8934                 *--eptr = '.';
8935             }
8936             if (width) {
8937                 base = width;
8938                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8939             }
8940             if (fill == '0')
8941                 *--eptr = fill;
8942             if (left)
8943                 *--eptr = '-';
8944             if (plus)
8945                 *--eptr = plus;
8946             if (alt)
8947                 *--eptr = '#';
8948             *--eptr = '%';
8949
8950             /* No taint.  Otherwise we are in the strange situation
8951              * where printf() taints but print($float) doesn't.
8952              * --jhi */
8953 #if defined(HAS_LONG_DOUBLE)
8954             if (intsize == 'q')
8955                 (void)sprintf(PL_efloatbuf, eptr, nv);
8956             else
8957                 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
8958 #else
8959             (void)sprintf(PL_efloatbuf, eptr, nv);
8960 #endif
8961             eptr = PL_efloatbuf;
8962             elen = strlen(PL_efloatbuf);
8963             break;
8964
8965             /* SPECIAL */
8966
8967         case 'n':
8968             i = SvCUR(sv) - origlen;
8969             if (args && !vectorize) {
8970                 switch (intsize) {
8971                 case 'h':       *(va_arg(*args, short*)) = i; break;
8972                 default:        *(va_arg(*args, int*)) = i; break;
8973                 case 'l':       *(va_arg(*args, long*)) = i; break;
8974                 case 'V':       *(va_arg(*args, IV*)) = i; break;
8975 #ifdef HAS_QUAD
8976                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
8977 #endif
8978                 }
8979             }
8980             else
8981                 sv_setuv_mg(argsv, (UV)i);
8982             vectorize = FALSE;
8983             continue;   /* not "break" */
8984
8985             /* UNKNOWN */
8986
8987         default:
8988       unknown:
8989             if (!args && ckWARN(WARN_PRINTF) &&
8990                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8991                 SV *msg = sv_newmortal();
8992                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
8993                           (PL_op->op_type == OP_PRTF) ? "" : "s");
8994                 if (c) {
8995                     if (isPRINT(c))
8996                         Perl_sv_catpvf(aTHX_ msg,
8997                                        "\"%%%c\"", c & 0xFF);
8998                     else
8999                         Perl_sv_catpvf(aTHX_ msg,
9000                                        "\"%%\\%03"UVof"\"",
9001                                        (UV)c & 0xFF);
9002                 } else
9003                     sv_catpv(msg, "end of string");
9004                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9005             }
9006
9007             /* output mangled stuff ... */
9008             if (c == '\0')
9009                 --q;
9010             eptr = p;
9011             elen = q - p;
9012
9013             /* ... right here, because formatting flags should not apply */
9014             SvGROW(sv, SvCUR(sv) + elen + 1);
9015             p = SvEND(sv);
9016             Copy(eptr, p, elen, char);
9017             p += elen;
9018             *p = '\0';
9019             SvCUR(sv) = p - SvPVX(sv);
9020             svix = osvix;
9021             continue;   /* not "break" */
9022         }
9023
9024         if (is_utf8 != has_utf8) {
9025              if (is_utf8) {
9026                   if (SvCUR(sv))
9027                        sv_utf8_upgrade(sv);
9028              }
9029              else {
9030                   SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
9031                   sv_utf8_upgrade(nsv);
9032                   eptr = SvPVX(nsv);
9033                   elen = SvCUR(nsv);
9034              }
9035              SvGROW(sv, SvCUR(sv) + elen + 1);
9036              p = SvEND(sv);
9037              *p = '\0';
9038         }
9039         if (left && ckWARN(WARN_PRINTF) && strchr(eptr, '\n') &&
9040             (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
9041             Perl_warner(aTHX_ packWARN(WARN_PRINTF),
9042                 "Newline in left-justified string for %sprintf",
9043                         (PL_op->op_type == OP_PRTF) ? "" : "s");
9044
9045         have = esignlen + zeros + elen;
9046         need = (have > width ? have : width);
9047         gap = need - have;
9048
9049         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9050         p = SvEND(sv);
9051         if (esignlen && fill == '0') {
9052             for (i = 0; i < (int)esignlen; i++)
9053                 *p++ = esignbuf[i];
9054         }
9055         if (gap && !left) {
9056             memset(p, fill, gap);
9057             p += gap;
9058         }
9059         if (esignlen && fill != '0') {
9060             for (i = 0; i < (int)esignlen; i++)
9061                 *p++ = esignbuf[i];
9062         }
9063         if (zeros) {
9064             for (i = zeros; i; i--)
9065                 *p++ = '0';
9066         }
9067         if (elen) {
9068             Copy(eptr, p, elen, char);
9069             p += elen;
9070         }
9071         if (gap && left) {
9072             memset(p, ' ', gap);
9073             p += gap;
9074         }
9075         if (vectorize) {
9076             if (veclen) {
9077                 Copy(dotstr, p, dotstrlen, char);
9078                 p += dotstrlen;
9079             }
9080             else
9081                 vectorize = FALSE;              /* done iterating over vecstr */
9082         }
9083         if (is_utf8)
9084             has_utf8 = TRUE;
9085         if (has_utf8)
9086             SvUTF8_on(sv);
9087         *p = '\0';
9088         SvCUR(sv) = p - SvPVX(sv);
9089         if (vectorize) {
9090             esignlen = 0;
9091             goto vector;
9092         }
9093     }
9094 }
9095
9096 /* =========================================================================
9097
9098 =head1 Cloning an interpreter
9099
9100 All the macros and functions in this section are for the private use of
9101 the main function, perl_clone().
9102
9103 The foo_dup() functions make an exact copy of an existing foo thinngy.
9104 During the course of a cloning, a hash table is used to map old addresses
9105 to new addresses. The table is created and manipulated with the
9106 ptr_table_* functions.
9107
9108 =cut
9109
9110 ============================================================================*/
9111
9112
9113 #if defined(USE_ITHREADS)
9114
9115 #if defined(USE_5005THREADS)
9116 #  include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
9117 #endif
9118
9119 #ifndef GpREFCNT_inc
9120 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9121 #endif
9122
9123
9124 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9125 #define av_dup(s,t)     (AV*)sv_dup((SV*)s,t)
9126 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9127 #define hv_dup(s,t)     (HV*)sv_dup((SV*)s,t)
9128 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9129 #define cv_dup(s,t)     (CV*)sv_dup((SV*)s,t)
9130 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9131 #define io_dup(s,t)     (IO*)sv_dup((SV*)s,t)
9132 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9133 #define gv_dup(s,t)     (GV*)sv_dup((SV*)s,t)
9134 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9135 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
9136 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
9137
9138
9139 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9140    regcomp.c. AMS 20010712 */
9141
9142 REGEXP *
9143 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
9144 {
9145     REGEXP *ret;
9146     int i, len, npar;
9147     struct reg_substr_datum *s;
9148
9149     if (!r)
9150         return (REGEXP *)NULL;
9151
9152     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9153         return ret;
9154
9155     len = r->offsets[0];
9156     npar = r->nparens+1;
9157
9158     Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9159     Copy(r->program, ret->program, len+1, regnode);
9160
9161     New(0, ret->startp, npar, I32);
9162     Copy(r->startp, ret->startp, npar, I32);
9163     New(0, ret->endp, npar, I32);
9164     Copy(r->startp, ret->startp, npar, I32);
9165
9166     New(0, ret->substrs, 1, struct reg_substr_data);
9167     for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9168         s->min_offset = r->substrs->data[i].min_offset;
9169         s->max_offset = r->substrs->data[i].max_offset;
9170         s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
9171         s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9172     }
9173
9174     ret->regstclass = NULL;
9175     if (r->data) {
9176         struct reg_data *d;
9177         int count = r->data->count;
9178
9179         Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
9180                 char, struct reg_data);
9181         New(0, d->what, count, U8);
9182
9183         d->count = count;
9184         for (i = 0; i < count; i++) {
9185             d->what[i] = r->data->what[i];
9186             switch (d->what[i]) {
9187             case 's':
9188                 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9189                 break;
9190             case 'p':
9191                 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9192                 break;
9193             case 'f':
9194                 /* This is cheating. */
9195                 New(0, d->data[i], 1, struct regnode_charclass_class);
9196                 StructCopy(r->data->data[i], d->data[i],
9197                             struct regnode_charclass_class);
9198                 ret->regstclass = (regnode*)d->data[i];
9199                 break;
9200             case 'o':
9201                 /* Compiled op trees are readonly, and can thus be
9202                    shared without duplication. */
9203                 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9204                 break;
9205             case 'n':
9206                 d->data[i] = r->data->data[i];
9207                 break;
9208             }
9209         }
9210
9211         ret->data = d;
9212     }
9213     else
9214         ret->data = NULL;
9215
9216     New(0, ret->offsets, 2*len+1, U32);
9217     Copy(r->offsets, ret->offsets, 2*len+1, U32);
9218
9219     ret->precomp        = SAVEPV(r->precomp);
9220     ret->refcnt         = r->refcnt;
9221     ret->minlen         = r->minlen;
9222     ret->prelen         = r->prelen;
9223     ret->nparens        = r->nparens;
9224     ret->lastparen      = r->lastparen;
9225     ret->lastcloseparen = r->lastcloseparen;
9226     ret->reganch        = r->reganch;
9227
9228     ret->sublen         = r->sublen;
9229
9230     if (RX_MATCH_COPIED(ret))
9231         ret->subbeg  = SAVEPV(r->subbeg);
9232     else
9233         ret->subbeg = Nullch;
9234
9235     ptr_table_store(PL_ptr_table, r, ret);
9236     return ret;
9237 }
9238
9239 /* duplicate a file handle */
9240
9241 PerlIO *
9242 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9243 {
9244     PerlIO *ret;
9245     if (!fp)
9246         return (PerlIO*)NULL;
9247
9248     /* look for it in the table first */
9249     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9250     if (ret)
9251         return ret;
9252
9253     /* create anew and remember what it is */
9254     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9255     ptr_table_store(PL_ptr_table, fp, ret);
9256     return ret;
9257 }
9258
9259 /* duplicate a directory handle */
9260
9261 DIR *
9262 Perl_dirp_dup(pTHX_ DIR *dp)
9263 {
9264     if (!dp)
9265         return (DIR*)NULL;
9266     /* XXX TODO */
9267     return dp;
9268 }
9269
9270 /* duplicate a typeglob */
9271
9272 GP *
9273 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9274 {
9275     GP *ret;
9276     if (!gp)
9277         return (GP*)NULL;
9278     /* look for it in the table first */
9279     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9280     if (ret)
9281         return ret;
9282
9283     /* create anew and remember what it is */
9284     Newz(0, ret, 1, GP);
9285     ptr_table_store(PL_ptr_table, gp, ret);
9286
9287     /* clone */
9288     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
9289     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
9290     ret->gp_io          = io_dup_inc(gp->gp_io, param);
9291     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
9292     ret->gp_av          = av_dup_inc(gp->gp_av, param);
9293     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
9294     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9295     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
9296     ret->gp_cvgen       = gp->gp_cvgen;
9297     ret->gp_flags       = gp->gp_flags;
9298     ret->gp_line        = gp->gp_line;
9299     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
9300     return ret;
9301 }
9302
9303 /* duplicate a chain of magic */
9304
9305 MAGIC *
9306 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9307 {
9308     MAGIC *mgprev = (MAGIC*)NULL;
9309     MAGIC *mgret;
9310     if (!mg)
9311         return (MAGIC*)NULL;
9312     /* look for it in the table first */
9313     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9314     if (mgret)
9315         return mgret;
9316
9317     for (; mg; mg = mg->mg_moremagic) {
9318         MAGIC *nmg;
9319         Newz(0, nmg, 1, MAGIC);
9320         if (mgprev)
9321             mgprev->mg_moremagic = nmg;
9322         else
9323             mgret = nmg;
9324         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
9325         nmg->mg_private = mg->mg_private;
9326         nmg->mg_type    = mg->mg_type;
9327         nmg->mg_flags   = mg->mg_flags;
9328         if (mg->mg_type == PERL_MAGIC_qr) {
9329             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9330         }
9331         else if(mg->mg_type == PERL_MAGIC_backref) {
9332              AV *av = (AV*) mg->mg_obj;
9333              SV **svp;
9334              I32 i;
9335              nmg->mg_obj = (SV*)newAV();
9336              svp = AvARRAY(av);
9337              i = AvFILLp(av);
9338              while (i >= 0) {
9339                   av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9340                   i--;
9341              }
9342         }
9343         else {
9344             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9345                               ? sv_dup_inc(mg->mg_obj, param)
9346                               : sv_dup(mg->mg_obj, param);
9347         }
9348         nmg->mg_len     = mg->mg_len;
9349         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
9350         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9351             if (mg->mg_len > 0) {
9352                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
9353                 if (mg->mg_type == PERL_MAGIC_overload_table &&
9354                         AMT_AMAGIC((AMT*)mg->mg_ptr))
9355                 {
9356                     AMT *amtp = (AMT*)mg->mg_ptr;
9357                     AMT *namtp = (AMT*)nmg->mg_ptr;
9358                     I32 i;
9359                     for (i = 1; i < NofAMmeth; i++) {
9360                         namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9361                     }
9362                 }
9363             }
9364             else if (mg->mg_len == HEf_SVKEY)
9365                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9366         }
9367         if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9368             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9369         }
9370         mgprev = nmg;
9371     }
9372     return mgret;
9373 }
9374
9375 /* create a new pointer-mapping table */
9376
9377 PTR_TBL_t *
9378 Perl_ptr_table_new(pTHX)
9379 {
9380     PTR_TBL_t *tbl;
9381     Newz(0, tbl, 1, PTR_TBL_t);
9382     tbl->tbl_max        = 511;
9383     tbl->tbl_items      = 0;
9384     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9385     return tbl;
9386 }
9387
9388 /* map an existing pointer using a table */
9389
9390 void *
9391 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
9392 {
9393     PTR_TBL_ENT_t *tblent;
9394     UV hash = PTR2UV(sv);
9395     assert(tbl);
9396     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9397     for (; tblent; tblent = tblent->next) {
9398         if (tblent->oldval == sv)
9399             return tblent->newval;
9400     }
9401     return (void*)NULL;
9402 }
9403
9404 /* add a new entry to a pointer-mapping table */
9405
9406 void
9407 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
9408 {
9409     PTR_TBL_ENT_t *tblent, **otblent;
9410     /* XXX this may be pessimal on platforms where pointers aren't good
9411      * hash values e.g. if they grow faster in the most significant
9412      * bits */
9413     UV hash = PTR2UV(oldv);
9414     bool i = 1;
9415
9416     assert(tbl);
9417     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9418     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
9419         if (tblent->oldval == oldv) {
9420             tblent->newval = newv;
9421             return;
9422         }
9423     }
9424     Newz(0, tblent, 1, PTR_TBL_ENT_t);
9425     tblent->oldval = oldv;
9426     tblent->newval = newv;
9427     tblent->next = *otblent;
9428     *otblent = tblent;
9429     tbl->tbl_items++;
9430     if (i && tbl->tbl_items > tbl->tbl_max)
9431         ptr_table_split(tbl);
9432 }
9433
9434 /* double the hash bucket size of an existing ptr table */
9435
9436 void
9437 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9438 {
9439     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9440     UV oldsize = tbl->tbl_max + 1;
9441     UV newsize = oldsize * 2;
9442     UV i;
9443
9444     Renew(ary, newsize, PTR_TBL_ENT_t*);
9445     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9446     tbl->tbl_max = --newsize;
9447     tbl->tbl_ary = ary;
9448     for (i=0; i < oldsize; i++, ary++) {
9449         PTR_TBL_ENT_t **curentp, **entp, *ent;
9450         if (!*ary)
9451             continue;
9452         curentp = ary + oldsize;
9453         for (entp = ary, ent = *ary; ent; ent = *entp) {
9454             if ((newsize & PTR2UV(ent->oldval)) != i) {
9455                 *entp = ent->next;
9456                 ent->next = *curentp;
9457                 *curentp = ent;
9458                 continue;
9459             }
9460             else
9461                 entp = &ent->next;
9462         }
9463     }
9464 }
9465
9466 /* remove all the entries from a ptr table */
9467
9468 void
9469 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9470 {
9471     register PTR_TBL_ENT_t **array;
9472     register PTR_TBL_ENT_t *entry;
9473     register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
9474     UV riter = 0;
9475     UV max;
9476
9477     if (!tbl || !tbl->tbl_items) {
9478         return;
9479     }
9480
9481     array = tbl->tbl_ary;
9482     entry = array[0];
9483     max = tbl->tbl_max;
9484
9485     for (;;) {
9486         if (entry) {
9487             oentry = entry;
9488             entry = entry->next;
9489             Safefree(oentry);
9490         }
9491         if (!entry) {
9492             if (++riter > max) {
9493                 break;
9494             }
9495             entry = array[riter];
9496         }
9497     }
9498
9499     tbl->tbl_items = 0;
9500 }
9501
9502 /* clear and free a ptr table */
9503
9504 void
9505 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9506 {
9507     if (!tbl) {
9508         return;
9509     }
9510     ptr_table_clear(tbl);
9511     Safefree(tbl->tbl_ary);
9512     Safefree(tbl);
9513 }
9514
9515 #ifdef DEBUGGING
9516 char *PL_watch_pvx;
9517 #endif
9518
9519 /* attempt to make everything in the typeglob readonly */
9520
9521 STATIC SV *
9522 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
9523 {
9524     GV *gv = (GV*)sstr;
9525     SV *sv = &param->proto_perl->Isv_no; /* just need SvREADONLY-ness */
9526
9527     if (GvIO(gv) || GvFORM(gv)) {
9528         GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
9529     }
9530     else if (!GvCV(gv)) {
9531         GvCV(gv) = (CV*)sv;
9532     }
9533     else {
9534         /* CvPADLISTs cannot be shared */
9535         if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
9536             GvUNIQUE_off(gv);
9537         }
9538     }
9539
9540     if (!GvUNIQUE(gv)) {
9541 #if 0
9542         PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
9543                       HvNAME(GvSTASH(gv)), GvNAME(gv));
9544 #endif
9545         return Nullsv;
9546     }
9547
9548     /*
9549      * write attempts will die with
9550      * "Modification of a read-only value attempted"
9551      */
9552     if (!GvSV(gv)) {
9553         GvSV(gv) = sv;
9554     }
9555     else {
9556         SvREADONLY_on(GvSV(gv));
9557     }
9558
9559     if (!GvAV(gv)) {
9560         GvAV(gv) = (AV*)sv;
9561     }
9562     else {
9563         SvREADONLY_on(GvAV(gv));
9564     }
9565
9566     if (!GvHV(gv)) {
9567         GvHV(gv) = (HV*)sv;
9568     }
9569     else {
9570         SvREADONLY_on(GvAV(gv));
9571     }
9572
9573     return sstr; /* he_dup() will SvREFCNT_inc() */
9574 }
9575
9576 /* duplicate an SV of any type (including AV, HV etc) */
9577
9578 void
9579 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9580 {
9581     if (SvROK(sstr)) {
9582         SvRV(dstr) = SvWEAKREF(sstr)
9583                      ? sv_dup(SvRV(sstr), param)
9584                      : sv_dup_inc(SvRV(sstr), param);
9585     }
9586     else if (SvPVX(sstr)) {
9587         /* Has something there */
9588         if (SvLEN(sstr)) {
9589             /* Normal PV - clone whole allocated space */
9590             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9591         }
9592         else {
9593             /* Special case - not normally malloced for some reason */
9594             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9595                 /* A "shared" PV - clone it as unshared string */
9596                 if(SvPADTMP(sstr)) {
9597                     /* However, some of them live in the pad
9598                        and they should not have these flags
9599                        turned off */
9600
9601                     SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
9602                                            SvUVX(sstr));
9603                     SvUVX(dstr) = SvUVX(sstr);
9604                 } else {
9605
9606                     SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
9607                     SvFAKE_off(dstr);
9608                     SvREADONLY_off(dstr);
9609                 }
9610             }
9611             else {
9612                 /* Some other special case - random pointer */
9613                 SvPVX(dstr) = SvPVX(sstr);
9614             }
9615         }
9616     }
9617     else {
9618         /* Copy the Null */
9619         SvPVX(dstr) = SvPVX(sstr);
9620     }
9621 }
9622
9623 SV *
9624 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9625 {
9626     SV *dstr;
9627
9628     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9629         return Nullsv;
9630     /* look for it in the table first */
9631     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9632     if (dstr)
9633         return dstr;
9634
9635     if(param->flags & CLONEf_JOIN_IN) {
9636         /** We are joining here so we don't want do clone
9637             something that is bad **/
9638
9639         if(SvTYPE(sstr) == SVt_PVHV &&
9640            HvNAME(sstr)) {
9641             /** don't clone stashes if they already exist **/
9642             HV* old_stash = gv_stashpv(HvNAME(sstr),0);
9643             return (SV*) old_stash;
9644         }
9645     }
9646
9647     /* create anew and remember what it is */
9648     new_SV(dstr);
9649     ptr_table_store(PL_ptr_table, sstr, dstr);
9650
9651     /* clone */
9652     SvFLAGS(dstr)       = SvFLAGS(sstr);
9653     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
9654     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
9655
9656 #ifdef DEBUGGING
9657     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
9658         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9659                       PL_watch_pvx, SvPVX(sstr));
9660 #endif
9661
9662     switch (SvTYPE(sstr)) {
9663     case SVt_NULL:
9664         SvANY(dstr)     = NULL;
9665         break;
9666     case SVt_IV:
9667         SvANY(dstr)     = new_XIV();
9668         SvIVX(dstr)     = SvIVX(sstr);
9669         break;
9670     case SVt_NV:
9671         SvANY(dstr)     = new_XNV();
9672         SvNVX(dstr)     = SvNVX(sstr);
9673         break;
9674     case SVt_RV:
9675         SvANY(dstr)     = new_XRV();
9676         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9677         break;
9678     case SVt_PV:
9679         SvANY(dstr)     = new_XPV();
9680         SvCUR(dstr)     = SvCUR(sstr);
9681         SvLEN(dstr)     = SvLEN(sstr);
9682         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9683         break;
9684     case SVt_PVIV:
9685         SvANY(dstr)     = new_XPVIV();
9686         SvCUR(dstr)     = SvCUR(sstr);
9687         SvLEN(dstr)     = SvLEN(sstr);
9688         SvIVX(dstr)     = SvIVX(sstr);
9689         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9690         break;
9691     case SVt_PVNV:
9692         SvANY(dstr)     = new_XPVNV();
9693         SvCUR(dstr)     = SvCUR(sstr);
9694         SvLEN(dstr)     = SvLEN(sstr);
9695         SvIVX(dstr)     = SvIVX(sstr);
9696         SvNVX(dstr)     = SvNVX(sstr);
9697         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9698         break;
9699     case SVt_PVMG:
9700         SvANY(dstr)     = new_XPVMG();
9701         SvCUR(dstr)     = SvCUR(sstr);
9702         SvLEN(dstr)     = SvLEN(sstr);
9703         SvIVX(dstr)     = SvIVX(sstr);
9704         SvNVX(dstr)     = SvNVX(sstr);
9705         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9706         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9707         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9708         break;
9709     case SVt_PVBM:
9710         SvANY(dstr)     = new_XPVBM();
9711         SvCUR(dstr)     = SvCUR(sstr);
9712         SvLEN(dstr)     = SvLEN(sstr);
9713         SvIVX(dstr)     = SvIVX(sstr);
9714         SvNVX(dstr)     = SvNVX(sstr);
9715         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9716         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9717         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9718         BmRARE(dstr)    = BmRARE(sstr);
9719         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
9720         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
9721         break;
9722     case SVt_PVLV:
9723         SvANY(dstr)     = new_XPVLV();
9724         SvCUR(dstr)     = SvCUR(sstr);
9725         SvLEN(dstr)     = SvLEN(sstr);
9726         SvIVX(dstr)     = SvIVX(sstr);
9727         SvNVX(dstr)     = SvNVX(sstr);
9728         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9729         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9730         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9731         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
9732         LvTARGLEN(dstr) = LvTARGLEN(sstr);
9733         if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
9734             LvTARG(dstr) = dstr;
9735         else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
9736             LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
9737         else
9738             LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
9739         LvTYPE(dstr)    = LvTYPE(sstr);
9740         break;
9741     case SVt_PVGV:
9742         if (GvUNIQUE((GV*)sstr)) {
9743             SV *share;
9744             if ((share = gv_share(sstr, param))) {
9745                 del_SV(dstr);
9746                 dstr = share;
9747                 ptr_table_store(PL_ptr_table, sstr, dstr);
9748 #if 0
9749                 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
9750                               HvNAME(GvSTASH(share)), GvNAME(share));
9751 #endif
9752                 break;
9753             }
9754         }
9755         SvANY(dstr)     = new_XPVGV();
9756         SvCUR(dstr)     = SvCUR(sstr);
9757         SvLEN(dstr)     = SvLEN(sstr);
9758         SvIVX(dstr)     = SvIVX(sstr);
9759         SvNVX(dstr)     = SvNVX(sstr);
9760         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9761         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9762         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9763         GvNAMELEN(dstr) = GvNAMELEN(sstr);
9764         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
9765         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr), param);
9766         GvFLAGS(dstr)   = GvFLAGS(sstr);
9767         GvGP(dstr)      = gp_dup(GvGP(sstr), param);
9768         (void)GpREFCNT_inc(GvGP(dstr));
9769         break;
9770     case SVt_PVIO:
9771         SvANY(dstr)     = new_XPVIO();
9772         SvCUR(dstr)     = SvCUR(sstr);
9773         SvLEN(dstr)     = SvLEN(sstr);
9774         SvIVX(dstr)     = SvIVX(sstr);
9775         SvNVX(dstr)     = SvNVX(sstr);
9776         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9777         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9778         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9779         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
9780         if (IoOFP(sstr) == IoIFP(sstr))
9781             IoOFP(dstr) = IoIFP(dstr);
9782         else
9783             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
9784         /* PL_rsfp_filters entries have fake IoDIRP() */
9785         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
9786             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
9787         else
9788             IoDIRP(dstr)        = IoDIRP(sstr);
9789         IoLINES(dstr)           = IoLINES(sstr);
9790         IoPAGE(dstr)            = IoPAGE(sstr);
9791         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
9792         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
9793         if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
9794             /* I have no idea why fake dirp (rsfps)
9795                should be treaded differently but otherwise
9796                we end up with leaks -- sky*/
9797             IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(sstr), param);
9798             IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(sstr), param);
9799             IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(sstr), param);
9800         } else {
9801             IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(sstr), param);
9802             IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(sstr), param);
9803             IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(sstr), param);
9804         }
9805         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
9806         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
9807         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
9808         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
9809         IoTYPE(dstr)            = IoTYPE(sstr);
9810         IoFLAGS(dstr)           = IoFLAGS(sstr);
9811         break;
9812     case SVt_PVAV:
9813         SvANY(dstr)     = new_XPVAV();
9814         SvCUR(dstr)     = SvCUR(sstr);
9815         SvLEN(dstr)     = SvLEN(sstr);
9816         SvIVX(dstr)     = SvIVX(sstr);
9817         SvNVX(dstr)     = SvNVX(sstr);
9818         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9819         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9820         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9821         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9822         if (AvARRAY((AV*)sstr)) {
9823             SV **dst_ary, **src_ary;
9824             SSize_t items = AvFILLp((AV*)sstr) + 1;
9825
9826             src_ary = AvARRAY((AV*)sstr);
9827             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9828             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9829             SvPVX(dstr) = (char*)dst_ary;
9830             AvALLOC((AV*)dstr) = dst_ary;
9831             if (AvREAL((AV*)sstr)) {
9832                 while (items-- > 0)
9833                     *dst_ary++ = sv_dup_inc(*src_ary++, param);
9834             }
9835             else {
9836                 while (items-- > 0)
9837                     *dst_ary++ = sv_dup(*src_ary++, param);
9838             }
9839             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9840             while (items-- > 0) {
9841                 *dst_ary++ = &PL_sv_undef;
9842             }
9843         }
9844         else {
9845             SvPVX(dstr)         = Nullch;
9846             AvALLOC((AV*)dstr)  = (SV**)NULL;
9847         }
9848         break;
9849     case SVt_PVHV:
9850         SvANY(dstr)     = new_XPVHV();
9851         SvCUR(dstr)     = SvCUR(sstr);
9852         SvLEN(dstr)     = SvLEN(sstr);
9853         SvIVX(dstr)     = SvIVX(sstr);
9854         SvNVX(dstr)     = SvNVX(sstr);
9855         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9856         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9857         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
9858         if (HvARRAY((HV*)sstr)) {
9859             STRLEN i = 0;
9860             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9861             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9862             Newz(0, dxhv->xhv_array,
9863                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9864             while (i <= sxhv->xhv_max) {
9865                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9866                                                     (bool)!!HvSHAREKEYS(sstr),
9867                                                     param);
9868                 ++i;
9869             }
9870             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
9871                                      (bool)!!HvSHAREKEYS(sstr), param);
9872         }
9873         else {
9874             SvPVX(dstr)         = Nullch;
9875             HvEITER((HV*)dstr)  = (HE*)NULL;
9876         }
9877         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
9878         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
9879     /* Record stashes for possible cloning in Perl_clone(). */
9880         if(HvNAME((HV*)dstr))
9881             av_push(param->stashes, dstr);
9882         break;
9883     case SVt_PVFM:
9884         SvANY(dstr)     = new_XPVFM();
9885         FmLINES(dstr)   = FmLINES(sstr);
9886         goto dup_pvcv;
9887         /* NOTREACHED */
9888     case SVt_PVCV:
9889         SvANY(dstr)     = new_XPVCV();
9890         dup_pvcv:
9891         SvCUR(dstr)     = SvCUR(sstr);
9892         SvLEN(dstr)     = SvLEN(sstr);
9893         SvIVX(dstr)     = SvIVX(sstr);
9894         SvNVX(dstr)     = SvNVX(sstr);
9895         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9896         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9897         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9898         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9899         CvSTART(dstr)   = CvSTART(sstr);
9900         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
9901         CvXSUB(dstr)    = CvXSUB(sstr);
9902         CvXSUBANY(dstr) = CvXSUBANY(sstr);
9903         if (CvCONST(sstr)) {
9904             CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9905                 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9906                 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9907         }
9908         CvGV(dstr)      = gv_dup(CvGV(sstr), param);
9909         if (param->flags & CLONEf_COPY_STACKS) {
9910           CvDEPTH(dstr) = CvDEPTH(sstr);
9911         } else {
9912           CvDEPTH(dstr) = 0;
9913         }
9914         PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
9915         CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
9916         CvOUTSIDE(dstr) =
9917                 CvWEAKOUTSIDE(sstr)
9918                         ? cv_dup(    CvOUTSIDE(sstr), param)
9919                         : cv_dup_inc(CvOUTSIDE(sstr), param);
9920         CvFLAGS(dstr)   = CvFLAGS(sstr);
9921         CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9922         break;
9923     default:
9924         Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
9925         break;
9926     }
9927
9928     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9929         ++PL_sv_objcount;
9930
9931     return dstr;
9932  }
9933
9934 /* duplicate a context */
9935
9936 PERL_CONTEXT *
9937 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9938 {
9939     PERL_CONTEXT *ncxs;
9940
9941     if (!cxs)
9942         return (PERL_CONTEXT*)NULL;
9943
9944     /* look for it in the table first */
9945     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9946     if (ncxs)
9947         return ncxs;
9948
9949     /* create anew and remember what it is */
9950     Newz(56, ncxs, max + 1, PERL_CONTEXT);
9951     ptr_table_store(PL_ptr_table, cxs, ncxs);
9952
9953     while (ix >= 0) {
9954         PERL_CONTEXT *cx = &cxs[ix];
9955         PERL_CONTEXT *ncx = &ncxs[ix];
9956         ncx->cx_type    = cx->cx_type;
9957         if (CxTYPE(cx) == CXt_SUBST) {
9958             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9959         }
9960         else {
9961             ncx->blk_oldsp      = cx->blk_oldsp;
9962             ncx->blk_oldcop     = cx->blk_oldcop;
9963             ncx->blk_oldretsp   = cx->blk_oldretsp;
9964             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
9965             ncx->blk_oldscopesp = cx->blk_oldscopesp;
9966             ncx->blk_oldpm      = cx->blk_oldpm;
9967             ncx->blk_gimme      = cx->blk_gimme;
9968             switch (CxTYPE(cx)) {
9969             case CXt_SUB:
9970                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
9971                                            ? cv_dup_inc(cx->blk_sub.cv, param)
9972                                            : cv_dup(cx->blk_sub.cv,param));
9973                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
9974                                            ? av_dup_inc(cx->blk_sub.argarray, param)
9975                                            : Nullav);
9976                 ncx->blk_sub.savearray  = av_dup_inc(cx->blk_sub.savearray, param);
9977                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
9978                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
9979                 ncx->blk_sub.lval       = cx->blk_sub.lval;
9980                 break;
9981             case CXt_EVAL:
9982                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9983                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9984                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
9985                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9986                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text, param);
9987                 break;
9988             case CXt_LOOP:
9989                 ncx->blk_loop.label     = cx->blk_loop.label;
9990                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
9991                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
9992                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
9993                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
9994                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
9995                                            ? cx->blk_loop.iterdata
9996                                            : gv_dup((GV*)cx->blk_loop.iterdata, param));
9997                 ncx->blk_loop.oldcomppad
9998                     = (PAD*)ptr_table_fetch(PL_ptr_table,
9999                                             cx->blk_loop.oldcomppad);
10000                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave, param);
10001                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval, param);
10002                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary, param);
10003                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
10004                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
10005                 break;
10006             case CXt_FORMAT:
10007                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv, param);
10008                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv, param);
10009                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10010                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
10011                 break;
10012             case CXt_BLOCK:
10013             case CXt_NULL:
10014                 break;
10015             }
10016         }
10017         --ix;
10018     }
10019     return ncxs;
10020 }
10021
10022 /* duplicate a stack info structure */
10023
10024 PERL_SI *
10025 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10026 {
10027     PERL_SI *nsi;
10028
10029     if (!si)
10030         return (PERL_SI*)NULL;
10031
10032     /* look for it in the table first */
10033     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10034     if (nsi)
10035         return nsi;
10036
10037     /* create anew and remember what it is */
10038     Newz(56, nsi, 1, PERL_SI);
10039     ptr_table_store(PL_ptr_table, si, nsi);
10040
10041     nsi->si_stack       = av_dup_inc(si->si_stack, param);
10042     nsi->si_cxix        = si->si_cxix;
10043     nsi->si_cxmax       = si->si_cxmax;
10044     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10045     nsi->si_type        = si->si_type;
10046     nsi->si_prev        = si_dup(si->si_prev, param);
10047     nsi->si_next        = si_dup(si->si_next, param);
10048     nsi->si_markoff     = si->si_markoff;
10049
10050     return nsi;
10051 }
10052
10053 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
10054 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
10055 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
10056 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
10057 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
10058 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
10059 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
10060 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
10061 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
10062 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
10063 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
10064 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
10065 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10066 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10067
10068 /* XXXXX todo */
10069 #define pv_dup_inc(p)   SAVEPV(p)
10070 #define pv_dup(p)       SAVEPV(p)
10071 #define svp_dup_inc(p,pp)       any_dup(p,pp)
10072
10073 /* map any object to the new equivent - either something in the
10074  * ptr table, or something in the interpreter structure
10075  */
10076
10077 void *
10078 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
10079 {
10080     void *ret;
10081
10082     if (!v)
10083         return (void*)NULL;
10084
10085     /* look for it in the table first */
10086     ret = ptr_table_fetch(PL_ptr_table, v);
10087     if (ret)
10088         return ret;
10089
10090     /* see if it is part of the interpreter structure */
10091     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10092         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10093     else {
10094         ret = v;
10095     }
10096
10097     return ret;
10098 }
10099
10100 /* duplicate the save stack */
10101
10102 ANY *
10103 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10104 {
10105     ANY *ss     = proto_perl->Tsavestack;
10106     I32 ix      = proto_perl->Tsavestack_ix;
10107     I32 max     = proto_perl->Tsavestack_max;
10108     ANY *nss;
10109     SV *sv;
10110     GV *gv;
10111     AV *av;
10112     HV *hv;
10113     void* ptr;
10114     int intval;
10115     long longval;
10116     GP *gp;
10117     IV iv;
10118     I32 i;
10119     char *c = NULL;
10120     void (*dptr) (void*);
10121     void (*dxptr) (pTHX_ void*);
10122     OP *o;
10123
10124     Newz(54, nss, max, ANY);
10125
10126     while (ix > 0) {
10127         i = POPINT(ss,ix);
10128         TOPINT(nss,ix) = i;
10129         switch (i) {
10130         case SAVEt_ITEM:                        /* normal string */
10131             sv = (SV*)POPPTR(ss,ix);
10132             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10133             sv = (SV*)POPPTR(ss,ix);
10134             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10135             break;
10136         case SAVEt_SV:                          /* scalar reference */
10137             sv = (SV*)POPPTR(ss,ix);
10138             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10139             gv = (GV*)POPPTR(ss,ix);
10140             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10141             break;
10142         case SAVEt_GENERIC_PVREF:               /* generic char* */
10143             c = (char*)POPPTR(ss,ix);
10144             TOPPTR(nss,ix) = pv_dup(c);
10145             ptr = POPPTR(ss,ix);
10146             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10147             break;
10148         case SAVEt_SHARED_PVREF:                /* char* in shared space */
10149             c = (char*)POPPTR(ss,ix);
10150             TOPPTR(nss,ix) = savesharedpv(c);
10151             ptr = POPPTR(ss,ix);
10152             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10153             break;
10154         case SAVEt_GENERIC_SVREF:               /* generic sv */
10155         case SAVEt_SVREF:                       /* scalar reference */
10156             sv = (SV*)POPPTR(ss,ix);
10157             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10158             ptr = POPPTR(ss,ix);
10159             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10160             break;
10161         case SAVEt_AV:                          /* array reference */
10162             av = (AV*)POPPTR(ss,ix);
10163             TOPPTR(nss,ix) = av_dup_inc(av, param);
10164             gv = (GV*)POPPTR(ss,ix);
10165             TOPPTR(nss,ix) = gv_dup(gv, param);
10166             break;
10167         case SAVEt_HV:                          /* hash reference */
10168             hv = (HV*)POPPTR(ss,ix);
10169             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10170             gv = (GV*)POPPTR(ss,ix);
10171             TOPPTR(nss,ix) = gv_dup(gv, param);
10172             break;
10173         case SAVEt_INT:                         /* int reference */
10174             ptr = POPPTR(ss,ix);
10175             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10176             intval = (int)POPINT(ss,ix);
10177             TOPINT(nss,ix) = intval;
10178             break;
10179         case SAVEt_LONG:                        /* long reference */
10180             ptr = POPPTR(ss,ix);
10181             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10182             longval = (long)POPLONG(ss,ix);
10183             TOPLONG(nss,ix) = longval;
10184             break;
10185         case SAVEt_I32:                         /* I32 reference */
10186         case SAVEt_I16:                         /* I16 reference */
10187         case SAVEt_I8:                          /* I8 reference */
10188             ptr = POPPTR(ss,ix);
10189             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10190             i = POPINT(ss,ix);
10191             TOPINT(nss,ix) = i;
10192             break;
10193         case SAVEt_IV:                          /* IV reference */
10194             ptr = POPPTR(ss,ix);
10195             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10196             iv = POPIV(ss,ix);
10197             TOPIV(nss,ix) = iv;
10198             break;
10199         case SAVEt_SPTR:                        /* SV* reference */
10200             ptr = POPPTR(ss,ix);
10201             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10202             sv = (SV*)POPPTR(ss,ix);
10203             TOPPTR(nss,ix) = sv_dup(sv, param);
10204             break;
10205         case SAVEt_VPTR:                        /* random* reference */
10206             ptr = POPPTR(ss,ix);
10207             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10208             ptr = POPPTR(ss,ix);
10209             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10210             break;
10211         case SAVEt_PPTR:                        /* char* reference */
10212             ptr = POPPTR(ss,ix);
10213             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10214             c = (char*)POPPTR(ss,ix);
10215             TOPPTR(nss,ix) = pv_dup(c);
10216             break;
10217         case SAVEt_HPTR:                        /* HV* reference */
10218             ptr = POPPTR(ss,ix);
10219             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10220             hv = (HV*)POPPTR(ss,ix);
10221             TOPPTR(nss,ix) = hv_dup(hv, param);
10222             break;
10223         case SAVEt_APTR:                        /* AV* reference */
10224             ptr = POPPTR(ss,ix);
10225             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10226             av = (AV*)POPPTR(ss,ix);
10227             TOPPTR(nss,ix) = av_dup(av, param);
10228             break;
10229         case SAVEt_NSTAB:
10230             gv = (GV*)POPPTR(ss,ix);
10231             TOPPTR(nss,ix) = gv_dup(gv, param);
10232             break;
10233         case SAVEt_GP:                          /* scalar reference */
10234             gp = (GP*)POPPTR(ss,ix);
10235             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10236             (void)GpREFCNT_inc(gp);
10237             gv = (GV*)POPPTR(ss,ix);
10238             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10239             c = (char*)POPPTR(ss,ix);
10240             TOPPTR(nss,ix) = pv_dup(c);
10241             iv = POPIV(ss,ix);
10242             TOPIV(nss,ix) = iv;
10243             iv = POPIV(ss,ix);
10244             TOPIV(nss,ix) = iv;
10245             break;
10246         case SAVEt_FREESV:
10247         case SAVEt_MORTALIZESV:
10248             sv = (SV*)POPPTR(ss,ix);
10249             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10250             break;
10251         case SAVEt_FREEOP:
10252             ptr = POPPTR(ss,ix);
10253             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10254                 /* these are assumed to be refcounted properly */
10255                 switch (((OP*)ptr)->op_type) {
10256                 case OP_LEAVESUB:
10257                 case OP_LEAVESUBLV:
10258                 case OP_LEAVEEVAL:
10259                 case OP_LEAVE:
10260                 case OP_SCOPE:
10261                 case OP_LEAVEWRITE:
10262                     TOPPTR(nss,ix) = ptr;
10263                     o = (OP*)ptr;
10264                     OpREFCNT_inc(o);
10265                     break;
10266                 default:
10267                     TOPPTR(nss,ix) = Nullop;
10268                     break;
10269                 }
10270             }
10271             else
10272                 TOPPTR(nss,ix) = Nullop;
10273             break;
10274         case SAVEt_FREEPV:
10275             c = (char*)POPPTR(ss,ix);
10276             TOPPTR(nss,ix) = pv_dup_inc(c);
10277             break;
10278         case SAVEt_CLEARSV:
10279             longval = POPLONG(ss,ix);
10280             TOPLONG(nss,ix) = longval;
10281             break;
10282         case SAVEt_DELETE:
10283             hv = (HV*)POPPTR(ss,ix);
10284             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10285             c = (char*)POPPTR(ss,ix);
10286             TOPPTR(nss,ix) = pv_dup_inc(c);
10287             i = POPINT(ss,ix);
10288             TOPINT(nss,ix) = i;
10289             break;
10290         case SAVEt_DESTRUCTOR:
10291             ptr = POPPTR(ss,ix);
10292             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
10293             dptr = POPDPTR(ss,ix);
10294             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
10295             break;
10296         case SAVEt_DESTRUCTOR_X:
10297             ptr = POPPTR(ss,ix);
10298             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
10299             dxptr = POPDXPTR(ss,ix);
10300             TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
10301             break;
10302         case SAVEt_REGCONTEXT:
10303         case SAVEt_ALLOC:
10304             i = POPINT(ss,ix);
10305             TOPINT(nss,ix) = i;
10306             ix -= i;
10307             break;
10308         case SAVEt_STACK_POS:           /* Position on Perl stack */
10309             i = POPINT(ss,ix);
10310             TOPINT(nss,ix) = i;
10311             break;
10312         case SAVEt_AELEM:               /* array element */
10313             sv = (SV*)POPPTR(ss,ix);
10314             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10315             i = POPINT(ss,ix);
10316             TOPINT(nss,ix) = i;
10317             av = (AV*)POPPTR(ss,ix);
10318             TOPPTR(nss,ix) = av_dup_inc(av, param);
10319             break;
10320         case SAVEt_HELEM:               /* hash element */
10321             sv = (SV*)POPPTR(ss,ix);
10322             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10323             sv = (SV*)POPPTR(ss,ix);
10324             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10325             hv = (HV*)POPPTR(ss,ix);
10326             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10327             break;
10328         case SAVEt_OP:
10329             ptr = POPPTR(ss,ix);
10330             TOPPTR(nss,ix) = ptr;
10331             break;
10332         case SAVEt_HINTS:
10333             i = POPINT(ss,ix);
10334             TOPINT(nss,ix) = i;
10335             break;
10336         case SAVEt_COMPPAD:
10337             av = (AV*)POPPTR(ss,ix);
10338             TOPPTR(nss,ix) = av_dup(av, param);
10339             break;
10340         case SAVEt_PADSV:
10341             longval = (long)POPLONG(ss,ix);
10342             TOPLONG(nss,ix) = longval;
10343             ptr = POPPTR(ss,ix);
10344             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10345             sv = (SV*)POPPTR(ss,ix);
10346             TOPPTR(nss,ix) = sv_dup(sv, param);
10347             break;
10348         case SAVEt_BOOL:
10349             ptr = POPPTR(ss,ix);
10350             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10351             longval = (long)POPBOOL(ss,ix);
10352             TOPBOOL(nss,ix) = (bool)longval;
10353             break;
10354         default:
10355             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10356         }
10357     }
10358
10359     return nss;
10360 }
10361
10362 /*
10363 =for apidoc perl_clone
10364
10365 Create and return a new interpreter by cloning the current one.
10366
10367 perl_clone takes these flags as paramters:
10368
10369 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10370 without it we only clone the data and zero the stacks,
10371 with it we copy the stacks and the new perl interpreter is
10372 ready to run at the exact same point as the previous one.
10373 The pseudo-fork code uses COPY_STACKS while the
10374 threads->new doesn't.
10375
10376 CLONEf_KEEP_PTR_TABLE
10377 perl_clone keeps a ptr_table with the pointer of the old
10378 variable as a key and the new variable as a value,
10379 this allows it to check if something has been cloned and not
10380 clone it again but rather just use the value and increase the
10381 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10382 the ptr_table using the function
10383 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10384 reason to keep it around is if you want to dup some of your own
10385 variable who are outside the graph perl scans, example of this
10386 code is in threads.xs create
10387
10388 CLONEf_CLONE_HOST
10389 This is a win32 thing, it is ignored on unix, it tells perls
10390 win32host code (which is c++) to clone itself, this is needed on
10391 win32 if you want to run two threads at the same time,
10392 if you just want to do some stuff in a separate perl interpreter
10393 and then throw it away and return to the original one,
10394 you don't need to do anything.
10395
10396 =cut
10397 */
10398
10399 /* XXX the above needs expanding by someone who actually understands it ! */
10400 EXTERN_C PerlInterpreter *
10401 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10402
10403 PerlInterpreter *
10404 perl_clone(PerlInterpreter *proto_perl, UV flags)
10405 {
10406 #ifdef PERL_IMPLICIT_SYS
10407
10408    /* perlhost.h so we need to call into it
10409    to clone the host, CPerlHost should have a c interface, sky */
10410
10411    if (flags & CLONEf_CLONE_HOST) {
10412        return perl_clone_host(proto_perl,flags);
10413    }
10414    return perl_clone_using(proto_perl, flags,
10415                             proto_perl->IMem,
10416                             proto_perl->IMemShared,
10417                             proto_perl->IMemParse,
10418                             proto_perl->IEnv,
10419                             proto_perl->IStdIO,
10420                             proto_perl->ILIO,
10421                             proto_perl->IDir,
10422                             proto_perl->ISock,
10423                             proto_perl->IProc);
10424 }
10425
10426 PerlInterpreter *
10427 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10428                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
10429                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10430                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10431                  struct IPerlDir* ipD, struct IPerlSock* ipS,
10432                  struct IPerlProc* ipP)
10433 {
10434     /* XXX many of the string copies here can be optimized if they're
10435      * constants; they need to be allocated as common memory and just
10436      * their pointers copied. */
10437
10438     IV i;
10439     CLONE_PARAMS clone_params;
10440     CLONE_PARAMS* param = &clone_params;
10441
10442     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10443     PERL_SET_THX(my_perl);
10444
10445 #  ifdef DEBUGGING
10446     Poison(my_perl, 1, PerlInterpreter);
10447     PL_markstack = 0;
10448     PL_scopestack = 0;
10449     PL_savestack = 0;
10450     PL_retstack = 0;
10451     PL_sig_pending = 0;
10452     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10453 #  else /* !DEBUGGING */
10454     Zero(my_perl, 1, PerlInterpreter);
10455 #  endif        /* DEBUGGING */
10456
10457     /* host pointers */
10458     PL_Mem              = ipM;
10459     PL_MemShared        = ipMS;
10460     PL_MemParse         = ipMP;
10461     PL_Env              = ipE;
10462     PL_StdIO            = ipStd;
10463     PL_LIO              = ipLIO;
10464     PL_Dir              = ipD;
10465     PL_Sock             = ipS;
10466     PL_Proc             = ipP;
10467 #else           /* !PERL_IMPLICIT_SYS */
10468     IV i;
10469     CLONE_PARAMS clone_params;
10470     CLONE_PARAMS* param = &clone_params;
10471     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10472     PERL_SET_THX(my_perl);
10473
10474
10475
10476 #    ifdef DEBUGGING
10477     Poison(my_perl, 1, PerlInterpreter);
10478     PL_markstack = 0;
10479     PL_scopestack = 0;
10480     PL_savestack = 0;
10481     PL_retstack = 0;
10482     PL_sig_pending = 0;
10483     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10484 #    else       /* !DEBUGGING */
10485     Zero(my_perl, 1, PerlInterpreter);
10486 #    endif      /* DEBUGGING */
10487 #endif          /* PERL_IMPLICIT_SYS */
10488     param->flags = flags;
10489     param->proto_perl = proto_perl;
10490
10491     /* arena roots */
10492     PL_xiv_arenaroot    = NULL;
10493     PL_xiv_root         = NULL;
10494     PL_xnv_arenaroot    = NULL;
10495     PL_xnv_root         = NULL;
10496     PL_xrv_arenaroot    = NULL;
10497     PL_xrv_root         = NULL;
10498     PL_xpv_arenaroot    = NULL;
10499     PL_xpv_root         = NULL;
10500     PL_xpviv_arenaroot  = NULL;
10501     PL_xpviv_root       = NULL;
10502     PL_xpvnv_arenaroot  = NULL;
10503     PL_xpvnv_root       = NULL;
10504     PL_xpvcv_arenaroot  = NULL;
10505     PL_xpvcv_root       = NULL;
10506     PL_xpvav_arenaroot  = NULL;
10507     PL_xpvav_root       = NULL;
10508     PL_xpvhv_arenaroot  = NULL;
10509     PL_xpvhv_root       = NULL;
10510     PL_xpvmg_arenaroot  = NULL;
10511     PL_xpvmg_root       = NULL;
10512     PL_xpvlv_arenaroot  = NULL;
10513     PL_xpvlv_root       = NULL;
10514     PL_xpvbm_arenaroot  = NULL;
10515     PL_xpvbm_root       = NULL;
10516     PL_he_arenaroot     = NULL;
10517     PL_he_root          = NULL;
10518     PL_nice_chunk       = NULL;
10519     PL_nice_chunk_size  = 0;
10520     PL_sv_count         = 0;
10521     PL_sv_objcount      = 0;
10522     PL_sv_root          = Nullsv;
10523     PL_sv_arenaroot     = Nullsv;
10524
10525     PL_debug            = proto_perl->Idebug;
10526
10527 #ifdef USE_REENTRANT_API
10528     Perl_reentrant_init(aTHX);
10529 #endif
10530
10531     /* create SV map for pointer relocation */
10532     PL_ptr_table = ptr_table_new();
10533
10534     /* initialize these special pointers as early as possible */
10535     SvANY(&PL_sv_undef)         = NULL;
10536     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
10537     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
10538     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10539
10540     SvANY(&PL_sv_no)            = new_XPVNV();
10541     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
10542     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10543     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
10544     SvCUR(&PL_sv_no)            = 0;
10545     SvLEN(&PL_sv_no)            = 1;
10546     SvNVX(&PL_sv_no)            = 0;
10547     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10548
10549     SvANY(&PL_sv_yes)           = new_XPVNV();
10550     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
10551     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10552     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
10553     SvCUR(&PL_sv_yes)           = 1;
10554     SvLEN(&PL_sv_yes)           = 2;
10555     SvNVX(&PL_sv_yes)           = 1;
10556     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10557
10558     /* create (a non-shared!) shared string table */
10559     PL_strtab           = newHV();
10560     HvSHAREKEYS_off(PL_strtab);
10561     hv_ksplit(PL_strtab, 512);
10562     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10563
10564     PL_compiling = proto_perl->Icompiling;
10565
10566     /* These two PVs will be free'd special way so must set them same way op.c does */
10567     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10568     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10569
10570     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
10571     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10572
10573     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10574     if (!specialWARN(PL_compiling.cop_warnings))
10575         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10576     if (!specialCopIO(PL_compiling.cop_io))
10577         PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10578     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10579
10580     /* pseudo environmental stuff */
10581     PL_origargc         = proto_perl->Iorigargc;
10582     PL_origargv         = proto_perl->Iorigargv;
10583
10584     param->stashes      = newAV();  /* Setup array of objects to call clone on */
10585
10586 #ifdef PERLIO_LAYERS
10587     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10588     PerlIO_clone(aTHX_ proto_perl, param);
10589 #endif
10590
10591     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
10592     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
10593     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
10594     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
10595     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
10596     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
10597
10598     /* switches */
10599     PL_minus_c          = proto_perl->Iminus_c;
10600     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
10601     PL_localpatches     = proto_perl->Ilocalpatches;
10602     PL_splitstr         = proto_perl->Isplitstr;
10603     PL_preprocess       = proto_perl->Ipreprocess;
10604     PL_minus_n          = proto_perl->Iminus_n;
10605     PL_minus_p          = proto_perl->Iminus_p;
10606     PL_minus_l          = proto_perl->Iminus_l;
10607     PL_minus_a          = proto_perl->Iminus_a;
10608     PL_minus_F          = proto_perl->Iminus_F;
10609     PL_doswitches       = proto_perl->Idoswitches;
10610     PL_dowarn           = proto_perl->Idowarn;
10611     PL_doextract        = proto_perl->Idoextract;
10612     PL_sawampersand     = proto_perl->Isawampersand;
10613     PL_unsafe           = proto_perl->Iunsafe;
10614     PL_inplace          = SAVEPV(proto_perl->Iinplace);
10615     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
10616     PL_perldb           = proto_perl->Iperldb;
10617     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10618     PL_exit_flags       = proto_perl->Iexit_flags;
10619
10620     /* magical thingies */
10621     /* XXX time(&PL_basetime) when asked for? */
10622     PL_basetime         = proto_perl->Ibasetime;
10623     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
10624
10625     PL_maxsysfd         = proto_perl->Imaxsysfd;
10626     PL_multiline        = proto_perl->Imultiline;
10627     PL_statusvalue      = proto_perl->Istatusvalue;
10628 #ifdef VMS
10629     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
10630 #endif
10631     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
10632
10633     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
10634     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
10635     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
10636
10637     /* Clone the regex array */
10638     PL_regex_padav = newAV();
10639     {
10640         I32 len = av_len((AV*)proto_perl->Iregex_padav);
10641         SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10642         av_push(PL_regex_padav,
10643                 sv_dup_inc(regexen[0],param));
10644         for(i = 1; i <= len; i++) {
10645             if(SvREPADTMP(regexen[i])) {
10646               av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
10647             } else {
10648                 av_push(PL_regex_padav,
10649                     SvREFCNT_inc(
10650                         newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
10651                              SvIVX(regexen[i])), param)))
10652                        ));
10653             }
10654         }
10655     }
10656     PL_regex_pad = AvARRAY(PL_regex_padav);
10657
10658     /* shortcuts to various I/O objects */
10659     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
10660     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
10661     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
10662     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
10663     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
10664     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
10665
10666     /* shortcuts to regexp stuff */
10667     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
10668
10669     /* shortcuts to misc objects */
10670     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
10671
10672     /* shortcuts to debugging objects */
10673     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
10674     PL_DBline           = gv_dup(proto_perl->IDBline, param);
10675     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
10676     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
10677     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
10678     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
10679     PL_lineary          = av_dup(proto_perl->Ilineary, param);
10680     PL_dbargs           = av_dup(proto_perl->Idbargs, param);
10681
10682     /* symbol tables */
10683     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash, param);
10684     PL_curstash         = hv_dup(proto_perl->Tcurstash, param);
10685     PL_nullstash       = hv_dup(proto_perl->Inullstash, param);
10686     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
10687     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
10688     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
10689
10690     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
10691     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
10692     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
10693     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
10694     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
10695     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
10696
10697     PL_sub_generation   = proto_perl->Isub_generation;
10698
10699     /* funky return mechanisms */
10700     PL_forkprocess      = proto_perl->Iforkprocess;
10701
10702     /* subprocess state */
10703     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
10704
10705     /* internal state */
10706     PL_tainting         = proto_perl->Itainting;
10707     PL_taint_warn       = proto_perl->Itaint_warn;
10708     PL_maxo             = proto_perl->Imaxo;
10709     if (proto_perl->Iop_mask)
10710         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10711     else
10712         PL_op_mask      = Nullch;
10713
10714     /* current interpreter roots */
10715     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
10716     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
10717     PL_main_start       = proto_perl->Imain_start;
10718     PL_eval_root        = proto_perl->Ieval_root;
10719     PL_eval_start       = proto_perl->Ieval_start;
10720
10721     /* runtime control stuff */
10722     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10723     PL_copline          = proto_perl->Icopline;
10724
10725     PL_filemode         = proto_perl->Ifilemode;
10726     PL_lastfd           = proto_perl->Ilastfd;
10727     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
10728     PL_Argv             = NULL;
10729     PL_Cmd              = Nullch;
10730     PL_gensym           = proto_perl->Igensym;
10731     PL_preambled        = proto_perl->Ipreambled;
10732     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
10733     PL_laststatval      = proto_perl->Ilaststatval;
10734     PL_laststype        = proto_perl->Ilaststype;
10735     PL_mess_sv          = Nullsv;
10736
10737     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
10738     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
10739
10740     /* interpreter atexit processing */
10741     PL_exitlistlen      = proto_perl->Iexitlistlen;
10742     if (PL_exitlistlen) {
10743         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10744         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10745     }
10746     else
10747         PL_exitlist     = (PerlExitListEntry*)NULL;
10748     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
10749     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
10750     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10751
10752     PL_profiledata      = NULL;
10753     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<', param);
10754     /* PL_rsfp_filters entries have fake IoDIRP() */
10755     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters, param);
10756
10757     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
10758
10759     PAD_CLONE_VARS(proto_perl, param);
10760
10761 #ifdef HAVE_INTERP_INTERN
10762     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10763 #endif
10764
10765     /* more statics moved here */
10766     PL_generation       = proto_perl->Igeneration;
10767     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
10768
10769     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
10770     PL_in_clean_all     = proto_perl->Iin_clean_all;
10771
10772     PL_uid              = proto_perl->Iuid;
10773     PL_euid             = proto_perl->Ieuid;
10774     PL_gid              = proto_perl->Igid;
10775     PL_egid             = proto_perl->Iegid;
10776     PL_nomemok          = proto_perl->Inomemok;
10777     PL_an               = proto_perl->Ian;
10778     PL_op_seqmax        = proto_perl->Iop_seqmax;
10779     PL_evalseq          = proto_perl->Ievalseq;
10780     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
10781     PL_origalen         = proto_perl->Iorigalen;
10782     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
10783     PL_osname           = SAVEPV(proto_perl->Iosname);
10784     PL_sh_path_compat   = proto_perl->Ish_path_compat; /* XXX never deallocated */
10785     PL_sighandlerp      = proto_perl->Isighandlerp;
10786
10787
10788     PL_runops           = proto_perl->Irunops;
10789
10790     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10791
10792 #ifdef CSH
10793     PL_cshlen           = proto_perl->Icshlen;
10794     PL_cshname          = proto_perl->Icshname; /* XXX never deallocated */
10795 #endif
10796
10797     PL_lex_state        = proto_perl->Ilex_state;
10798     PL_lex_defer        = proto_perl->Ilex_defer;
10799     PL_lex_expect       = proto_perl->Ilex_expect;
10800     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
10801     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
10802     PL_lex_starts       = proto_perl->Ilex_starts;
10803     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff, param);
10804     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl, param);
10805     PL_lex_op           = proto_perl->Ilex_op;
10806     PL_lex_inpat        = proto_perl->Ilex_inpat;
10807     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
10808     PL_lex_brackets     = proto_perl->Ilex_brackets;
10809     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10810     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
10811     PL_lex_casemods     = proto_perl->Ilex_casemods;
10812     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10813     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
10814
10815     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10816     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10817     PL_nexttoke         = proto_perl->Inexttoke;
10818
10819     /* XXX This is probably masking the deeper issue of why
10820      * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
10821      * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
10822      * (A little debugging with a watchpoint on it may help.)
10823      */
10824     if (SvANY(proto_perl->Ilinestr)) {
10825         PL_linestr              = sv_dup_inc(proto_perl->Ilinestr, param);
10826         i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
10827         PL_bufptr               = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10828         i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
10829         PL_oldbufptr    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10830         i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
10831         PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10832         i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
10833         PL_linestart    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10834     }
10835     else {
10836         PL_linestr = NEWSV(65,79);
10837         sv_upgrade(PL_linestr,SVt_PVIV);
10838         sv_setpvn(PL_linestr,"",0);
10839         PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
10840     }
10841     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10842     PL_pending_ident    = proto_perl->Ipending_ident;
10843     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
10844
10845     PL_expect           = proto_perl->Iexpect;
10846
10847     PL_multi_start      = proto_perl->Imulti_start;
10848     PL_multi_end        = proto_perl->Imulti_end;
10849     PL_multi_open       = proto_perl->Imulti_open;
10850     PL_multi_close      = proto_perl->Imulti_close;
10851
10852     PL_error_count      = proto_perl->Ierror_count;
10853     PL_subline          = proto_perl->Isubline;
10854     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
10855
10856     /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
10857     if (SvANY(proto_perl->Ilinestr)) {
10858         i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10859         PL_last_uni             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10860         i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10861         PL_last_lop             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10862         PL_last_lop_op  = proto_perl->Ilast_lop_op;
10863     }
10864     else {
10865         PL_last_uni     = SvPVX(PL_linestr);
10866         PL_last_lop     = SvPVX(PL_linestr);
10867         PL_last_lop_op  = 0;
10868     }
10869     PL_in_my            = proto_perl->Iin_my;
10870     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash, param);
10871 #ifdef FCRYPT
10872     PL_cryptseen        = proto_perl->Icryptseen;
10873 #endif
10874
10875     PL_hints            = proto_perl->Ihints;
10876
10877     PL_amagic_generation        = proto_perl->Iamagic_generation;
10878
10879 #ifdef USE_LOCALE_COLLATE
10880     PL_collation_ix     = proto_perl->Icollation_ix;
10881     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
10882     PL_collation_standard       = proto_perl->Icollation_standard;
10883     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
10884     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
10885 #endif /* USE_LOCALE_COLLATE */
10886
10887 #ifdef USE_LOCALE_NUMERIC
10888     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
10889     PL_numeric_standard = proto_perl->Inumeric_standard;
10890     PL_numeric_local    = proto_perl->Inumeric_local;
10891     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10892 #endif /* !USE_LOCALE_NUMERIC */
10893
10894     /* utf8 character classes */
10895     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10896     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10897     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10898     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10899     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
10900     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10901     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
10902     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
10903     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
10904     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
10905     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
10906     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
10907     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10908     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
10909     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10910     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10911     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10912     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
10913     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
10914     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
10915
10916     /* Did the locale setup indicate UTF-8? */
10917     PL_utf8locale       = proto_perl->Iutf8locale;
10918     /* Unicode features (see perlrun/-C) */
10919     PL_unicode          = proto_perl->Iunicode;
10920
10921     /* Pre-5.8 signals control */
10922     PL_signals          = proto_perl->Isignals;
10923
10924     /* times() ticks per second */
10925     PL_clocktick        = proto_perl->Iclocktick;
10926
10927     /* Recursion stopper for PerlIO_find_layer */
10928     PL_in_load_module   = proto_perl->Iin_load_module;
10929
10930     /* sort() routine */
10931     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
10932
10933     /* Not really needed/useful since the reenrant_retint is "volatile",
10934      * but do it for consistency's sake. */
10935     PL_reentrant_retint = proto_perl->Ireentrant_retint;
10936
10937     /* Hooks to shared SVs and locks. */
10938     PL_sharehook        = proto_perl->Isharehook;
10939     PL_lockhook         = proto_perl->Ilockhook;
10940     PL_unlockhook       = proto_perl->Iunlockhook;
10941     PL_threadhook       = proto_perl->Ithreadhook;
10942
10943     PL_runops_std       = proto_perl->Irunops_std;
10944     PL_runops_dbg       = proto_perl->Irunops_dbg;
10945
10946 #ifdef THREADS_HAVE_PIDS
10947     PL_ppid             = proto_perl->Ippid;
10948 #endif
10949
10950     /* swatch cache */
10951     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
10952     PL_last_swash_klen  = 0;
10953     PL_last_swash_key[0]= '\0';
10954     PL_last_swash_tmps  = (U8*)NULL;
10955     PL_last_swash_slen  = 0;
10956
10957     /* perly.c globals */
10958     PL_yydebug          = proto_perl->Iyydebug;
10959     PL_yynerrs          = proto_perl->Iyynerrs;
10960     PL_yyerrflag        = proto_perl->Iyyerrflag;
10961     PL_yychar           = proto_perl->Iyychar;
10962     PL_yyval            = proto_perl->Iyyval;
10963     PL_yylval           = proto_perl->Iyylval;
10964
10965     PL_glob_index       = proto_perl->Iglob_index;
10966     PL_srand_called     = proto_perl->Isrand_called;
10967     PL_uudmap['M']      = 0;            /* reinits on demand */
10968     PL_bitcount         = Nullch;       /* reinits on demand */
10969
10970     if (proto_perl->Ipsig_pend) {
10971         Newz(0, PL_psig_pend, SIG_SIZE, int);
10972     }
10973     else {
10974         PL_psig_pend    = (int*)NULL;
10975     }
10976
10977     if (proto_perl->Ipsig_ptr) {
10978         Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
10979         Newz(0, PL_psig_name, SIG_SIZE, SV*);
10980         for (i = 1; i < SIG_SIZE; i++) {
10981             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10982             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10983         }
10984     }
10985     else {
10986         PL_psig_ptr     = (SV**)NULL;
10987         PL_psig_name    = (SV**)NULL;
10988     }
10989
10990     /* thrdvar.h stuff */
10991
10992     if (flags & CLONEf_COPY_STACKS) {
10993         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10994         PL_tmps_ix              = proto_perl->Ttmps_ix;
10995         PL_tmps_max             = proto_perl->Ttmps_max;
10996         PL_tmps_floor           = proto_perl->Ttmps_floor;
10997         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10998         i = 0;
10999         while (i <= PL_tmps_ix) {
11000             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11001             ++i;
11002         }
11003
11004         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11005         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11006         Newz(54, PL_markstack, i, I32);
11007         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
11008                                                   - proto_perl->Tmarkstack);
11009         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
11010                                                   - proto_perl->Tmarkstack);
11011         Copy(proto_perl->Tmarkstack, PL_markstack,
11012              PL_markstack_ptr - PL_markstack + 1, I32);
11013
11014         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11015          * NOTE: unlike the others! */
11016         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
11017         PL_scopestack_max       = proto_perl->Tscopestack_max;
11018         Newz(54, PL_scopestack, PL_scopestack_max, I32);
11019         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11020
11021         /* next push_return() sets PL_retstack[PL_retstack_ix]
11022          * NOTE: unlike the others! */
11023         PL_retstack_ix          = proto_perl->Tretstack_ix;
11024         PL_retstack_max         = proto_perl->Tretstack_max;
11025         Newz(54, PL_retstack, PL_retstack_max, OP*);
11026         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
11027
11028         /* NOTE: si_dup() looks at PL_markstack */
11029         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo, param);
11030
11031         /* PL_curstack          = PL_curstackinfo->si_stack; */
11032         PL_curstack             = av_dup(proto_perl->Tcurstack, param);
11033         PL_mainstack            = av_dup(proto_perl->Tmainstack, param);
11034
11035         /* next PUSHs() etc. set *(PL_stack_sp+1) */
11036         PL_stack_base           = AvARRAY(PL_curstack);
11037         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
11038                                                    - proto_perl->Tstack_base);
11039         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
11040
11041         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11042          * NOTE: unlike the others! */
11043         PL_savestack_ix         = proto_perl->Tsavestack_ix;
11044         PL_savestack_max        = proto_perl->Tsavestack_max;
11045         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
11046         PL_savestack            = ss_dup(proto_perl, param);
11047     }
11048     else {
11049         init_stacks();
11050         ENTER;                  /* perl_destruct() wants to LEAVE; */
11051     }
11052
11053     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
11054     PL_top_env          = &PL_start_env;
11055
11056     PL_op               = proto_perl->Top;
11057
11058     PL_Sv               = Nullsv;
11059     PL_Xpv              = (XPV*)NULL;
11060     PL_na               = proto_perl->Tna;
11061
11062     PL_statbuf          = proto_perl->Tstatbuf;
11063     PL_statcache        = proto_perl->Tstatcache;
11064     PL_statgv           = gv_dup(proto_perl->Tstatgv, param);
11065     PL_statname         = sv_dup_inc(proto_perl->Tstatname, param);
11066 #ifdef HAS_TIMES
11067     PL_timesbuf         = proto_perl->Ttimesbuf;
11068 #endif
11069
11070     PL_tainted          = proto_perl->Ttainted;
11071     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
11072     PL_rs               = sv_dup_inc(proto_perl->Trs, param);
11073     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv, param);
11074     PL_ofs_sv           = sv_dup_inc(proto_perl->Tofs_sv, param);
11075     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv, param);
11076     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
11077     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget, param);
11078     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget, param);
11079     PL_formtarget       = sv_dup(proto_perl->Tformtarget, param);
11080
11081     PL_restartop        = proto_perl->Trestartop;
11082     PL_in_eval          = proto_perl->Tin_eval;
11083     PL_delaymagic       = proto_perl->Tdelaymagic;
11084     PL_dirty            = proto_perl->Tdirty;
11085     PL_localizing       = proto_perl->Tlocalizing;
11086
11087 #ifdef PERL_FLEXIBLE_EXCEPTIONS
11088     PL_protect          = proto_perl->Tprotect;
11089 #endif
11090     PL_errors           = sv_dup_inc(proto_perl->Terrors, param);
11091     PL_hv_fetch_ent_mh  = Nullhe;
11092     PL_modcount         = proto_perl->Tmodcount;
11093     PL_lastgotoprobe    = Nullop;
11094     PL_dumpindent       = proto_perl->Tdumpindent;
11095
11096     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11097     PL_sortstash        = hv_dup(proto_perl->Tsortstash, param);
11098     PL_firstgv          = gv_dup(proto_perl->Tfirstgv, param);
11099     PL_secondgv         = gv_dup(proto_perl->Tsecondgv, param);
11100     PL_sortcxix         = proto_perl->Tsortcxix;
11101     PL_efloatbuf        = Nullch;               /* reinits on demand */
11102     PL_efloatsize       = 0;                    /* reinits on demand */
11103
11104     /* regex stuff */
11105
11106     PL_screamfirst      = NULL;
11107     PL_screamnext       = NULL;
11108     PL_maxscream        = -1;                   /* reinits on demand */
11109     PL_lastscream       = Nullsv;
11110
11111     PL_watchaddr        = NULL;
11112     PL_watchok          = Nullch;
11113
11114     PL_regdummy         = proto_perl->Tregdummy;
11115     PL_regcomp_parse    = Nullch;
11116     PL_regxend          = Nullch;
11117     PL_regcode          = (regnode*)NULL;
11118     PL_regnaughty       = 0;
11119     PL_regsawback       = 0;
11120     PL_regprecomp       = Nullch;
11121     PL_regnpar          = 0;
11122     PL_regsize          = 0;
11123     PL_regflags         = 0;
11124     PL_regseen          = 0;
11125     PL_seen_zerolen     = 0;
11126     PL_seen_evals       = 0;
11127     PL_regcomp_rx       = (regexp*)NULL;
11128     PL_extralen         = 0;
11129     PL_colorset         = 0;            /* reinits PL_colors[] */
11130     /*PL_colors[6]      = {0,0,0,0,0,0};*/
11131     PL_reg_whilem_seen  = 0;
11132     PL_reginput         = Nullch;
11133     PL_regbol           = Nullch;
11134     PL_regeol           = Nullch;
11135     PL_regstartp        = (I32*)NULL;
11136     PL_regendp          = (I32*)NULL;
11137     PL_reglastparen     = (U32*)NULL;
11138     PL_regtill          = Nullch;
11139     PL_reg_start_tmp    = (char**)NULL;
11140     PL_reg_start_tmpl   = 0;
11141     PL_regdata          = (struct reg_data*)NULL;
11142     PL_bostr            = Nullch;
11143     PL_reg_flags        = 0;
11144     PL_reg_eval_set     = 0;
11145     PL_regnarrate       = 0;
11146     PL_regprogram       = (regnode*)NULL;
11147     PL_regindent        = 0;
11148     PL_regcc            = (CURCUR*)NULL;
11149     PL_reg_call_cc      = (struct re_cc_state*)NULL;
11150     PL_reg_re           = (regexp*)NULL;
11151     PL_reg_ganch        = Nullch;
11152     PL_reg_sv           = Nullsv;
11153     PL_reg_match_utf8   = FALSE;
11154     PL_reg_magic        = (MAGIC*)NULL;
11155     PL_reg_oldpos       = 0;
11156     PL_reg_oldcurpm     = (PMOP*)NULL;
11157     PL_reg_curpm        = (PMOP*)NULL;
11158     PL_reg_oldsaved     = Nullch;
11159     PL_reg_oldsavedlen  = 0;
11160     PL_reg_maxiter      = 0;
11161     PL_reg_leftiter     = 0;
11162     PL_reg_poscache     = Nullch;
11163     PL_reg_poscache_size= 0;
11164
11165     /* RE engine - function pointers */
11166     PL_regcompp         = proto_perl->Tregcompp;
11167     PL_regexecp         = proto_perl->Tregexecp;
11168     PL_regint_start     = proto_perl->Tregint_start;
11169     PL_regint_string    = proto_perl->Tregint_string;
11170     PL_regfree          = proto_perl->Tregfree;
11171
11172     PL_reginterp_cnt    = 0;
11173     PL_reg_starttry     = 0;
11174
11175     /* Pluggable optimizer */
11176     PL_peepp            = proto_perl->Tpeepp;
11177
11178     PL_stashcache       = newHV();
11179
11180     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11181         ptr_table_free(PL_ptr_table);
11182         PL_ptr_table = NULL;
11183     }
11184
11185     /* Call the ->CLONE method, if it exists, for each of the stashes
11186        identified by sv_dup() above.
11187     */
11188     while(av_len(param->stashes) != -1) {
11189         HV* stash = (HV*) av_shift(param->stashes);
11190         GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11191         if (cloner && GvCV(cloner)) {
11192             dSP;
11193             ENTER;
11194             SAVETMPS;
11195             PUSHMARK(SP);
11196            XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
11197             PUTBACK;
11198             call_sv((SV*)GvCV(cloner), G_DISCARD);
11199             FREETMPS;
11200             LEAVE;
11201         }
11202     }
11203
11204     SvREFCNT_dec(param->stashes);
11205
11206     return my_perl;
11207 }
11208
11209 #endif /* USE_ITHREADS */
11210
11211 /*
11212 =head1 Unicode Support
11213
11214 =for apidoc sv_recode_to_utf8
11215
11216 The encoding is assumed to be an Encode object, on entry the PV
11217 of the sv is assumed to be octets in that encoding, and the sv
11218 will be converted into Unicode (and UTF-8).
11219
11220 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11221 is not a reference, nothing is done to the sv.  If the encoding is not
11222 an C<Encode::XS> Encoding object, bad things will happen.
11223 (See F<lib/encoding.pm> and L<Encode>).
11224
11225 The PV of the sv is returned.
11226
11227 =cut */
11228
11229 char *
11230 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11231 {
11232     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11233         SV *uni;
11234         STRLEN len;
11235         char *s;
11236         dSP;
11237         ENTER;
11238         SAVETMPS;
11239         save_re_context();
11240         PUSHMARK(sp);
11241         EXTEND(SP, 3);
11242         XPUSHs(encoding);
11243         XPUSHs(sv);
11244 /*
11245   NI-S 2002/07/09
11246   Passing sv_yes is wrong - it needs to be or'ed set of constants
11247   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11248   remove converted chars from source.
11249
11250   Both will default the value - let them.
11251
11252         XPUSHs(&PL_sv_yes);
11253 */
11254         PUTBACK;
11255         call_method("decode", G_SCALAR);
11256         SPAGAIN;
11257         uni = POPs;
11258         PUTBACK;
11259         s = SvPV(uni, len);
11260         if (s != SvPVX(sv)) {
11261             SvGROW(sv, len + 1);
11262             Move(s, SvPVX(sv), len, char);
11263             SvCUR_set(sv, len);
11264             SvPVX(sv)[len] = 0;
11265         }
11266         FREETMPS;
11267         LEAVE;
11268         SvUTF8_on(sv);
11269     }
11270     return SvPVX(sv);
11271 }
11272
11273 /*
11274 =for apidoc sv_cat_decode
11275
11276 The encoding is assumed to be an Encode object, the PV of the ssv is
11277 assumed to be octets in that encoding and decoding the input starts
11278 from the position which (PV + *offset) pointed to.  The dsv will be
11279 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
11280 when the string tstr appears in decoding output or the input ends on
11281 the PV of the ssv. The value which the offset points will be modified
11282 to the last input position on the ssv.
11283
11284 Returns TRUE if the terminator was found, else returns FALSE.
11285
11286 =cut */
11287
11288 bool
11289 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11290                    SV *ssv, int *offset, char *tstr, int tlen)
11291 {
11292     bool ret = FALSE;
11293     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11294         SV *offsv;
11295         dSP;
11296         ENTER;
11297         SAVETMPS;
11298         save_re_context();
11299         PUSHMARK(sp);
11300         EXTEND(SP, 6);
11301         XPUSHs(encoding);
11302         XPUSHs(dsv);
11303         XPUSHs(ssv);
11304         XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11305         XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11306         PUTBACK;
11307         call_method("cat_decode", G_SCALAR);
11308         SPAGAIN;
11309         ret = SvTRUE(TOPs);
11310         *offset = SvIV(offsv);
11311         PUTBACK;
11312         FREETMPS;
11313         LEAVE;
11314     }
11315     else
11316         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11317     return ret;
11318 }
11319