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