sv.c

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