sv.c

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