sv.c

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