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