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