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