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