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