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