sv.c

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