sv.c

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