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