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