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