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