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