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