sv.c

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