sv.c

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