sv.c

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