sv.c

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