sv.c

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