sv.c

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