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