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