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