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