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