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