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