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