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