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