sv.c

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