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