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