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