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