sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
   5  *    and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'I wonder what the Entish is for "yes" and "no",' he thought.
  14  *                                                      --Pippin
  15  *
  16  *     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
  17  */
  18
  19 /*
  20  *
  21  *
  22  * This file contains the code that creates, manipulates and destroys
  23  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
  24  * structure of an SV, so their creation and destruction is handled
  25  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
  26  * level functions (eg. substr, split, join) for each of the types are
  27  * in the pp*.c files.
  28  */
  29
  30 #include "EXTERN.h"
  31 #define PERL_IN_SV_C
  32 #include "perl.h"
  33 #include "regcomp.h"
  34
  35 #define FCALL *f
  36
  37 #ifdef __Lynx__
  38 /* Missing proto on LynxOS */
  39   char *gconvert(double, int, int,  char *);
  40 #endif
  41
  42 #ifdef PERL_UTF8_CACHE_ASSERT
  43 /* if adding more checks watch out for the following tests:
  44  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
  45  *   lib/utf8.t lib/Unicode/Collate/t/index.t
  46  * --jhi
  47  */
  48 #   define ASSERT_UTF8_CACHE(cache) \
  49     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
  50                               assert((cache)[2] <= (cache)[3]); \
  51                               assert((cache)[3] <= (cache)[1]);} \
  52                               } STMT_END
  53 #else
  54 #   define ASSERT_UTF8_CACHE(cache) NOOP
  55 #endif
  56
  57 #ifdef PERL_OLD_COPY_ON_WRITE
  58 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
  59 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
  60 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
  61    on-write.  */
  62 #endif
  63
  64 /* ============================================================================
  65
  66 =head1 Allocation and deallocation of SVs.
  67
  68 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
  69 sv, av, hv...) contains type and reference count information, and for
  70 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
  71 contains fields specific to each type.  Some types store all they need
  72 in the head, so don't have a body.
  73
  74 In all but the most memory-paranoid configuations (ex: PURIFY), heads
  75 and bodies are allocated out of arenas, which by default are
  76 approximately 4K chunks of memory parcelled up into N heads or bodies.
  77 Sv-bodies are allocated by their sv-type, guaranteeing size
  78 consistency needed to allocate safely from arrays.
  79
  80 For SV-heads, the first slot in each arena is reserved, and holds a
  81 link to the next arena, some flags, and a note of the number of slots.
  82 Snaked through each arena chain is a linked list of free items; when
  83 this becomes empty, an extra arena is allocated and divided up into N
  84 items which are threaded into the free list.
  85
  86 SV-bodies are similar, but they use arena-sets by default, which
  87 separate the link and info from the arena itself, and reclaim the 1st
  88 slot in the arena.  SV-bodies are further described later.
  89
  90 The following global variables are associated with arenas:
  91
  92     PL_sv_arenaroot     pointer to list of SV arenas
  93     PL_sv_root          pointer to list of free SV structures
  94
  95     PL_body_arenas      head of linked-list of body arenas
  96     PL_body_roots[]     array of pointers to list of free bodies of svtype
  97                         arrays are indexed by the svtype needed
  98
  99 A few special SV heads are not allocated from an arena, but are
 100 instead directly created in the interpreter structure, eg PL_sv_undef.
 101 The size of arenas can be changed from the default by setting
 102 PERL_ARENA_SIZE appropriately at compile time.
 103
 104 The SV arena serves the secondary purpose of allowing still-live SVs
 105 to be located and destroyed during final cleanup.
 106
 107 At the lowest level, the macros new_SV() and del_SV() grab and free
 108 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
 109 to return the SV to the free list with error checking.) new_SV() calls
 110 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
 111 SVs in the free list have their SvTYPE field set to all ones.
 112
 113 At the time of very final cleanup, sv_free_arenas() is called from
 114 perl_destruct() to physically free all the arenas allocated since the
 115 start of the interpreter.
 116
 117 The function visit() scans the SV arenas list, and calls a specified
 118 function for each SV it finds which is still live - ie which has an SvTYPE
 119 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
 120 following functions (specified as [function that calls visit()] / [function
 121 called by visit() for each SV]):
 122
 123     sv_report_used() / do_report_used()
 124                         dump all remaining SVs (debugging aid)
 125
 126     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
 127                         Attempt to free all objects pointed to by RVs,
 128                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
 129                         try to do the same for all objects indirectly
 130                         referenced by typeglobs too.  Called once from
 131                         perl_destruct(), prior to calling sv_clean_all()
 132                         below.
 133
 134     sv_clean_all() / do_clean_all()
 135                         SvREFCNT_dec(sv) each remaining SV, possibly
 136                         triggering an sv_free(). It also sets the
 137                         SVf_BREAK flag on the SV to indicate that the
 138                         refcnt has been artificially lowered, and thus
 139                         stopping sv_free() from giving spurious warnings
 140                         about SVs which unexpectedly have a refcnt
 141                         of zero.  called repeatedly from perl_destruct()
 142                         until there are no SVs left.
 143
 144 =head2 Arena allocator API Summary
 145
 146 Private API to rest of sv.c
 147
 148     new_SV(),  del_SV(),
 149
 150     new_XIV(), del_XIV(),
 151     new_XNV(), del_XNV(),
 152     etc
 153
 154 Public API:
 155
 156     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
 157
 158 =cut
 159
 160  * ========================================================================= */
 161
 162 /*
 163  * "A time to plant, and a time to uproot what was planted..."
 164  */
 165
 166 void
 167 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
 168 {
 169     dVAR;
 170     void *new_chunk;
 171     U32 new_chunk_size;
 172
 173     PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
 174
 175     new_chunk = (void *)(chunk);
 176     new_chunk_size = (chunk_size);
 177     if (new_chunk_size > PL_nice_chunk_size) {
 178         Safefree(PL_nice_chunk);
 179         PL_nice_chunk = (char *) new_chunk;
 180         PL_nice_chunk_size = new_chunk_size;
 181     } else {
 182         Safefree(chunk);
 183     }
 184 }
 185
 186 #ifdef PERL_MEM_LOG
 187 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
 188             Perl_mem_log_new_sv(sv, file, line, func)
 189 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
 190             Perl_mem_log_del_sv(sv, file, line, func)
 191 #else
 192 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
 193 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
 194 #endif
 195
 196 #ifdef DEBUG_LEAKING_SCALARS
 197 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
 198 #  define DEBUG_SV_SERIAL(sv)                                               \
 199     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
 200             PTR2UV(sv), (long)(sv)->sv_debug_serial))
 201 #else
 202 #  define FREE_SV_DEBUG_FILE(sv)
 203 #  define DEBUG_SV_SERIAL(sv)   NOOP
 204 #endif
 205
 206 #ifdef PERL_POISON
 207 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
 208 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = MUTABLE_SV((val))
 209 /* Whilst I'd love to do this, it seems that things like to check on
 210    unreferenced scalars
 211 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
 212 */
 213 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
 214                                 PoisonNew(&SvREFCNT(sv), 1, U32)
 215 #else
 216 #  define SvARENA_CHAIN(sv)     SvANY(sv)
 217 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
 218 #  define POSION_SV_HEAD(sv)
 219 #endif
 220
 221 /* Mark an SV head as unused, and add to free list.
 222  *
 223  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
 224  * its refcount artificially decremented during global destruction, so
 225  * there may be dangling pointers to it. The last thing we want in that
 226  * case is for it to be reused. */
 227
 228 #define plant_SV(p) \
 229     STMT_START {                                        \
 230         const U32 old_flags = SvFLAGS(p);                       \
 231         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 232         DEBUG_SV_SERIAL(p);                             \
 233         FREE_SV_DEBUG_FILE(p);                          \
 234         POSION_SV_HEAD(p);                              \
 235         SvFLAGS(p) = SVTYPEMASK;                        \
 236         if (!(old_flags & SVf_BREAK)) {         \
 237             SvARENA_CHAIN_SET(p, PL_sv_root);   \
 238             PL_sv_root = (p);                           \
 239         }                                               \
 240         --PL_sv_count;                                  \
 241     } STMT_END
 242
 243 #define uproot_SV(p) \
 244     STMT_START {                                        \
 245         (p) = PL_sv_root;                               \
 246         PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p));              \
 247         ++PL_sv_count;                                  \
 248     } STMT_END
 249
 250
 251 /* make some more SVs by adding another arena */
 252
 253 STATIC SV*
 254 S_more_sv(pTHX)
 255 {
 256     dVAR;
 257     SV* sv;
 258
 259     if (PL_nice_chunk) {
 260         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 261         PL_nice_chunk = NULL;
 262         PL_nice_chunk_size = 0;
 263     }
 264     else {
 265         char *chunk;                /* must use New here to match call to */
 266         Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
 267         sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
 268     }
 269     uproot_SV(sv);
 270     return sv;
 271 }
 272
 273 /* new_SV(): return a new, empty SV head */
 274
 275 #ifdef DEBUG_LEAKING_SCALARS
 276 /* provide a real function for a debugger to play with */
 277 STATIC SV*
 278 S_new_SV(pTHX_ const char *file, int line, const char *func)
 279 {
 280     SV* sv;
 281
 282     if (PL_sv_root)
 283         uproot_SV(sv);
 284     else
 285         sv = S_more_sv(aTHX);
 286     SvANY(sv) = 0;
 287     SvREFCNT(sv) = 1;
 288     SvFLAGS(sv) = 0;
 289     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
 290     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
 291                 ? PL_parser->copline
 292                 :  PL_curcop
 293                     ? CopLINE(PL_curcop)
 294                     : 0
 295             );
 296     sv->sv_debug_inpad = 0;
 297     sv->sv_debug_cloned = 0;
 298     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 299
 300     sv->sv_debug_serial = PL_sv_serial++;
 301
 302     MEM_LOG_NEW_SV(sv, file, line, func);
 303     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
 304             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
 305
 306     return sv;
 307 }
 308 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
 309
 310 #else
 311 #  define new_SV(p) \
 312     STMT_START {                                        \
 313         if (PL_sv_root)                                 \
 314             uproot_SV(p);                               \
 315         else                                            \
 316             (p) = S_more_sv(aTHX);                      \
 317         SvANY(p) = 0;                                   \
 318         SvREFCNT(p) = 1;                                \
 319         SvFLAGS(p) = 0;                                 \
 320         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 321     } STMT_END
 322 #endif
 323
 324
 325 /* del_SV(): return an empty SV head to the free list */
 326
 327 #ifdef DEBUGGING
 328
 329 #define del_SV(p) \
 330     STMT_START {                                        \
 331         if (DEBUG_D_TEST)                               \
 332             del_sv(p);                                  \
 333         else                                            \
 334             plant_SV(p);                                \
 335     } STMT_END
 336
 337 STATIC void
 338 S_del_sv(pTHX_ SV *p)
 339 {
 340     dVAR;
 341
 342     PERL_ARGS_ASSERT_DEL_SV;
 343
 344     if (DEBUG_D_TEST) {
 345         SV* sva;
 346         bool ok = 0;
 347         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 348             const SV * const sv = sva + 1;
 349             const SV * const svend = &sva[SvREFCNT(sva)];
 350             if (p >= sv && p < svend) {
 351                 ok = 1;
 352                 break;
 353             }
 354         }
 355         if (!ok) {
 356             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
 357                              "Attempt to free non-arena SV: 0x%"UVxf
 358                              pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
 359             return;
 360         }
 361     }
 362     plant_SV(p);
 363 }
 364
 365 #else /* ! DEBUGGING */
 366
 367 #define del_SV(p)   plant_SV(p)
 368
 369 #endif /* DEBUGGING */
 370
 371
 372 /*
 373 =head1 SV Manipulation Functions
 374
 375 =for apidoc sv_add_arena
 376
 377 Given a chunk of memory, link it to the head of the list of arenas,
 378 and split it into a list of free SVs.
 379
 380 =cut
 381 */
 382
 383 static void
 384 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
 385 {
 386     dVAR;
 387     SV *const sva = MUTABLE_SV(ptr);
 388     register SV* sv;
 389     register SV* svend;
 390
 391     PERL_ARGS_ASSERT_SV_ADD_ARENA;
 392
 393     /* The first SV in an arena isn't an SV. */
 394     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 395     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 396     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 397
 398     PL_sv_arenaroot = sva;
 399     PL_sv_root = sva + 1;
 400
 401     svend = &sva[SvREFCNT(sva) - 1];
 402     sv = sva + 1;
 403     while (sv < svend) {
 404         SvARENA_CHAIN_SET(sv, (sv + 1));
 405 #ifdef DEBUGGING
 406         SvREFCNT(sv) = 0;
 407 #endif
 408         /* Must always set typemask because it's always checked in on cleanup
 409            when the arenas are walked looking for objects.  */
 410         SvFLAGS(sv) = SVTYPEMASK;
 411         sv++;
 412     }
 413     SvARENA_CHAIN_SET(sv, 0);
 414 #ifdef DEBUGGING
 415     SvREFCNT(sv) = 0;
 416 #endif
 417     SvFLAGS(sv) = SVTYPEMASK;
 418 }
 419
 420 /* visit(): call the named function for each non-free SV in the arenas
 421  * whose flags field matches the flags/mask args. */
 422
 423 STATIC I32
 424 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
 425 {
 426     dVAR;
 427     SV* sva;
 428     I32 visited = 0;
 429
 430     PERL_ARGS_ASSERT_VISIT;
 431
 432     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 433         register const SV * const svend = &sva[SvREFCNT(sva)];
 434         register SV* sv;
 435         for (sv = sva + 1; sv < svend; ++sv) {
 436             if (SvTYPE(sv) != SVTYPEMASK
 437                     && (sv->sv_flags & mask) == flags
 438                     && SvREFCNT(sv))
 439             {
 440                 (FCALL)(aTHX_ sv);
 441                 ++visited;
 442             }
 443         }
 444     }
 445     return visited;
 446 }
 447
 448 #ifdef DEBUGGING
 449
 450 /* called by sv_report_used() for each live SV */
 451
 452 static void
 453 do_report_used(pTHX_ SV *const sv)
 454 {
 455     if (SvTYPE(sv) != SVTYPEMASK) {
 456         PerlIO_printf(Perl_debug_log, "****\n");
 457         sv_dump(sv);
 458     }
 459 }
 460 #endif
 461
 462 /*
 463 =for apidoc sv_report_used
 464
 465 Dump the contents of all SVs not yet freed. (Debugging aid).
 466
 467 =cut
 468 */
 469
 470 void
 471 Perl_sv_report_used(pTHX)
 472 {
 473 #ifdef DEBUGGING
 474     visit(do_report_used, 0, 0);
 475 #else
 476     PERL_UNUSED_CONTEXT;
 477 #endif
 478 }
 479
 480 /* called by sv_clean_objs() for each live SV */
 481
 482 static void
 483 do_clean_objs(pTHX_ SV *const ref)
 484 {
 485     dVAR;
 486     assert (SvROK(ref));
 487     {
 488         SV * const target = SvRV(ref);
 489         if (SvOBJECT(target)) {
 490             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
 491             if (SvWEAKREF(ref)) {
 492                 sv_del_backref(target, ref);
 493                 SvWEAKREF_off(ref);
 494                 SvRV_set(ref, NULL);
 495             } else {
 496                 SvROK_off(ref);
 497                 SvRV_set(ref, NULL);
 498                 SvREFCNT_dec(target);
 499             }
 500         }
 501     }
 502
 503     /* XXX Might want to check arrays, etc. */
 504 }
 505
 506 /* called by sv_clean_objs() for each live SV */
 507
 508 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 509 static void
 510 do_clean_named_objs(pTHX_ SV *const sv)
 511 {
 512     dVAR;
 513     assert(SvTYPE(sv) == SVt_PVGV);
 514     assert(isGV_with_GP(sv));
 515     if (GvGP(sv)) {
 516         if ((
 517 #ifdef PERL_DONT_CREATE_GVSV
 518              GvSV(sv) &&
 519 #endif
 520              SvOBJECT(GvSV(sv))) ||
 521              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
 522              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
 523              /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
 524              (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
 525              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
 526         {
 527             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
 528             SvFLAGS(sv) |= SVf_BREAK;
 529             SvREFCNT_dec(sv);
 530         }
 531     }
 532 }
 533 #endif
 534
 535 /*
 536 =for apidoc sv_clean_objs
 537
 538 Attempt to destroy all objects not yet freed
 539
 540 =cut
 541 */
 542
 543 void
 544 Perl_sv_clean_objs(pTHX)
 545 {
 546     dVAR;
 547     PL_in_clean_objs = TRUE;
 548     visit(do_clean_objs, SVf_ROK, SVf_ROK);
 549 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 550     /* some barnacles may yet remain, clinging to typeglobs */
 551     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
 552 #endif
 553     PL_in_clean_objs = FALSE;
 554 }
 555
 556 /* called by sv_clean_all() for each live SV */
 557
 558 static void
 559 do_clean_all(pTHX_ SV *const sv)
 560 {
 561     dVAR;
 562     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
 563         /* don't clean pid table and strtab */
 564         return;
 565     }
 566     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
 567     SvFLAGS(sv) |= SVf_BREAK;
 568     SvREFCNT_dec(sv);
 569 }
 570
 571 /*
 572 =for apidoc sv_clean_all
 573
 574 Decrement the refcnt of each remaining SV, possibly triggering a
 575 cleanup. This function may have to be called multiple times to free
 576 SVs which are in complex self-referential hierarchies.
 577
 578 =cut
 579 */
 580
 581 I32
 582 Perl_sv_clean_all(pTHX)
 583 {
 584     dVAR;
 585     I32 cleaned;
 586     PL_in_clean_all = TRUE;
 587     cleaned = visit(do_clean_all, 0,0);
 588     PL_in_clean_all = FALSE;
 589     return cleaned;
 590 }
 591
 592 /*
 593   ARENASETS: a meta-arena implementation which separates arena-info
 594   into struct arena_set, which contains an array of struct
 595   arena_descs, each holding info for a single arena.  By separating
 596   the meta-info from the arena, we recover the 1st slot, formerly
 597   borrowed for list management.  The arena_set is about the size of an
 598   arena, avoiding the needless malloc overhead of a naive linked-list.
 599
 600   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
 601   memory in the last arena-set (1/2 on average).  In trade, we get
 602   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
 603   smaller types).  The recovery of the wasted space allows use of
 604   small arenas for large, rare body types, by changing array* fields
 605   in body_details_by_type[] below.
 606 */
 607 struct arena_desc {
 608     char       *arena;          /* the raw storage, allocated aligned */
 609     size_t      size;           /* its size ~4k typ */
 610     svtype      utype;          /* bodytype stored in arena */
 611 };
 612
 613 struct arena_set;
 614
 615 /* Get the maximum number of elements in set[] such that struct arena_set
 616    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
 617    therefore likely to be 1 aligned memory page.  */
 618
 619 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
 620                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
 621
 622 struct arena_set {
 623     struct arena_set* next;
 624     unsigned int   set_size;    /* ie ARENAS_PER_SET */
 625     unsigned int   curr;        /* index of next available arena-desc */
 626     struct arena_desc set[ARENAS_PER_SET];
 627 };
 628
 629 /*
 630 =for apidoc sv_free_arenas
 631
 632 Deallocate the memory used by all arenas. Note that all the individual SV
 633 heads and bodies within the arenas must already have been freed.
 634
 635 =cut
 636 */
 637 void
 638 Perl_sv_free_arenas(pTHX)
 639 {
 640     dVAR;
 641     SV* sva;
 642     SV* svanext;
 643     unsigned int i;
 644
 645     /* Free arenas here, but be careful about fake ones.  (We assume
 646        contiguity of the fake ones with the corresponding real ones.) */
 647
 648     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 649         svanext = MUTABLE_SV(SvANY(sva));
 650         while (svanext && SvFAKE(svanext))
 651             svanext = MUTABLE_SV(SvANY(svanext));
 652
 653         if (!SvFAKE(sva))
 654             Safefree(sva);
 655     }
 656
 657     {
 658         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 659
 660         while (aroot) {
 661             struct arena_set *current = aroot;
 662             i = aroot->curr;
 663             while (i--) {
 664                 assert(aroot->set[i].arena);
 665                 Safefree(aroot->set[i].arena);
 666             }
 667             aroot = aroot->next;
 668             Safefree(current);
 669         }
 670     }
 671     PL_body_arenas = 0;
 672
 673     i = PERL_ARENA_ROOTS_SIZE;
 674     while (i--)
 675         PL_body_roots[i] = 0;
 676
 677     Safefree(PL_nice_chunk);
 678     PL_nice_chunk = NULL;
 679     PL_nice_chunk_size = 0;
 680     PL_sv_arenaroot = 0;
 681     PL_sv_root = 0;
 682 }
 683
 684 /*
 685   Here are mid-level routines that manage the allocation of bodies out
 686   of the various arenas.  There are 5 kinds of arenas:
 687
 688   1. SV-head arenas, which are discussed and handled above
 689   2. regular body arenas
 690   3. arenas for reduced-size bodies
 691   4. Hash-Entry arenas
 692
 693   Arena types 2 & 3 are chained by body-type off an array of
 694   arena-root pointers, which is indexed by svtype.  Some of the
 695   larger/less used body types are malloced singly, since a large
 696   unused block of them is wasteful.  Also, several svtypes dont have
 697   bodies; the data fits into the sv-head itself.  The arena-root
 698   pointer thus has a few unused root-pointers (which may be hijacked
 699   later for arena types 4,5)
 700
 701   3 differs from 2 as an optimization; some body types have several
 702   unused fields in the front of the structure (which are kept in-place
 703   for consistency).  These bodies can be allocated in smaller chunks,
 704   because the leading fields arent accessed.  Pointers to such bodies
 705   are decremented to point at the unused 'ghost' memory, knowing that
 706   the pointers are used with offsets to the real memory.
 707
 708   HE, HEK arenas are managed separately, with separate code, but may
 709   be merge-able later..
 710 */
 711
 712 /* get_arena(size): this creates custom-sized arenas
 713    TBD: export properly for hv.c: S_more_he().
 714 */
 715 void*
 716 Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype)
 717 {
 718     dVAR;
 719     struct arena_desc* adesc;
 720     struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 721     unsigned int curr;
 722
 723     /* shouldnt need this
 724     if (!arena_size)    arena_size = PERL_ARENA_SIZE;
 725     */
 726
 727     /* may need new arena-set to hold new arena */
 728     if (!aroot || aroot->curr >= aroot->set_size) {
 729         struct arena_set *newroot;
 730         Newxz(newroot, 1, struct arena_set);
 731         newroot->set_size = ARENAS_PER_SET;
 732         newroot->next = aroot;
 733         aroot = newroot;
 734         PL_body_arenas = (void *) newroot;
 735         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
 736     }
 737
 738     /* ok, now have arena-set with at least 1 empty/available arena-desc */
 739     curr = aroot->curr++;
 740     adesc = &(aroot->set[curr]);
 741     assert(!adesc->arena);
 742
 743     Newx(adesc->arena, arena_size, char);
 744     adesc->size = arena_size;
 745     adesc->utype = bodytype;
 746     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
 747                           curr, (void*)adesc->arena, (UV)arena_size));
 748
 749     return adesc->arena;
 750 }
 751
 752
 753 /* return a thing to the free list */
 754
 755 #define del_body(thing, root)                   \
 756     STMT_START {                                \
 757         void ** const thing_copy = (void **)thing;\
 758         *thing_copy = *root;                    \
 759         *root = (void*)thing_copy;              \
 760     } STMT_END
 761
 762 /*
 763
 764 =head1 SV-Body Allocation
 765
 766 Allocation of SV-bodies is similar to SV-heads, differing as follows;
 767 the allocation mechanism is used for many body types, so is somewhat
 768 more complicated, it uses arena-sets, and has no need for still-live
 769 SV detection.
 770
 771 At the outermost level, (new|del)_X*V macros return bodies of the
 772 appropriate type.  These macros call either (new|del)_body_type or
 773 (new|del)_body_allocated macro pairs, depending on specifics of the
 774 type.  Most body types use the former pair, the latter pair is used to
 775 allocate body types with "ghost fields".
 776
 777 "ghost fields" are fields that are unused in certain types, and
 778 consequently don't need to actually exist.  They are declared because
 779 they're part of a "base type", which allows use of functions as
 780 methods.  The simplest examples are AVs and HVs, 2 aggregate types
 781 which don't use the fields which support SCALAR semantics.
 782
 783 For these types, the arenas are carved up into appropriately sized
 784 chunks, we thus avoid wasted memory for those unaccessed members.
 785 When bodies are allocated, we adjust the pointer back in memory by the
 786 size of the part not allocated, so it's as if we allocated the full
 787 structure.  (But things will all go boom if you write to the part that
 788 is "not there", because you'll be overwriting the last members of the
 789 preceding structure in memory.)
 790
 791 We calculate the correction using the STRUCT_OFFSET macro on the first
 792 member present. If the allocated structure is smaller (no initial NV
 793 actually allocated) then the net effect is to subtract the size of the NV
 794 from the pointer, to return a new pointer as if an initial NV were actually
 795 allocated. (We were using structures named *_allocated for this, but
 796 this turned out to be a subtle bug, because a structure without an NV
 797 could have a lower alignment constraint, but the compiler is allowed to
 798 optimised accesses based on the alignment constraint of the actual pointer
 799 to the full structure, for example, using a single 64 bit load instruction
 800 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
 801
 802 This is the same trick as was used for NV and IV bodies. Ironically it
 803 doesn't need to be used for NV bodies any more, because NV is now at
 804 the start of the structure. IV bodies don't need it either, because
 805 they are no longer allocated.
 806
 807 In turn, the new_body_* allocators call S_new_body(), which invokes
 808 new_body_inline macro, which takes a lock, and takes a body off the
 809 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
 810 necessary to refresh an empty list.  Then the lock is released, and
 811 the body is returned.
 812
 813 S_more_bodies calls get_arena(), and carves it up into an array of N
 814 bodies, which it strings into a linked list.  It looks up arena-size
 815 and body-size from the body_details table described below, thus
 816 supporting the multiple body-types.
 817
 818 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
 819 the (new|del)_X*V macros are mapped directly to malloc/free.
 820
 821 */
 822
 823 /*
 824
 825 For each sv-type, struct body_details bodies_by_type[] carries
 826 parameters which control these aspects of SV handling:
 827
 828 Arena_size determines whether arenas are used for this body type, and if
 829 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
 830 zero, forcing individual mallocs and frees.
 831
 832 Body_size determines how big a body is, and therefore how many fit into
 833 each arena.  Offset carries the body-pointer adjustment needed for
 834 "ghost fields", and is used in *_allocated macros.
 835
 836 But its main purpose is to parameterize info needed in
 837 Perl_sv_upgrade().  The info here dramatically simplifies the function
 838 vs the implementation in 5.8.8, making it table-driven.  All fields
 839 are used for this, except for arena_size.
 840
 841 For the sv-types that have no bodies, arenas are not used, so those
 842 PL_body_roots[sv_type] are unused, and can be overloaded.  In
 843 something of a special case, SVt_NULL is borrowed for HE arenas;
 844 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
 845 bodies_by_type[SVt_NULL] slot is not used, as the table is not
 846 available in hv.c.
 847
 848 */
 849
 850 struct body_details {
 851     U8 body_size;       /* Size to allocate  */
 852     U8 copy;            /* Size of structure to copy (may be shorter)  */
 853     U8 offset;
 854     unsigned int type : 4;          /* We have space for a sanity check.  */
 855     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
 856     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
 857     unsigned int arena : 1;         /* Allocated from an arena */
 858     size_t arena_size;              /* Size of arena to allocate */
 859 };
 860
 861 #define HADNV FALSE
 862 #define NONV TRUE
 863
 864
 865 #ifdef PURIFY
 866 /* With -DPURFIY we allocate everything directly, and don't use arenas.
 867    This seems a rather elegant way to simplify some of the code below.  */
 868 #define HASARENA FALSE
 869 #else
 870 #define HASARENA TRUE
 871 #endif
 872 #define NOARENA FALSE
 873
 874 /* Size the arenas to exactly fit a given number of bodies.  A count
 875    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
 876    simplifying the default.  If count > 0, the arena is sized to fit
 877    only that many bodies, allowing arenas to be used for large, rare
 878    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
 879    limited by PERL_ARENA_SIZE, so we can safely oversize the
 880    declarations.
 881  */
 882 #define FIT_ARENA0(body_size)                           \
 883     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
 884 #define FIT_ARENAn(count,body_size)                     \
 885     ( count * body_size <= PERL_ARENA_SIZE)             \
 886     ? count * body_size                                 \
 887     : FIT_ARENA0 (body_size)
 888 #define FIT_ARENA(count,body_size)                      \
 889     count                                               \
 890     ? FIT_ARENAn (count, body_size)                     \
 891     : FIT_ARENA0 (body_size)
 892
 893 /* Calculate the length to copy. Specifically work out the length less any
 894    final padding the compiler needed to add.  See the comment in sv_upgrade
 895    for why copying the padding proved to be a bug.  */
 896
 897 #define copy_length(type, last_member) \
 898         STRUCT_OFFSET(type, last_member) \
 899         + sizeof (((type*)SvANY((const SV *)0))->last_member)
 900
 901 static const struct body_details bodies_by_type[] = {
 902     { sizeof(HE), 0, 0, SVt_NULL,
 903       FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
 904
 905     /* The bind placeholder pretends to be an RV for now.
 906        Also it's marked as "can't upgrade" to stop anyone using it before it's
 907        implemented.  */
 908     { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
 909
 910     /* IVs are in the head, so the allocation size is 0.  */
 911     { 0,
 912       sizeof(IV), /* This is used to copy out the IV body.  */
 913       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
 914       NOARENA /* IVS don't need an arena  */, 0
 915     },
 916
 917     /* 8 bytes on most ILP32 with IEEE doubles */
 918     { sizeof(NV), sizeof(NV),
 919       STRUCT_OFFSET(XPVNV, xnv_u),
 920       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
 921
 922     /* 8 bytes on most ILP32 with IEEE doubles */
 923     { sizeof(XPV),
 924       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
 925       + STRUCT_OFFSET(XPV, xpv_cur),
 926       SVt_PV, FALSE, NONV, HASARENA,
 927       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 928
 929 #if 2 *PTRSIZE <= IVSIZE
 930     /* 12 */
 931     { sizeof(XPVIV),
 932       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 933       + STRUCT_OFFSET(XPV, xpv_cur),
 934       SVt_PVIV, FALSE, NONV, HASARENA,
 935       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 936     /* 12 */
 937 #else
 938     { sizeof(XPVIV),
 939       copy_length(XPVIV, xiv_u),
 940       0,
 941       SVt_PVIV, FALSE, NONV, HASARENA,
 942       FIT_ARENA(0, sizeof(XPVIV)) },
 943 #endif
 944
 945 #if (2 *PTRSIZE <= IVSIZE) && (2 *PTRSIZE <= NVSIZE)
 946     /* 20 */
 947     { sizeof(XPVNV),
 948       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 949       + STRUCT_OFFSET(XPV, xpv_cur),
 950       SVt_PVNV, FALSE, HADNV, HASARENA,
 951       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 952 #else
 953     /* 20 */
 954     { sizeof(XPVNV), copy_length(XPVNV, xnv_u), 0, SVt_PVNV, FALSE, HADNV,
 955       HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
 956 #endif
 957
 958     /* 28 */
 959     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
 960       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 961
 962     /* something big */
 963     { sizeof(regexp),
 964       sizeof(regexp),
 965       0,
 966       SVt_REGEXP, FALSE, NONV, HASARENA,
 967       FIT_ARENA(0, sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur))
 968     },
 969
 970     /* 48 */
 971     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
 972       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
 973
 974     /* 64 */
 975     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
 976       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
 977
 978     { sizeof(XPVAV),
 979       copy_length(XPVAV, xav_alloc),
 980       0,
 981       SVt_PVAV, TRUE, NONV, HASARENA,
 982       FIT_ARENA(0, sizeof(XPVAV)) },
 983
 984     { sizeof(XPVHV),
 985       copy_length(XPVHV, xhv_max),
 986       0,
 987       SVt_PVHV, TRUE, NONV, HASARENA,
 988       FIT_ARENA(0, sizeof(XPVHV)) },
 989
 990     /* 56 */
 991     { sizeof(XPVCV),
 992       sizeof(XPVCV),
 993       0,
 994       SVt_PVCV, TRUE, NONV, HASARENA,
 995       FIT_ARENA(0, sizeof(XPVCV)) },
 996
 997     { sizeof(XPVFM),
 998       sizeof(XPVFM),
 999       0,
1000       SVt_PVFM, TRUE, NONV, NOARENA,
1001       FIT_ARENA(20, sizeof(XPVFM)) },
1002
1003     /* XPVIO is 84 bytes, fits 48x */
1004     { sizeof(XPVIO),
1005       sizeof(XPVIO),
1006       0,
1007       SVt_PVIO, TRUE, NONV, HASARENA,
1008       FIT_ARENA(24, sizeof(XPVIO)) },
1009 };
1010
1011 #define new_body_allocated(sv_type)             \
1012     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1013              - bodies_by_type[sv_type].offset)
1014
1015 #define del_body_allocated(p, sv_type)          \
1016     del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1017
1018
1019 #define my_safemalloc(s)        (void*)safemalloc(s)
1020 #define my_safecalloc(s)        (void*)safecalloc(s, 1)
1021 #define my_safefree(p)  safefree((char*)p)
1022
1023 #ifdef PURIFY
1024
1025 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
1026 #define del_XNV(p)      my_safefree(p)
1027
1028 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
1029 #define del_XPVNV(p)    my_safefree(p)
1030
1031 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
1032 #define del_XPVAV(p)    my_safefree(p)
1033
1034 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
1035 #define del_XPVHV(p)    my_safefree(p)
1036
1037 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
1038 #define del_XPVMG(p)    my_safefree(p)
1039
1040 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
1041 #define del_XPVGV(p)    my_safefree(p)
1042
1043 #else /* !PURIFY */
1044
1045 #define new_XNV()       new_body_allocated(SVt_NV)
1046 #define del_XNV(p)      del_body_allocated(p, SVt_NV)
1047
1048 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
1049 #define del_XPVNV(p)    del_body_allocated(p, SVt_PVNV)
1050
1051 #define new_XPVAV()     new_body_allocated(SVt_PVAV)
1052 #define del_XPVAV(p)    del_body_allocated(p, SVt_PVAV)
1053
1054 #define new_XPVHV()     new_body_allocated(SVt_PVHV)
1055 #define del_XPVHV(p)    del_body_allocated(p, SVt_PVHV)
1056
1057 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
1058 #define del_XPVMG(p)    del_body_allocated(p, SVt_PVMG)
1059
1060 #define new_XPVGV()     new_body_allocated(SVt_PVGV)
1061 #define del_XPVGV(p)    del_body_allocated(p, SVt_PVGV)
1062
1063 #endif /* PURIFY */
1064
1065 /* no arena for you! */
1066
1067 #define new_NOARENA(details) \
1068         my_safemalloc((details)->body_size + (details)->offset)
1069 #define new_NOARENAZ(details) \
1070         my_safecalloc((details)->body_size + (details)->offset)
1071
1072 STATIC void *
1073 S_more_bodies (pTHX_ const svtype sv_type)
1074 {
1075     dVAR;
1076     void ** const root = &PL_body_roots[sv_type];
1077     const struct body_details * const bdp = &bodies_by_type[sv_type];
1078     const size_t body_size = bdp->body_size;
1079     char *start;
1080     const char *end;
1081     const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1082 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1083     static bool done_sanity_check;
1084
1085     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1086      * variables like done_sanity_check. */
1087     if (!done_sanity_check) {
1088         unsigned int i = SVt_LAST;
1089
1090         done_sanity_check = TRUE;
1091
1092         while (i--)
1093             assert (bodies_by_type[i].type == i);
1094     }
1095 #endif
1096
1097     assert(bdp->arena_size);
1098
1099     start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1100
1101     end = start + arena_size - 2 * body_size;
1102
1103     /* computed count doesnt reflect the 1st slot reservation */
1104 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1105     DEBUG_m(PerlIO_printf(Perl_debug_log,
1106                           "arena %p end %p arena-size %d (from %d) type %d "
1107                           "size %d ct %d\n",
1108                           (void*)start, (void*)end, (int)arena_size,
1109                           (int)bdp->arena_size, sv_type, (int)body_size,
1110                           (int)arena_size / (int)body_size));
1111 #else
1112     DEBUG_m(PerlIO_printf(Perl_debug_log,
1113                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1114                           (void*)start, (void*)end,
1115                           (int)bdp->arena_size, sv_type, (int)body_size,
1116                           (int)bdp->arena_size / (int)body_size));
1117 #endif
1118     *root = (void *)start;
1119
1120     while (start <= end) {
1121         char * const next = start + body_size;
1122         *(void**) start = (void *)next;
1123         start = next;
1124     }
1125     *(void **)start = 0;
1126
1127     return *root;
1128 }
1129
1130 /* grab a new thing from the free list, allocating more if necessary.
1131    The inline version is used for speed in hot routines, and the
1132    function using it serves the rest (unless PURIFY).
1133 */
1134 #define new_body_inline(xpv, sv_type) \
1135     STMT_START { \
1136         void ** const r3wt = &PL_body_roots[sv_type]; \
1137         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1138           ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1139         *(r3wt) = *(void**)(xpv); \
1140     } STMT_END
1141
1142 #ifndef PURIFY
1143
1144 STATIC void *
1145 S_new_body(pTHX_ const svtype sv_type)
1146 {
1147     dVAR;
1148     void *xpv;
1149     new_body_inline(xpv, sv_type);
1150     return xpv;
1151 }
1152
1153 #endif
1154
1155 static const struct body_details fake_rv =
1156     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1157
1158 /*
1159 =for apidoc sv_upgrade
1160
1161 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1162 SV, then copies across as much information as possible from the old body.
1163 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1164
1165 =cut
1166 */
1167
1168 void
1169 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1170 {
1171     dVAR;
1172     void*       old_body;
1173     void*       new_body;
1174     const svtype old_type = SvTYPE(sv);
1175     const struct body_details *new_type_details;
1176     const struct body_details *old_type_details
1177         = bodies_by_type + old_type;
1178     SV *referant = NULL;
1179
1180     PERL_ARGS_ASSERT_SV_UPGRADE;
1181
1182     if (old_type == new_type)
1183         return;
1184
1185     /* This clause was purposefully added ahead of the early return above to
1186        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1187        inference by Nick I-S that it would fix other troublesome cases. See
1188        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1189
1190        Given that shared hash key scalars are no longer PVIV, but PV, there is
1191        no longer need to unshare so as to free up the IVX slot for its proper
1192        purpose. So it's safe to move the early return earlier.  */
1193
1194     if (new_type != SVt_PV && SvIsCOW(sv)) {
1195         sv_force_normal_flags(sv, 0);
1196     }
1197
1198     old_body = SvANY(sv);
1199
1200     /* Copying structures onto other structures that have been neatly zeroed
1201        has a subtle gotcha. Consider XPVMG
1202
1203        +------+------+------+------+------+-------+-------+
1204        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1205        +------+------+------+------+------+-------+-------+
1206        0      4      8     12     16     20      24      28
1207
1208        where NVs are aligned to 8 bytes, so that sizeof that structure is
1209        actually 32 bytes long, with 4 bytes of padding at the end:
1210
1211        +------+------+------+------+------+-------+-------+------+
1212        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1213        +------+------+------+------+------+-------+-------+------+
1214        0      4      8     12     16     20      24      28     32
1215
1216        so what happens if you allocate memory for this structure:
1217
1218        +------+------+------+------+------+-------+-------+------+------+...
1219        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1220        +------+------+------+------+------+-------+-------+------+------+...
1221        0      4      8     12     16     20      24      28     32     36
1222
1223        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1224        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1225        started out as zero once, but it's quite possible that it isn't. So now,
1226        rather than a nicely zeroed GP, you have it pointing somewhere random.
1227        Bugs ensue.
1228
1229        (In fact, GP ends up pointing at a previous GP structure, because the
1230        principle cause of the padding in XPVMG getting garbage is a copy of
1231        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1232        this happens to be moot because XPVGV has been re-ordered, with GP
1233        no longer after STASH)
1234
1235        So we are careful and work out the size of used parts of all the
1236        structures.  */
1237
1238     switch (old_type) {
1239     case SVt_NULL:
1240         break;
1241     case SVt_IV:
1242         if (SvROK(sv)) {
1243             referant = SvRV(sv);
1244             old_type_details = &fake_rv;
1245             if (new_type == SVt_NV)
1246                 new_type = SVt_PVNV;
1247         } else {
1248             if (new_type < SVt_PVIV) {
1249                 new_type = (new_type == SVt_NV)
1250                     ? SVt_PVNV : SVt_PVIV;
1251             }
1252         }
1253         break;
1254     case SVt_NV:
1255         if (new_type < SVt_PVNV) {
1256             new_type = SVt_PVNV;
1257         }
1258         break;
1259     case SVt_PV:
1260         assert(new_type > SVt_PV);
1261         assert(SVt_IV < SVt_PV);
1262         assert(SVt_NV < SVt_PV);
1263         break;
1264     case SVt_PVIV:
1265         break;
1266     case SVt_PVNV:
1267         break;
1268     case SVt_PVMG:
1269         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1270            there's no way that it can be safely upgraded, because perl.c
1271            expects to Safefree(SvANY(PL_mess_sv))  */
1272         assert(sv != PL_mess_sv);
1273         /* This flag bit is used to mean other things in other scalar types.
1274            Given that it only has meaning inside the pad, it shouldn't be set
1275            on anything that can get upgraded.  */
1276         assert(!SvPAD_TYPED(sv));
1277         break;
1278     default:
1279         if (old_type_details->cant_upgrade)
1280             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1281                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1282     }
1283
1284     if (old_type > new_type)
1285         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1286                 (int)old_type, (int)new_type);
1287
1288     new_type_details = bodies_by_type + new_type;
1289
1290     SvFLAGS(sv) &= ~SVTYPEMASK;
1291     SvFLAGS(sv) |= new_type;
1292
1293     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1294        the return statements above will have triggered.  */
1295     assert (new_type != SVt_NULL);
1296     switch (new_type) {
1297     case SVt_IV:
1298         assert(old_type == SVt_NULL);
1299         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1300         SvIV_set(sv, 0);
1301         return;
1302     case SVt_NV:
1303         assert(old_type == SVt_NULL);
1304         SvANY(sv) = new_XNV();
1305         SvNV_set(sv, 0);
1306         return;
1307     case SVt_PVHV:
1308     case SVt_PVAV:
1309         assert(new_type_details->body_size);
1310
1311 #ifndef PURIFY
1312         assert(new_type_details->arena);
1313         assert(new_type_details->arena_size);
1314         /* This points to the start of the allocated area.  */
1315         new_body_inline(new_body, new_type);
1316         Zero(new_body, new_type_details->body_size, char);
1317         new_body = ((char *)new_body) - new_type_details->offset;
1318 #else
1319         /* We always allocated the full length item with PURIFY. To do this
1320            we fake things so that arena is false for all 16 types..  */
1321         new_body = new_NOARENAZ(new_type_details);
1322 #endif
1323         SvANY(sv) = new_body;
1324         if (new_type == SVt_PVAV) {
1325             AvMAX(sv)   = -1;
1326             AvFILLp(sv) = -1;
1327             AvREAL_only(sv);
1328             if (old_type_details->body_size) {
1329                 AvALLOC(sv) = 0;
1330             } else {
1331                 /* It will have been zeroed when the new body was allocated.
1332                    Lets not write to it, in case it confuses a write-back
1333                    cache.  */
1334             }
1335         } else {
1336             assert(!SvOK(sv));
1337             SvOK_off(sv);
1338 #ifndef NODEFAULT_SHAREKEYS
1339             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1340 #endif
1341             HvMAX(sv) = 7; /* (start with 8 buckets) */
1342         }
1343
1344         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1345            The target created by newSVrv also is, and it can have magic.
1346            However, it never has SvPVX set.
1347         */
1348         if (old_type == SVt_IV) {
1349             assert(!SvROK(sv));
1350         } else if (old_type >= SVt_PV) {
1351             assert(SvPVX_const(sv) == 0);
1352         }
1353
1354         if (old_type >= SVt_PVMG) {
1355             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1356             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1357         } else {
1358             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1359         }
1360         break;
1361
1362
1363     case SVt_REGEXP:
1364         /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1365            sv_force_normal_flags(sv) is called.  */
1366         SvFAKE_on(sv);
1367     case SVt_PVIV:
1368         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1369            no route from NV to PVIV, NOK can never be true  */
1370         assert(!SvNOKp(sv));
1371         assert(!SvNOK(sv));
1372     case SVt_PVIO:
1373     case SVt_PVFM:
1374     case SVt_PVGV:
1375     case SVt_PVCV:
1376     case SVt_PVLV:
1377     case SVt_PVMG:
1378     case SVt_PVNV:
1379     case SVt_PV:
1380
1381         assert(new_type_details->body_size);
1382         /* We always allocated the full length item with PURIFY. To do this
1383            we fake things so that arena is false for all 16 types..  */
1384         if(new_type_details->arena) {
1385             /* This points to the start of the allocated area.  */
1386             new_body_inline(new_body, new_type);
1387             Zero(new_body, new_type_details->body_size, char);
1388             new_body = ((char *)new_body) - new_type_details->offset;
1389         } else {
1390             new_body = new_NOARENAZ(new_type_details);
1391         }
1392         SvANY(sv) = new_body;
1393
1394         if (old_type_details->copy) {
1395             /* There is now the potential for an upgrade from something without
1396                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1397             int offset = old_type_details->offset;
1398             int length = old_type_details->copy;
1399
1400             if (new_type_details->offset > old_type_details->offset) {
1401                 const int difference
1402                     = new_type_details->offset - old_type_details->offset;
1403                 offset += difference;
1404                 length -= difference;
1405             }
1406             assert (length >= 0);
1407
1408             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1409                  char);
1410         }
1411
1412 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1413         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1414          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1415          * NV slot, but the new one does, then we need to initialise the
1416          * freshly created NV slot with whatever the correct bit pattern is
1417          * for 0.0  */
1418         if (old_type_details->zero_nv && !new_type_details->zero_nv
1419             && !isGV_with_GP(sv))
1420             SvNV_set(sv, 0);
1421 #endif
1422
1423         if (new_type == SVt_PVIO) {
1424             IO * const io = MUTABLE_IO(sv);
1425             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1426
1427             SvOBJECT_on(io);
1428             /* Clear the stashcache because a new IO could overrule a package
1429                name */
1430             hv_clear(PL_stashcache);
1431
1432             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1433             IoPAGE_LEN(sv) = 60;
1434         }
1435         if (old_type < SVt_PV) {
1436             /* referant will be NULL unless the old type was SVt_IV emulating
1437                SVt_RV */
1438             sv->sv_u.svu_rv = referant;
1439         }
1440         break;
1441     default:
1442         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1443                    (unsigned long)new_type);
1444     }
1445
1446     if (old_type > SVt_IV) {
1447 #ifdef PURIFY
1448         my_safefree(old_body);
1449 #else
1450         /* Note that there is an assumption that all bodies of types that
1451            can be upgraded came from arenas. Only the more complex non-
1452            upgradable types are allowed to be directly malloc()ed.  */
1453         assert(old_type_details->arena);
1454         del_body((void*)((char*)old_body + old_type_details->offset),
1455                  &PL_body_roots[old_type]);
1456 #endif
1457     }
1458 }
1459
1460 /*
1461 =for apidoc sv_backoff
1462
1463 Remove any string offset. You should normally use the C<SvOOK_off> macro
1464 wrapper instead.
1465
1466 =cut
1467 */
1468
1469 int
1470 Perl_sv_backoff(pTHX_ register SV *const sv)
1471 {
1472     STRLEN delta;
1473     const char * const s = SvPVX_const(sv);
1474
1475     PERL_ARGS_ASSERT_SV_BACKOFF;
1476     PERL_UNUSED_CONTEXT;
1477
1478     assert(SvOOK(sv));
1479     assert(SvTYPE(sv) != SVt_PVHV);
1480     assert(SvTYPE(sv) != SVt_PVAV);
1481
1482     SvOOK_offset(sv, delta);
1483
1484     SvLEN_set(sv, SvLEN(sv) + delta);
1485     SvPV_set(sv, SvPVX(sv) - delta);
1486     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1487     SvFLAGS(sv) &= ~SVf_OOK;
1488     return 0;
1489 }
1490
1491 /*
1492 =for apidoc sv_grow
1493
1494 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1495 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1496 Use the C<SvGROW> wrapper instead.
1497
1498 =cut
1499 */
1500
1501 char *
1502 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1503 {
1504     register char *s;
1505
1506     PERL_ARGS_ASSERT_SV_GROW;
1507
1508     if (PL_madskills && newlen >= 0x100000) {
1509         PerlIO_printf(Perl_debug_log,
1510                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1511     }
1512 #ifdef HAS_64K_LIMIT
1513     if (newlen >= 0x10000) {
1514         PerlIO_printf(Perl_debug_log,
1515                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1516         my_exit(1);
1517     }
1518 #endif /* HAS_64K_LIMIT */
1519     if (SvROK(sv))
1520         sv_unref(sv);
1521     if (SvTYPE(sv) < SVt_PV) {
1522         sv_upgrade(sv, SVt_PV);
1523         s = SvPVX_mutable(sv);
1524     }
1525     else if (SvOOK(sv)) {       /* pv is offset? */
1526         sv_backoff(sv);
1527         s = SvPVX_mutable(sv);
1528         if (newlen > SvLEN(sv))
1529             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1530 #ifdef HAS_64K_LIMIT
1531         if (newlen >= 0x10000)
1532             newlen = 0xFFFF;
1533 #endif
1534     }
1535     else
1536         s = SvPVX_mutable(sv);
1537
1538     if (newlen > SvLEN(sv)) {           /* need more room? */
1539 #ifndef Perl_safesysmalloc_size
1540         newlen = PERL_STRLEN_ROUNDUP(newlen);
1541 #endif
1542         if (SvLEN(sv) && s) {
1543             s = (char*)saferealloc(s, newlen);
1544         }
1545         else {
1546             s = (char*)safemalloc(newlen);
1547             if (SvPVX_const(sv) && SvCUR(sv)) {
1548                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1549             }
1550         }
1551         SvPV_set(sv, s);
1552 #ifdef Perl_safesysmalloc_size
1553         /* Do this here, do it once, do it right, and then we will never get
1554            called back into sv_grow() unless there really is some growing
1555            needed.  */
1556         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1557 #else
1558         SvLEN_set(sv, newlen);
1559 #endif
1560     }
1561     return s;
1562 }
1563
1564 /*
1565 =for apidoc sv_setiv
1566
1567 Copies an integer into the given SV, upgrading first if necessary.
1568 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1569
1570 =cut
1571 */
1572
1573 void
1574 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1575 {
1576     dVAR;
1577
1578     PERL_ARGS_ASSERT_SV_SETIV;
1579
1580     SV_CHECK_THINKFIRST_COW_DROP(sv);
1581     switch (SvTYPE(sv)) {
1582     case SVt_NULL:
1583     case SVt_NV:
1584         sv_upgrade(sv, SVt_IV);
1585         break;
1586     case SVt_PV:
1587         sv_upgrade(sv, SVt_PVIV);
1588         break;
1589
1590     case SVt_PVGV:
1591         if (!isGV_with_GP(sv))
1592             break;
1593     case SVt_PVAV:
1594     case SVt_PVHV:
1595     case SVt_PVCV:
1596     case SVt_PVFM:
1597     case SVt_PVIO:
1598         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1599                    OP_DESC(PL_op));
1600     default: NOOP;
1601     }
1602     (void)SvIOK_only(sv);                       /* validate number */
1603     SvIV_set(sv, i);
1604     SvTAINT(sv);
1605 }
1606
1607 /*
1608 =for apidoc sv_setiv_mg
1609
1610 Like C<sv_setiv>, but also handles 'set' magic.
1611
1612 =cut
1613 */
1614
1615 void
1616 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1617 {
1618     PERL_ARGS_ASSERT_SV_SETIV_MG;
1619
1620     sv_setiv(sv,i);
1621     SvSETMAGIC(sv);
1622 }
1623
1624 /*
1625 =for apidoc sv_setuv
1626
1627 Copies an unsigned integer into the given SV, upgrading first if necessary.
1628 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1629
1630 =cut
1631 */
1632
1633 void
1634 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1635 {
1636     PERL_ARGS_ASSERT_SV_SETUV;
1637
1638     /* With these two if statements:
1639        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1640
1641        without
1642        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1643
1644        If you wish to remove them, please benchmark to see what the effect is
1645     */
1646     if (u <= (UV)IV_MAX) {
1647        sv_setiv(sv, (IV)u);
1648        return;
1649     }
1650     sv_setiv(sv, 0);
1651     SvIsUV_on(sv);
1652     SvUV_set(sv, u);
1653 }
1654
1655 /*
1656 =for apidoc sv_setuv_mg
1657
1658 Like C<sv_setuv>, but also handles 'set' magic.
1659
1660 =cut
1661 */
1662
1663 void
1664 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1665 {
1666     PERL_ARGS_ASSERT_SV_SETUV_MG;
1667
1668     sv_setuv(sv,u);
1669     SvSETMAGIC(sv);
1670 }
1671
1672 /*
1673 =for apidoc sv_setnv
1674
1675 Copies a double into the given SV, upgrading first if necessary.
1676 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1677
1678 =cut
1679 */
1680
1681 void
1682 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1683 {
1684     dVAR;
1685
1686     PERL_ARGS_ASSERT_SV_SETNV;
1687
1688     SV_CHECK_THINKFIRST_COW_DROP(sv);
1689     switch (SvTYPE(sv)) {
1690     case SVt_NULL:
1691     case SVt_IV:
1692         sv_upgrade(sv, SVt_NV);
1693         break;
1694     case SVt_PV:
1695     case SVt_PVIV:
1696         sv_upgrade(sv, SVt_PVNV);
1697         break;
1698
1699     case SVt_PVGV:
1700         if (!isGV_with_GP(sv))
1701             break;
1702     case SVt_PVAV:
1703     case SVt_PVHV:
1704     case SVt_PVCV:
1705     case SVt_PVFM:
1706     case SVt_PVIO:
1707         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1708                    OP_DESC(PL_op));
1709     default: NOOP;
1710     }
1711     SvNV_set(sv, num);
1712     (void)SvNOK_only(sv);                       /* validate number */
1713     SvTAINT(sv);
1714 }
1715
1716 /*
1717 =for apidoc sv_setnv_mg
1718
1719 Like C<sv_setnv>, but also handles 'set' magic.
1720
1721 =cut
1722 */
1723
1724 void
1725 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1726 {
1727     PERL_ARGS_ASSERT_SV_SETNV_MG;
1728
1729     sv_setnv(sv,num);
1730     SvSETMAGIC(sv);
1731 }
1732
1733 /* Print an "isn't numeric" warning, using a cleaned-up,
1734  * printable version of the offending string
1735  */
1736
1737 STATIC void
1738 S_not_a_number(pTHX_ SV *const sv)
1739 {
1740      dVAR;
1741      SV *dsv;
1742      char tmpbuf[64];
1743      const char *pv;
1744
1745      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1746
1747      if (DO_UTF8(sv)) {
1748           dsv = newSVpvs_flags("", SVs_TEMP);
1749           pv = sv_uni_display(dsv, sv, 10, 0);
1750      } else {
1751           char *d = tmpbuf;
1752           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1753           /* each *s can expand to 4 chars + "...\0",
1754              i.e. need room for 8 chars */
1755
1756           const char *s = SvPVX_const(sv);
1757           const char * const end = s + SvCUR(sv);
1758           for ( ; s < end && d < limit; s++ ) {
1759                int ch = *s & 0xFF;
1760                if (ch & 128 && !isPRINT_LC(ch)) {
1761                     *d++ = 'M';
1762                     *d++ = '-';
1763                     ch &= 127;
1764                }
1765                if (ch == '\n') {
1766                     *d++ = '\\';
1767                     *d++ = 'n';
1768                }
1769                else if (ch == '\r') {
1770                     *d++ = '\\';
1771                     *d++ = 'r';
1772                }
1773                else if (ch == '\f') {
1774                     *d++ = '\\';
1775                     *d++ = 'f';
1776                }
1777                else if (ch == '\\') {
1778                     *d++ = '\\';
1779                     *d++ = '\\';
1780                }
1781                else if (ch == '\0') {
1782                     *d++ = '\\';
1783                     *d++ = '0';
1784                }
1785                else if (isPRINT_LC(ch))
1786                     *d++ = ch;
1787                else {
1788                     *d++ = '^';
1789                     *d++ = toCTRL(ch);
1790                }
1791           }
1792           if (s < end) {
1793                *d++ = '.';
1794                *d++ = '.';
1795                *d++ = '.';
1796           }
1797           *d = '\0';
1798           pv = tmpbuf;
1799     }
1800
1801     if (PL_op)
1802         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1803                     "Argument \"%s\" isn't numeric in %s", pv,
1804                     OP_DESC(PL_op));
1805     else
1806         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1807                     "Argument \"%s\" isn't numeric", pv);
1808 }
1809
1810 /*
1811 =for apidoc looks_like_number
1812
1813 Test if the content of an SV looks like a number (or is a number).
1814 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1815 non-numeric warning), even if your atof() doesn't grok them.
1816
1817 =cut
1818 */
1819
1820 I32
1821 Perl_looks_like_number(pTHX_ SV *const sv)
1822 {
1823     register const char *sbegin;
1824     STRLEN len;
1825
1826     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1827
1828     if (SvPOK(sv)) {
1829         sbegin = SvPVX_const(sv);
1830         len = SvCUR(sv);
1831     }
1832     else if (SvPOKp(sv))
1833         sbegin = SvPV_const(sv, len);
1834     else
1835         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1836     return grok_number(sbegin, len, NULL);
1837 }
1838
1839 STATIC bool
1840 S_glob_2number(pTHX_ GV * const gv)
1841 {
1842     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1843     SV *const buffer = sv_newmortal();
1844
1845     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1846
1847     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1848        is on.  */
1849     SvFAKE_off(gv);
1850     gv_efullname3(buffer, gv, "*");
1851     SvFLAGS(gv) |= wasfake;
1852
1853     /* We know that all GVs stringify to something that is not-a-number,
1854         so no need to test that.  */
1855     if (ckWARN(WARN_NUMERIC))
1856         not_a_number(buffer);
1857     /* We just want something true to return, so that S_sv_2iuv_common
1858         can tail call us and return true.  */
1859     return TRUE;
1860 }
1861
1862 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1863    until proven guilty, assume that things are not that bad... */
1864
1865 /*
1866    NV_PRESERVES_UV:
1867
1868    As 64 bit platforms often have an NV that doesn't preserve all bits of
1869    an IV (an assumption perl has been based on to date) it becomes necessary
1870    to remove the assumption that the NV always carries enough precision to
1871    recreate the IV whenever needed, and that the NV is the canonical form.
1872    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1873    precision as a side effect of conversion (which would lead to insanity
1874    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1875    1) to distinguish between IV/UV/NV slots that have cached a valid
1876       conversion where precision was lost and IV/UV/NV slots that have a
1877       valid conversion which has lost no precision
1878    2) to ensure that if a numeric conversion to one form is requested that
1879       would lose precision, the precise conversion (or differently
1880       imprecise conversion) is also performed and cached, to prevent
1881       requests for different numeric formats on the same SV causing
1882       lossy conversion chains. (lossless conversion chains are perfectly
1883       acceptable (still))
1884
1885
1886    flags are used:
1887    SvIOKp is true if the IV slot contains a valid value
1888    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1889    SvNOKp is true if the NV slot contains a valid value
1890    SvNOK  is true only if the NV value is accurate
1891
1892    so
1893    while converting from PV to NV, check to see if converting that NV to an
1894    IV(or UV) would lose accuracy over a direct conversion from PV to
1895    IV(or UV). If it would, cache both conversions, return NV, but mark
1896    SV as IOK NOKp (ie not NOK).
1897
1898    While converting from PV to IV, check to see if converting that IV to an
1899    NV would lose accuracy over a direct conversion from PV to NV. If it
1900    would, cache both conversions, flag similarly.
1901
1902    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1903    correctly because if IV & NV were set NV *always* overruled.
1904    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1905    changes - now IV and NV together means that the two are interchangeable:
1906    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1907
1908    The benefit of this is that operations such as pp_add know that if
1909    SvIOK is true for both left and right operands, then integer addition
1910    can be used instead of floating point (for cases where the result won't
1911    overflow). Before, floating point was always used, which could lead to
1912    loss of precision compared with integer addition.
1913
1914    * making IV and NV equal status should make maths accurate on 64 bit
1915      platforms
1916    * may speed up maths somewhat if pp_add and friends start to use
1917      integers when possible instead of fp. (Hopefully the overhead in
1918      looking for SvIOK and checking for overflow will not outweigh the
1919      fp to integer speedup)
1920    * will slow down integer operations (callers of SvIV) on "inaccurate"
1921      values, as the change from SvIOK to SvIOKp will cause a call into
1922      sv_2iv each time rather than a macro access direct to the IV slot
1923    * should speed up number->string conversion on integers as IV is
1924      favoured when IV and NV are equally accurate
1925
1926    ####################################################################
1927    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1928    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1929    On the other hand, SvUOK is true iff UV.
1930    ####################################################################
1931
1932    Your mileage will vary depending your CPU's relative fp to integer
1933    performance ratio.
1934 */
1935
1936 #ifndef NV_PRESERVES_UV
1937 #  define IS_NUMBER_UNDERFLOW_IV 1
1938 #  define IS_NUMBER_UNDERFLOW_UV 2
1939 #  define IS_NUMBER_IV_AND_UV    2
1940 #  define IS_NUMBER_OVERFLOW_IV  4
1941 #  define IS_NUMBER_OVERFLOW_UV  5
1942
1943 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1944
1945 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1946 STATIC int
1947 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1948 #  ifdef DEBUGGING
1949                        , I32 numtype
1950 #  endif
1951                        )
1952 {
1953     dVAR;
1954
1955     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1956
1957     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));
1958     if (SvNVX(sv) < (NV)IV_MIN) {
1959         (void)SvIOKp_on(sv);
1960         (void)SvNOK_on(sv);
1961         SvIV_set(sv, IV_MIN);
1962         return IS_NUMBER_UNDERFLOW_IV;
1963     }
1964     if (SvNVX(sv) > (NV)UV_MAX) {
1965         (void)SvIOKp_on(sv);
1966         (void)SvNOK_on(sv);
1967         SvIsUV_on(sv);
1968         SvUV_set(sv, UV_MAX);
1969         return IS_NUMBER_OVERFLOW_UV;
1970     }
1971     (void)SvIOKp_on(sv);
1972     (void)SvNOK_on(sv);
1973     /* Can't use strtol etc to convert this string.  (See truth table in
1974        sv_2iv  */
1975     if (SvNVX(sv) <= (UV)IV_MAX) {
1976         SvIV_set(sv, I_V(SvNVX(sv)));
1977         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1978             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1979         } else {
1980             /* Integer is imprecise. NOK, IOKp */
1981         }
1982         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1983     }
1984     SvIsUV_on(sv);
1985     SvUV_set(sv, U_V(SvNVX(sv)));
1986     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1987         if (SvUVX(sv) == UV_MAX) {
1988             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1989                possibly be preserved by NV. Hence, it must be overflow.
1990                NOK, IOKp */
1991             return IS_NUMBER_OVERFLOW_UV;
1992         }
1993         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1994     } else {
1995         /* Integer is imprecise. NOK, IOKp */
1996     }
1997     return IS_NUMBER_OVERFLOW_IV;
1998 }
1999 #endif /* !NV_PRESERVES_UV*/
2000
2001 STATIC bool
2002 S_sv_2iuv_common(pTHX_ SV *const sv)
2003 {
2004     dVAR;
2005
2006     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2007
2008     if (SvNOKp(sv)) {
2009         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2010          * without also getting a cached IV/UV from it at the same time
2011          * (ie PV->NV conversion should detect loss of accuracy and cache
2012          * IV or UV at same time to avoid this. */
2013         /* IV-over-UV optimisation - choose to cache IV if possible */
2014
2015         if (SvTYPE(sv) == SVt_NV)
2016             sv_upgrade(sv, SVt_PVNV);
2017
2018         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2019         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2020            certainly cast into the IV range at IV_MAX, whereas the correct
2021            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2022            cases go to UV */
2023 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2024         if (Perl_isnan(SvNVX(sv))) {
2025             SvUV_set(sv, 0);
2026             SvIsUV_on(sv);
2027             return FALSE;
2028         }
2029 #endif
2030         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2031             SvIV_set(sv, I_V(SvNVX(sv)));
2032             if (SvNVX(sv) == (NV) SvIVX(sv)
2033 #ifndef NV_PRESERVES_UV
2034                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2035                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2036                 /* Don't flag it as "accurately an integer" if the number
2037                    came from a (by definition imprecise) NV operation, and
2038                    we're outside the range of NV integer precision */
2039 #endif
2040                 ) {
2041                 if (SvNOK(sv))
2042                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2043                 else {
2044                     /* scalar has trailing garbage, eg "42a" */
2045                 }
2046                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2047                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2048                                       PTR2UV(sv),
2049                                       SvNVX(sv),
2050                                       SvIVX(sv)));
2051
2052             } else {
2053                 /* IV not precise.  No need to convert from PV, as NV
2054                    conversion would already have cached IV if it detected
2055                    that PV->IV would be better than PV->NV->IV
2056                    flags already correct - don't set public IOK.  */
2057                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2058                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2059                                       PTR2UV(sv),
2060                                       SvNVX(sv),
2061                                       SvIVX(sv)));
2062             }
2063             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2064                but the cast (NV)IV_MIN rounds to a the value less (more
2065                negative) than IV_MIN which happens to be equal to SvNVX ??
2066                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2067                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2068                (NV)UVX == NVX are both true, but the values differ. :-(
2069                Hopefully for 2s complement IV_MIN is something like
2070                0x8000000000000000 which will be exact. NWC */
2071         }
2072         else {
2073             SvUV_set(sv, U_V(SvNVX(sv)));
2074             if (
2075                 (SvNVX(sv) == (NV) SvUVX(sv))
2076 #ifndef  NV_PRESERVES_UV
2077                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2078                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2079                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2080                 /* Don't flag it as "accurately an integer" if the number
2081                    came from a (by definition imprecise) NV operation, and
2082                    we're outside the range of NV integer precision */
2083 #endif
2084                 && SvNOK(sv)
2085                 )
2086                 SvIOK_on(sv);
2087             SvIsUV_on(sv);
2088             DEBUG_c(PerlIO_printf(Perl_debug_log,
2089                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2090                                   PTR2UV(sv),
2091                                   SvUVX(sv),
2092                                   SvUVX(sv)));
2093         }
2094     }
2095     else if (SvPOKp(sv) && SvLEN(sv)) {
2096         UV value;
2097         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2098         /* We want to avoid a possible problem when we cache an IV/ a UV which
2099            may be later translated to an NV, and the resulting NV is not
2100            the same as the direct translation of the initial string
2101            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2102            be careful to ensure that the value with the .456 is around if the
2103            NV value is requested in the future).
2104
2105            This means that if we cache such an IV/a UV, we need to cache the
2106            NV as well.  Moreover, we trade speed for space, and do not
2107            cache the NV if we are sure it's not needed.
2108          */
2109
2110         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2111         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2112              == IS_NUMBER_IN_UV) {
2113             /* It's definitely an integer, only upgrade to PVIV */
2114             if (SvTYPE(sv) < SVt_PVIV)
2115                 sv_upgrade(sv, SVt_PVIV);
2116             (void)SvIOK_on(sv);
2117         } else if (SvTYPE(sv) < SVt_PVNV)
2118             sv_upgrade(sv, SVt_PVNV);
2119
2120         /* If NVs preserve UVs then we only use the UV value if we know that
2121            we aren't going to call atof() below. If NVs don't preserve UVs
2122            then the value returned may have more precision than atof() will
2123            return, even though value isn't perfectly accurate.  */
2124         if ((numtype & (IS_NUMBER_IN_UV
2125 #ifdef NV_PRESERVES_UV
2126                         | IS_NUMBER_NOT_INT
2127 #endif
2128             )) == IS_NUMBER_IN_UV) {
2129             /* This won't turn off the public IOK flag if it was set above  */
2130             (void)SvIOKp_on(sv);
2131
2132             if (!(numtype & IS_NUMBER_NEG)) {
2133                 /* positive */;
2134                 if (value <= (UV)IV_MAX) {
2135                     SvIV_set(sv, (IV)value);
2136                 } else {
2137                     /* it didn't overflow, and it was positive. */
2138                     SvUV_set(sv, value);
2139                     SvIsUV_on(sv);
2140                 }
2141             } else {
2142                 /* 2s complement assumption  */
2143                 if (value <= (UV)IV_MIN) {
2144                     SvIV_set(sv, -(IV)value);
2145                 } else {
2146                     /* Too negative for an IV.  This is a double upgrade, but
2147                        I'm assuming it will be rare.  */
2148                     if (SvTYPE(sv) < SVt_PVNV)
2149                         sv_upgrade(sv, SVt_PVNV);
2150                     SvNOK_on(sv);
2151                     SvIOK_off(sv);
2152                     SvIOKp_on(sv);
2153                     SvNV_set(sv, -(NV)value);
2154                     SvIV_set(sv, IV_MIN);
2155                 }
2156             }
2157         }
2158         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2159            will be in the previous block to set the IV slot, and the next
2160            block to set the NV slot.  So no else here.  */
2161
2162         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2163             != IS_NUMBER_IN_UV) {
2164             /* It wasn't an (integer that doesn't overflow the UV). */
2165             SvNV_set(sv, Atof(SvPVX_const(sv)));
2166
2167             if (! numtype && ckWARN(WARN_NUMERIC))
2168                 not_a_number(sv);
2169
2170 #if defined(USE_LONG_DOUBLE)
2171             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2172                                   PTR2UV(sv), SvNVX(sv)));
2173 #else
2174             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2175                                   PTR2UV(sv), SvNVX(sv)));
2176 #endif
2177
2178 #ifdef NV_PRESERVES_UV
2179             (void)SvIOKp_on(sv);
2180             (void)SvNOK_on(sv);
2181             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2182                 SvIV_set(sv, I_V(SvNVX(sv)));
2183                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2184                     SvIOK_on(sv);
2185                 } else {
2186                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2187                 }
2188                 /* UV will not work better than IV */
2189             } else {
2190                 if (SvNVX(sv) > (NV)UV_MAX) {
2191                     SvIsUV_on(sv);
2192                     /* Integer is inaccurate. NOK, IOKp, is UV */
2193                     SvUV_set(sv, UV_MAX);
2194                 } else {
2195                     SvUV_set(sv, U_V(SvNVX(sv)));
2196                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2197                        NV preservse UV so can do correct comparison.  */
2198                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2199                         SvIOK_on(sv);
2200                     } else {
2201                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2202                     }
2203                 }
2204                 SvIsUV_on(sv);
2205             }
2206 #else /* NV_PRESERVES_UV */
2207             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2208                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2209                 /* The IV/UV slot will have been set from value returned by
2210                    grok_number above.  The NV slot has just been set using
2211                    Atof.  */
2212                 SvNOK_on(sv);
2213                 assert (SvIOKp(sv));
2214             } else {
2215                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2216                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2217                     /* Small enough to preserve all bits. */
2218                     (void)SvIOKp_on(sv);
2219                     SvNOK_on(sv);
2220                     SvIV_set(sv, I_V(SvNVX(sv)));
2221                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2222                         SvIOK_on(sv);
2223                     /* Assumption: first non-preserved integer is < IV_MAX,
2224                        this NV is in the preserved range, therefore: */
2225                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2226                           < (UV)IV_MAX)) {
2227                         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);
2228                     }
2229                 } else {
2230                     /* IN_UV NOT_INT
2231                          0      0       already failed to read UV.
2232                          0      1       already failed to read UV.
2233                          1      0       you won't get here in this case. IV/UV
2234                                         slot set, public IOK, Atof() unneeded.
2235                          1      1       already read UV.
2236                        so there's no point in sv_2iuv_non_preserve() attempting
2237                        to use atol, strtol, strtoul etc.  */
2238 #  ifdef DEBUGGING
2239                     sv_2iuv_non_preserve (sv, numtype);
2240 #  else
2241                     sv_2iuv_non_preserve (sv);
2242 #  endif
2243                 }
2244             }
2245 #endif /* NV_PRESERVES_UV */
2246         /* It might be more code efficient to go through the entire logic above
2247            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2248            gets complex and potentially buggy, so more programmer efficient
2249            to do it this way, by turning off the public flags:  */
2250         if (!numtype)
2251             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2252         }
2253     }
2254     else  {
2255         if (isGV_with_GP(sv))
2256             return glob_2number(MUTABLE_GV(sv));
2257
2258         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2259             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2260                 report_uninit(sv);
2261         }
2262         if (SvTYPE(sv) < SVt_IV)
2263             /* Typically the caller expects that sv_any is not NULL now.  */
2264             sv_upgrade(sv, SVt_IV);
2265         /* Return 0 from the caller.  */
2266         return TRUE;
2267     }
2268     return FALSE;
2269 }
2270
2271 /*
2272 =for apidoc sv_2iv_flags
2273
2274 Return the integer value of an SV, doing any necessary string
2275 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2276 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2277
2278 =cut
2279 */
2280
2281 IV
2282 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2283 {
2284     dVAR;
2285     if (!sv)
2286         return 0;
2287     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2288         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2289            cache IVs just in case. In practice it seems that they never
2290            actually anywhere accessible by user Perl code, let alone get used
2291            in anything other than a string context.  */
2292         if (flags & SV_GMAGIC)
2293             mg_get(sv);
2294         if (SvIOKp(sv))
2295             return SvIVX(sv);
2296         if (SvNOKp(sv)) {
2297             return I_V(SvNVX(sv));
2298         }
2299         if (SvPOKp(sv) && SvLEN(sv)) {
2300             UV value;
2301             const int numtype
2302                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2303
2304             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2305                 == IS_NUMBER_IN_UV) {
2306                 /* It's definitely an integer */
2307                 if (numtype & IS_NUMBER_NEG) {
2308                     if (value < (UV)IV_MIN)
2309                         return -(IV)value;
2310                 } else {
2311                     if (value < (UV)IV_MAX)
2312                         return (IV)value;
2313                 }
2314             }
2315             if (!numtype) {
2316                 if (ckWARN(WARN_NUMERIC))
2317                     not_a_number(sv);
2318             }
2319             return I_V(Atof(SvPVX_const(sv)));
2320         }
2321         if (SvROK(sv)) {
2322             goto return_rok;
2323         }
2324         assert(SvTYPE(sv) >= SVt_PVMG);
2325         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2326     } else if (SvTHINKFIRST(sv)) {
2327         if (SvROK(sv)) {
2328         return_rok:
2329             if (SvAMAGIC(sv)) {
2330                 SV * tmpstr;
2331                 if (flags & SV_SKIP_OVERLOAD)
2332                     return 0;
2333                 tmpstr=AMG_CALLun(sv,numer);
2334                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2335                     return SvIV(tmpstr);
2336                 }
2337             }
2338             return PTR2IV(SvRV(sv));
2339         }
2340         if (SvIsCOW(sv)) {
2341             sv_force_normal_flags(sv, 0);
2342         }
2343         if (SvREADONLY(sv) && !SvOK(sv)) {
2344             if (ckWARN(WARN_UNINITIALIZED))
2345                 report_uninit(sv);
2346             return 0;
2347         }
2348     }
2349     if (!SvIOKp(sv)) {
2350         if (S_sv_2iuv_common(aTHX_ sv))
2351             return 0;
2352     }
2353     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2354         PTR2UV(sv),SvIVX(sv)));
2355     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2356 }
2357
2358 /*
2359 =for apidoc sv_2uv_flags
2360
2361 Return the unsigned integer value of an SV, doing any necessary string
2362 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2363 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2364
2365 =cut
2366 */
2367
2368 UV
2369 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2370 {
2371     dVAR;
2372     if (!sv)
2373         return 0;
2374     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2375         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2376            cache IVs just in case.  */
2377         if (flags & SV_GMAGIC)
2378             mg_get(sv);
2379         if (SvIOKp(sv))
2380             return SvUVX(sv);
2381         if (SvNOKp(sv))
2382             return U_V(SvNVX(sv));
2383         if (SvPOKp(sv) && SvLEN(sv)) {
2384             UV value;
2385             const int numtype
2386                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2387
2388             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2389                 == IS_NUMBER_IN_UV) {
2390                 /* It's definitely an integer */
2391                 if (!(numtype & IS_NUMBER_NEG))
2392                     return value;
2393             }
2394             if (!numtype) {
2395                 if (ckWARN(WARN_NUMERIC))
2396                     not_a_number(sv);
2397             }
2398             return U_V(Atof(SvPVX_const(sv)));
2399         }
2400         if (SvROK(sv)) {
2401             goto return_rok;
2402         }
2403         assert(SvTYPE(sv) >= SVt_PVMG);
2404         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2405     } else if (SvTHINKFIRST(sv)) {
2406         if (SvROK(sv)) {
2407         return_rok:
2408             if (SvAMAGIC(sv)) {
2409                 SV *tmpstr;
2410                 if (flags & SV_SKIP_OVERLOAD)
2411                     return 0;
2412                 tmpstr = AMG_CALLun(sv,numer);
2413                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2414                     return SvUV(tmpstr);
2415                 }
2416             }
2417             return PTR2UV(SvRV(sv));
2418         }
2419         if (SvIsCOW(sv)) {
2420             sv_force_normal_flags(sv, 0);
2421         }
2422         if (SvREADONLY(sv) && !SvOK(sv)) {
2423             if (ckWARN(WARN_UNINITIALIZED))
2424                 report_uninit(sv);
2425             return 0;
2426         }
2427     }
2428     if (!SvIOKp(sv)) {
2429         if (S_sv_2iuv_common(aTHX_ sv))
2430             return 0;
2431     }
2432
2433     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2434                           PTR2UV(sv),SvUVX(sv)));
2435     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2436 }
2437
2438 /*
2439 =for apidoc sv_2nv
2440
2441 Return the num value of an SV, doing any necessary string or integer
2442 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2443 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2444
2445 =cut
2446 */
2447
2448 NV
2449 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2450 {
2451     dVAR;
2452     if (!sv)
2453         return 0.0;
2454     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2455         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2456            cache IVs just in case.  */
2457         if (flags & SV_GMAGIC)
2458             mg_get(sv);
2459         if (SvNOKp(sv))
2460             return SvNVX(sv);
2461         if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2462             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2463                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2464                 not_a_number(sv);
2465             return Atof(SvPVX_const(sv));
2466         }
2467         if (SvIOKp(sv)) {
2468             if (SvIsUV(sv))
2469                 return (NV)SvUVX(sv);
2470             else
2471                 return (NV)SvIVX(sv);
2472         }
2473         if (SvROK(sv)) {
2474             goto return_rok;
2475         }
2476         assert(SvTYPE(sv) >= SVt_PVMG);
2477         /* This falls through to the report_uninit near the end of the
2478            function. */
2479     } else if (SvTHINKFIRST(sv)) {
2480         if (SvROK(sv)) {
2481         return_rok:
2482             if (SvAMAGIC(sv)) {
2483                 SV *tmpstr;
2484                 if (flags & SV_SKIP_OVERLOAD)
2485                     return 0;
2486                 tmpstr = AMG_CALLun(sv,numer);
2487                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2488                     return SvNV(tmpstr);
2489                 }
2490             }
2491             return PTR2NV(SvRV(sv));
2492         }
2493         if (SvIsCOW(sv)) {
2494             sv_force_normal_flags(sv, 0);
2495         }
2496         if (SvREADONLY(sv) && !SvOK(sv)) {
2497             if (ckWARN(WARN_UNINITIALIZED))
2498                 report_uninit(sv);
2499             return 0.0;
2500         }
2501     }
2502     if (SvTYPE(sv) < SVt_NV) {
2503         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2504         sv_upgrade(sv, SVt_NV);
2505 #ifdef USE_LONG_DOUBLE
2506         DEBUG_c({
2507             STORE_NUMERIC_LOCAL_SET_STANDARD();
2508             PerlIO_printf(Perl_debug_log,
2509                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2510                           PTR2UV(sv), SvNVX(sv));
2511             RESTORE_NUMERIC_LOCAL();
2512         });
2513 #else
2514         DEBUG_c({
2515             STORE_NUMERIC_LOCAL_SET_STANDARD();
2516             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2517                           PTR2UV(sv), SvNVX(sv));
2518             RESTORE_NUMERIC_LOCAL();
2519         });
2520 #endif
2521     }
2522     else if (SvTYPE(sv) < SVt_PVNV)
2523         sv_upgrade(sv, SVt_PVNV);
2524     if (SvNOKp(sv)) {
2525         return SvNVX(sv);
2526     }
2527     if (SvIOKp(sv)) {
2528         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2529 #ifdef NV_PRESERVES_UV
2530         if (SvIOK(sv))
2531             SvNOK_on(sv);
2532         else
2533             SvNOKp_on(sv);
2534 #else
2535         /* Only set the public NV OK flag if this NV preserves the IV  */
2536         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2537         if (SvIOK(sv) &&
2538             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2539                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2540             SvNOK_on(sv);
2541         else
2542             SvNOKp_on(sv);
2543 #endif
2544     }
2545     else if (SvPOKp(sv) && SvLEN(sv)) {
2546         UV value;
2547         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2548         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2549             not_a_number(sv);
2550 #ifdef NV_PRESERVES_UV
2551         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2552             == IS_NUMBER_IN_UV) {
2553             /* It's definitely an integer */
2554             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2555         } else
2556             SvNV_set(sv, Atof(SvPVX_const(sv)));
2557         if (numtype)
2558             SvNOK_on(sv);
2559         else
2560             SvNOKp_on(sv);
2561 #else
2562         SvNV_set(sv, Atof(SvPVX_const(sv)));
2563         /* Only set the public NV OK flag if this NV preserves the value in
2564            the PV at least as well as an IV/UV would.
2565            Not sure how to do this 100% reliably. */
2566         /* if that shift count is out of range then Configure's test is
2567            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2568            UV_BITS */
2569         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2570             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2571             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2572         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2573             /* Can't use strtol etc to convert this string, so don't try.
2574                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2575             SvNOK_on(sv);
2576         } else {
2577             /* value has been set.  It may not be precise.  */
2578             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2579                 /* 2s complement assumption for (UV)IV_MIN  */
2580                 SvNOK_on(sv); /* Integer is too negative.  */
2581             } else {
2582                 SvNOKp_on(sv);
2583                 SvIOKp_on(sv);
2584
2585                 if (numtype & IS_NUMBER_NEG) {
2586                     SvIV_set(sv, -(IV)value);
2587                 } else if (value <= (UV)IV_MAX) {
2588                     SvIV_set(sv, (IV)value);
2589                 } else {
2590                     SvUV_set(sv, value);
2591                     SvIsUV_on(sv);
2592                 }
2593
2594                 if (numtype & IS_NUMBER_NOT_INT) {
2595                     /* I believe that even if the original PV had decimals,
2596                        they are lost beyond the limit of the FP precision.
2597                        However, neither is canonical, so both only get p
2598                        flags.  NWC, 2000/11/25 */
2599                     /* Both already have p flags, so do nothing */
2600                 } else {
2601                     const NV nv = SvNVX(sv);
2602                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2603                         if (SvIVX(sv) == I_V(nv)) {
2604                             SvNOK_on(sv);
2605                         } else {
2606                             /* It had no "." so it must be integer.  */
2607                         }
2608                         SvIOK_on(sv);
2609                     } else {
2610                         /* between IV_MAX and NV(UV_MAX).
2611                            Could be slightly > UV_MAX */
2612
2613                         if (numtype & IS_NUMBER_NOT_INT) {
2614                             /* UV and NV both imprecise.  */
2615                         } else {
2616                             const UV nv_as_uv = U_V(nv);
2617
2618                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2619                                 SvNOK_on(sv);
2620                             }
2621                             SvIOK_on(sv);
2622                         }
2623                     }
2624                 }
2625             }
2626         }
2627         /* It might be more code efficient to go through the entire logic above
2628            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2629            gets complex and potentially buggy, so more programmer efficient
2630            to do it this way, by turning off the public flags:  */
2631         if (!numtype)
2632             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2633 #endif /* NV_PRESERVES_UV */
2634     }
2635     else  {
2636         if (isGV_with_GP(sv)) {
2637             glob_2number(MUTABLE_GV(sv));
2638             return 0.0;
2639         }
2640
2641         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2642             report_uninit(sv);
2643         assert (SvTYPE(sv) >= SVt_NV);
2644         /* Typically the caller expects that sv_any is not NULL now.  */
2645         /* XXX Ilya implies that this is a bug in callers that assume this
2646            and ideally should be fixed.  */
2647         return 0.0;
2648     }
2649 #if defined(USE_LONG_DOUBLE)
2650     DEBUG_c({
2651         STORE_NUMERIC_LOCAL_SET_STANDARD();
2652         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2653                       PTR2UV(sv), SvNVX(sv));
2654         RESTORE_NUMERIC_LOCAL();
2655     });
2656 #else
2657     DEBUG_c({
2658         STORE_NUMERIC_LOCAL_SET_STANDARD();
2659         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2660                       PTR2UV(sv), SvNVX(sv));
2661         RESTORE_NUMERIC_LOCAL();
2662     });
2663 #endif
2664     return SvNVX(sv);
2665 }
2666
2667 /*
2668 =for apidoc sv_2num
2669
2670 Return an SV with the numeric value of the source SV, doing any necessary
2671 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2672 access this function.
2673
2674 =cut
2675 */
2676
2677 SV *
2678 Perl_sv_2num(pTHX_ register SV *const sv)
2679 {
2680     PERL_ARGS_ASSERT_SV_2NUM;
2681
2682     if (!SvROK(sv))
2683         return sv;
2684     if (SvAMAGIC(sv)) {
2685         SV * const tmpsv = AMG_CALLun(sv,numer);
2686         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2687             return sv_2num(tmpsv);
2688     }
2689     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2690 }
2691
2692 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2693  * UV as a string towards the end of buf, and return pointers to start and
2694  * end of it.
2695  *
2696  * We assume that buf is at least TYPE_CHARS(UV) long.
2697  */
2698
2699 static char *
2700 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2701 {
2702     char *ptr = buf + TYPE_CHARS(UV);
2703     char * const ebuf = ptr;
2704     int sign;
2705
2706     PERL_ARGS_ASSERT_UIV_2BUF;
2707
2708     if (is_uv)
2709         sign = 0;
2710     else if (iv >= 0) {
2711         uv = iv;
2712         sign = 0;
2713     } else {
2714         uv = -iv;
2715         sign = 1;
2716     }
2717     do {
2718         *--ptr = '0' + (char)(uv % 10);
2719     } while (uv /= 10);
2720     if (sign)
2721         *--ptr = '-';
2722     *peob = ebuf;
2723     return ptr;
2724 }
2725
2726 /*
2727 =for apidoc sv_2pv_flags
2728
2729 Returns a pointer to the string value of an SV, and sets *lp to its length.
2730 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2731 if necessary.
2732 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2733 usually end up here too.
2734
2735 =cut
2736 */
2737
2738 char *
2739 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2740 {
2741     dVAR;
2742     register char *s;
2743
2744     if (!sv) {
2745         if (lp)
2746             *lp = 0;
2747         return (char *)"";
2748     }
2749     if (SvGMAGICAL(sv)) {
2750         if (flags & SV_GMAGIC)
2751             mg_get(sv);
2752         if (SvPOKp(sv)) {
2753             if (lp)
2754                 *lp = SvCUR(sv);
2755             if (flags & SV_MUTABLE_RETURN)
2756                 return SvPVX_mutable(sv);
2757             if (flags & SV_CONST_RETURN)
2758                 return (char *)SvPVX_const(sv);
2759             return SvPVX(sv);
2760         }
2761         if (SvIOKp(sv) || SvNOKp(sv)) {
2762             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2763             STRLEN len;
2764
2765             if (SvIOKp(sv)) {
2766                 len = SvIsUV(sv)
2767                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2768                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2769             } else {
2770                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2771                 len = strlen(tbuf);
2772             }
2773             assert(!SvROK(sv));
2774             {
2775                 dVAR;
2776
2777 #ifdef FIXNEGATIVEZERO
2778                 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2779                     tbuf[0] = '0';
2780                     tbuf[1] = 0;
2781                     len = 1;
2782                 }
2783 #endif
2784                 SvUPGRADE(sv, SVt_PV);
2785                 if (lp)
2786                     *lp = len;
2787                 s = SvGROW_mutable(sv, len + 1);
2788                 SvCUR_set(sv, len);
2789                 SvPOKp_on(sv);
2790                 return (char*)memcpy(s, tbuf, len + 1);
2791             }
2792         }
2793         if (SvROK(sv)) {
2794             goto return_rok;
2795         }
2796         assert(SvTYPE(sv) >= SVt_PVMG);
2797         /* This falls through to the report_uninit near the end of the
2798            function. */
2799     } else if (SvTHINKFIRST(sv)) {
2800         if (SvROK(sv)) {
2801         return_rok:
2802             if (SvAMAGIC(sv)) {
2803                 SV *tmpstr;
2804                 if (flags & SV_SKIP_OVERLOAD)
2805                     return NULL;
2806                 tmpstr = AMG_CALLun(sv,string);
2807                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2808                     /* Unwrap this:  */
2809                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2810                      */
2811
2812                     char *pv;
2813                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2814                         if (flags & SV_CONST_RETURN) {
2815                             pv = (char *) SvPVX_const(tmpstr);
2816                         } else {
2817                             pv = (flags & SV_MUTABLE_RETURN)
2818                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2819                         }
2820                         if (lp)
2821                             *lp = SvCUR(tmpstr);
2822                     } else {
2823                         pv = sv_2pv_flags(tmpstr, lp, flags);
2824                     }
2825                     if (SvUTF8(tmpstr))
2826                         SvUTF8_on(sv);
2827                     else
2828                         SvUTF8_off(sv);
2829                     return pv;
2830                 }
2831             }
2832             {
2833                 STRLEN len;
2834                 char *retval;
2835                 char *buffer;
2836                 SV *const referent = SvRV(sv);
2837
2838                 if (!referent) {
2839                     len = 7;
2840                     retval = buffer = savepvn("NULLREF", len);
2841                 } else if (SvTYPE(referent) == SVt_REGEXP) {
2842                     REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2843                     I32 seen_evals = 0;
2844
2845                     assert(re);
2846
2847                     /* If the regex is UTF-8 we want the containing scalar to
2848                        have an UTF-8 flag too */
2849                     if (RX_UTF8(re))
2850                         SvUTF8_on(sv);
2851                     else
2852                         SvUTF8_off(sv);
2853
2854                     if ((seen_evals = RX_SEEN_EVALS(re)))
2855                         PL_reginterp_cnt += seen_evals;
2856
2857                     if (lp)
2858                         *lp = RX_WRAPLEN(re);
2859
2860                     return RX_WRAPPED(re);
2861                 } else {
2862                     const char *const typestr = sv_reftype(referent, 0);
2863                     const STRLEN typelen = strlen(typestr);
2864                     UV addr = PTR2UV(referent);
2865                     const char *stashname = NULL;
2866                     STRLEN stashnamelen = 0; /* hush, gcc */
2867                     const char *buffer_end;
2868
2869                     if (SvOBJECT(referent)) {
2870                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2871
2872                         if (name) {
2873                             stashname = HEK_KEY(name);
2874                             stashnamelen = HEK_LEN(name);
2875
2876                             if (HEK_UTF8(name)) {
2877                                 SvUTF8_on(sv);
2878                             } else {
2879                                 SvUTF8_off(sv);
2880                             }
2881                         } else {
2882                             stashname = "__ANON__";
2883                             stashnamelen = 8;
2884                         }
2885                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2886                             + 2 * sizeof(UV) + 2 /* )\0 */;
2887                     } else {
2888                         len = typelen + 3 /* (0x */
2889                             + 2 * sizeof(UV) + 2 /* )\0 */;
2890                     }
2891
2892                     Newx(buffer, len, char);
2893                     buffer_end = retval = buffer + len;
2894
2895                     /* Working backwards  */
2896                     *--retval = '\0';
2897                     *--retval = ')';
2898                     do {
2899                         *--retval = PL_hexdigit[addr & 15];
2900                     } while (addr >>= 4);
2901                     *--retval = 'x';
2902                     *--retval = '0';
2903                     *--retval = '(';
2904
2905                     retval -= typelen;
2906                     memcpy(retval, typestr, typelen);
2907
2908                     if (stashname) {
2909                         *--retval = '=';
2910                         retval -= stashnamelen;
2911                         memcpy(retval, stashname, stashnamelen);
2912                     }
2913                     /* retval may not neccesarily have reached the start of the
2914                        buffer here.  */
2915                     assert (retval >= buffer);
2916
2917                     len = buffer_end - retval - 1; /* -1 for that \0  */
2918                 }
2919                 if (lp)
2920                     *lp = len;
2921                 SAVEFREEPV(buffer);
2922                 return retval;
2923             }
2924         }
2925         if (SvREADONLY(sv) && !SvOK(sv)) {
2926             if (lp)
2927                 *lp = 0;
2928             if (flags & SV_UNDEF_RETURNS_NULL)
2929                 return NULL;
2930             if (ckWARN(WARN_UNINITIALIZED))
2931                 report_uninit(sv);
2932             return (char *)"";
2933         }
2934     }
2935     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2936         /* I'm assuming that if both IV and NV are equally valid then
2937            converting the IV is going to be more efficient */
2938         const U32 isUIOK = SvIsUV(sv);
2939         char buf[TYPE_CHARS(UV)];
2940         char *ebuf, *ptr;
2941         STRLEN len;
2942
2943         if (SvTYPE(sv) < SVt_PVIV)
2944             sv_upgrade(sv, SVt_PVIV);
2945         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2946         len = ebuf - ptr;
2947         /* inlined from sv_setpvn */
2948         s = SvGROW_mutable(sv, len + 1);
2949         Move(ptr, s, len, char);
2950         s += len;
2951         *s = '\0';
2952     }
2953     else if (SvNOKp(sv)) {
2954         dSAVE_ERRNO;
2955         if (SvTYPE(sv) < SVt_PVNV)
2956             sv_upgrade(sv, SVt_PVNV);
2957         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2958         s = SvGROW_mutable(sv, NV_DIG + 20);
2959         /* some Xenix systems wipe out errno here */
2960 #ifdef apollo
2961         if (SvNVX(sv) == 0.0)
2962             my_strlcpy(s, "0", SvLEN(sv));
2963         else
2964 #endif /*apollo*/
2965         {
2966             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2967         }
2968         RESTORE_ERRNO;
2969 #ifdef FIXNEGATIVEZERO
2970         if (*s == '-' && s[1] == '0' && !s[2]) {
2971             s[0] = '0';
2972             s[1] = 0;
2973         }
2974 #endif
2975         while (*s) s++;
2976 #ifdef hcx
2977         if (s[-1] == '.')
2978             *--s = '\0';
2979 #endif
2980     }
2981     else {
2982         if (isGV_with_GP(sv)) {
2983             GV *const gv = MUTABLE_GV(sv);
2984             const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2985             SV *const buffer = sv_newmortal();
2986
2987             /* FAKE globs can get coerced, so need to turn this off temporarily
2988                if it is on.  */
2989             SvFAKE_off(gv);
2990             gv_efullname3(buffer, gv, "*");
2991             SvFLAGS(gv) |= wasfake;
2992
2993             if (SvPOK(buffer)) {
2994                 if (lp) {
2995                     *lp = SvCUR(buffer);
2996                 }
2997                 return SvPVX(buffer);
2998             }
2999             else {
3000                 if (lp)
3001                     *lp = 0;
3002                 return (char *)"";
3003             }
3004         }
3005
3006         if (lp)
3007             *lp = 0;
3008         if (flags & SV_UNDEF_RETURNS_NULL)
3009             return NULL;
3010         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3011             report_uninit(sv);
3012         if (SvTYPE(sv) < SVt_PV)
3013             /* Typically the caller expects that sv_any is not NULL now.  */
3014             sv_upgrade(sv, SVt_PV);
3015         return (char *)"";
3016     }
3017     {
3018         const STRLEN len = s - SvPVX_const(sv);
3019         if (lp)
3020             *lp = len;
3021         SvCUR_set(sv, len);
3022     }
3023     SvPOK_on(sv);
3024     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3025                           PTR2UV(sv),SvPVX_const(sv)));
3026     if (flags & SV_CONST_RETURN)
3027         return (char *)SvPVX_const(sv);
3028     if (flags & SV_MUTABLE_RETURN)
3029         return SvPVX_mutable(sv);
3030     return SvPVX(sv);
3031 }
3032
3033 /*
3034 =for apidoc sv_copypv
3035
3036 Copies a stringified representation of the source SV into the
3037 destination SV.  Automatically performs any necessary mg_get and
3038 coercion of numeric values into strings.  Guaranteed to preserve
3039 UTF8 flag even from overloaded objects.  Similar in nature to
3040 sv_2pv[_flags] but operates directly on an SV instead of just the
3041 string.  Mostly uses sv_2pv_flags to do its work, except when that
3042 would lose the UTF-8'ness of the PV.
3043
3044 =cut
3045 */
3046
3047 void
3048 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3049 {
3050     STRLEN len;
3051     const char * const s = SvPV_const(ssv,len);
3052
3053     PERL_ARGS_ASSERT_SV_COPYPV;
3054
3055     sv_setpvn(dsv,s,len);
3056     if (SvUTF8(ssv))
3057         SvUTF8_on(dsv);
3058     else
3059         SvUTF8_off(dsv);
3060 }
3061
3062 /*
3063 =for apidoc sv_2pvbyte
3064
3065 Return a pointer to the byte-encoded representation of the SV, and set *lp
3066 to its length.  May cause the SV to be downgraded from UTF-8 as a
3067 side-effect.
3068
3069 Usually accessed via the C<SvPVbyte> macro.
3070
3071 =cut
3072 */
3073
3074 char *
3075 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3076 {
3077     PERL_ARGS_ASSERT_SV_2PVBYTE;
3078
3079     sv_utf8_downgrade(sv,0);
3080     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3081 }
3082
3083 /*
3084 =for apidoc sv_2pvutf8
3085
3086 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3087 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3088
3089 Usually accessed via the C<SvPVutf8> macro.
3090
3091 =cut
3092 */
3093
3094 char *
3095 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3096 {
3097     PERL_ARGS_ASSERT_SV_2PVUTF8;
3098
3099     sv_utf8_upgrade(sv);
3100     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3101 }
3102
3103
3104 /*
3105 =for apidoc sv_2bool
3106
3107 This function is only called on magical items, and is only used by
3108 sv_true() or its macro equivalent.
3109
3110 =cut
3111 */
3112
3113 bool
3114 Perl_sv_2bool(pTHX_ register SV *const sv)
3115 {
3116     dVAR;
3117
3118     PERL_ARGS_ASSERT_SV_2BOOL;
3119
3120     SvGETMAGIC(sv);
3121
3122     if (!SvOK(sv))
3123         return 0;
3124     if (SvROK(sv)) {
3125         if (SvAMAGIC(sv)) {
3126             SV * const tmpsv = AMG_CALLun(sv,bool_);
3127             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3128                 return cBOOL(SvTRUE(tmpsv));
3129         }
3130         return SvRV(sv) != 0;
3131     }
3132     if (SvPOKp(sv)) {
3133         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3134         if (Xpvtmp &&
3135                 (*sv->sv_u.svu_pv > '0' ||
3136                 Xpvtmp->xpv_cur > 1 ||
3137                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3138             return 1;
3139         else
3140             return 0;
3141     }
3142     else {
3143         if (SvIOKp(sv))
3144             return SvIVX(sv) != 0;
3145         else {
3146             if (SvNOKp(sv))
3147                 return SvNVX(sv) != 0.0;
3148             else {
3149                 if (isGV_with_GP(sv))
3150                     return TRUE;
3151                 else
3152                     return FALSE;
3153             }
3154         }
3155     }
3156 }
3157
3158 /*
3159 =for apidoc sv_utf8_upgrade
3160
3161 Converts the PV of an SV to its UTF-8-encoded form.
3162 Forces the SV to string form if it is not already.
3163 Will C<mg_get> on C<sv> if appropriate.
3164 Always sets the SvUTF8 flag to avoid future validity checks even
3165 if the whole string is the same in UTF-8 as not.
3166 Returns the number of bytes in the converted string
3167
3168 This is not as a general purpose byte encoding to Unicode interface:
3169 use the Encode extension for that.
3170
3171 =for apidoc sv_utf8_upgrade_nomg
3172
3173 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3174
3175 =for apidoc sv_utf8_upgrade_flags
3176
3177 Converts the PV of an SV to its UTF-8-encoded form.
3178 Forces the SV to string form if it is not already.
3179 Always sets the SvUTF8 flag to avoid future validity checks even
3180 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3181 will C<mg_get> on C<sv> if appropriate, else not.
3182 Returns the number of bytes in the converted string
3183 C<sv_utf8_upgrade> and
3184 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3185
3186 This is not as a general purpose byte encoding to Unicode interface:
3187 use the Encode extension for that.
3188
3189 =cut
3190
3191 The grow version is currently not externally documented.  It adds a parameter,
3192 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3193 have free after it upon return.  This allows the caller to reserve extra space
3194 that it intends to fill, to avoid extra grows.
3195
3196 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3197 which can be used to tell this function to not first check to see if there are
3198 any characters that are different in UTF-8 (variant characters) which would
3199 force it to allocate a new string to sv, but to assume there are.  Typically
3200 this flag is used by a routine that has already parsed the string to find that
3201 there are such characters, and passes this information on so that the work
3202 doesn't have to be repeated.
3203
3204 (One might think that the calling routine could pass in the position of the
3205 first such variant, so it wouldn't have to be found again.  But that is not the
3206 case, because typically when the caller is likely to use this flag, it won't be
3207 calling this routine unless it finds something that won't fit into a byte.
3208 Otherwise it tries to not upgrade and just use bytes.  But some things that
3209 do fit into a byte are variants in utf8, and the caller may not have been
3210 keeping track of these.)
3211
3212 If the routine itself changes the string, it adds a trailing NUL.  Such a NUL
3213 isn't guaranteed due to having other routines do the work in some input cases,
3214 or if the input is already flagged as being in utf8.
3215
3216 The speed of this could perhaps be improved for many cases if someone wanted to
3217 write a fast function that counts the number of variant characters in a string,
3218 especially if it could return the position of the first one.
3219
3220 */
3221
3222 STRLEN
3223 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3224 {
3225     dVAR;
3226
3227     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3228
3229     if (sv == &PL_sv_undef)
3230         return 0;
3231     if (!SvPOK(sv)) {
3232         STRLEN len = 0;
3233         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3234             (void) sv_2pv_flags(sv,&len, flags);
3235             if (SvUTF8(sv)) {
3236                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3237                 return len;
3238             }
3239         } else {
3240             (void) SvPV_force(sv,len);
3241         }
3242     }
3243
3244     if (SvUTF8(sv)) {
3245         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3246         return SvCUR(sv);
3247     }
3248
3249     if (SvIsCOW(sv)) {
3250         sv_force_normal_flags(sv, 0);
3251     }
3252
3253     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3254         sv_recode_to_utf8(sv, PL_encoding);
3255         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3256         return SvCUR(sv);
3257     }
3258
3259     if (SvCUR(sv) == 0) {
3260         if (extra) SvGROW(sv, extra);
3261     } else { /* Assume Latin-1/EBCDIC */
3262         /* This function could be much more efficient if we
3263          * had a FLAG in SVs to signal if there are any variant
3264          * chars in the PV.  Given that there isn't such a flag
3265          * make the loop as fast as possible (although there are certainly ways
3266          * to speed this up, eg. through vectorization) */
3267         U8 * s = (U8 *) SvPVX_const(sv);
3268         U8 * e = (U8 *) SvEND(sv);
3269         U8 *t = s;
3270         STRLEN two_byte_count = 0;
3271
3272         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3273
3274         /* See if really will need to convert to utf8.  We mustn't rely on our
3275          * incoming SV being well formed and having a trailing '\0', as certain
3276          * code in pp_formline can send us partially built SVs. */
3277
3278         while (t < e) {
3279             const U8 ch = *t++;
3280             if (NATIVE_IS_INVARIANT(ch)) continue;
3281
3282             t--;    /* t already incremented; re-point to first variant */
3283             two_byte_count = 1;
3284             goto must_be_utf8;
3285         }
3286
3287         /* utf8 conversion not needed because all are invariants.  Mark as
3288          * UTF-8 even if no variant - saves scanning loop */
3289         SvUTF8_on(sv);
3290         return SvCUR(sv);
3291
3292 must_be_utf8:
3293
3294         /* Here, the string should be converted to utf8, either because of an
3295          * input flag (two_byte_count = 0), or because a character that
3296          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3297          * the beginning of the string (if we didn't examine anything), or to
3298          * the first variant.  In either case, everything from s to t - 1 will
3299          * occupy only 1 byte each on output.
3300          *
3301          * There are two main ways to convert.  One is to create a new string
3302          * and go through the input starting from the beginning, appending each
3303          * converted value onto the new string as we go along.  It's probably
3304          * best to allocate enough space in the string for the worst possible
3305          * case rather than possibly running out of space and having to
3306          * reallocate and then copy what we've done so far.  Since everything
3307          * from s to t - 1 is invariant, the destination can be initialized
3308          * with these using a fast memory copy
3309          *
3310          * The other way is to figure out exactly how big the string should be
3311          * by parsing the entire input.  Then you don't have to make it big
3312          * enough to handle the worst possible case, and more importantly, if
3313          * the string you already have is large enough, you don't have to
3314          * allocate a new string, you can copy the last character in the input
3315          * string to the final position(s) that will be occupied by the
3316          * converted string and go backwards, stopping at t, since everything
3317          * before that is invariant.
3318          *
3319          * There are advantages and disadvantages to each method.
3320          *
3321          * In the first method, we can allocate a new string, do the memory
3322          * copy from the s to t - 1, and then proceed through the rest of the
3323          * string byte-by-byte.
3324          *
3325          * In the second method, we proceed through the rest of the input
3326          * string just calculating how big the converted string will be.  Then
3327          * there are two cases:
3328          *  1)  if the string has enough extra space to handle the converted
3329          *      value.  We go backwards through the string, converting until we
3330          *      get to the position we are at now, and then stop.  If this
3331          *      position is far enough along in the string, this method is
3332          *      faster than the other method.  If the memory copy were the same
3333          *      speed as the byte-by-byte loop, that position would be about
3334          *      half-way, as at the half-way mark, parsing to the end and back
3335          *      is one complete string's parse, the same amount as starting
3336          *      over and going all the way through.  Actually, it would be
3337          *      somewhat less than half-way, as it's faster to just count bytes
3338          *      than to also copy, and we don't have the overhead of allocating
3339          *      a new string, changing the scalar to use it, and freeing the
3340          *      existing one.  But if the memory copy is fast, the break-even
3341          *      point is somewhere after half way.  The counting loop could be
3342          *      sped up by vectorization, etc, to move the break-even point
3343          *      further towards the beginning.
3344          *  2)  if the string doesn't have enough space to handle the converted
3345          *      value.  A new string will have to be allocated, and one might
3346          *      as well, given that, start from the beginning doing the first
3347          *      method.  We've spent extra time parsing the string and in
3348          *      exchange all we've gotten is that we know precisely how big to
3349          *      make the new one.  Perl is more optimized for time than space,
3350          *      so this case is a loser.
3351          * So what I've decided to do is not use the 2nd method unless it is
3352          * guaranteed that a new string won't have to be allocated, assuming
3353          * the worst case.  I also decided not to put any more conditions on it
3354          * than this, for now.  It seems likely that, since the worst case is
3355          * twice as big as the unknown portion of the string (plus 1), we won't
3356          * be guaranteed enough space, causing us to go to the first method,
3357          * unless the string is short, or the first variant character is near
3358          * the end of it.  In either of these cases, it seems best to use the
3359          * 2nd method.  The only circumstance I can think of where this would
3360          * be really slower is if the string had once had much more data in it
3361          * than it does now, but there is still a substantial amount in it  */
3362
3363         {
3364             STRLEN invariant_head = t - s;
3365             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3366             if (SvLEN(sv) < size) {
3367
3368                 /* Here, have decided to allocate a new string */
3369
3370                 U8 *dst;
3371                 U8 *d;
3372
3373                 Newx(dst, size, U8);
3374
3375                 /* If no known invariants at the beginning of the input string,
3376                  * set so starts from there.  Otherwise, can use memory copy to
3377                  * get up to where we are now, and then start from here */
3378
3379                 if (invariant_head <= 0) {
3380                     d = dst;
3381                 } else {
3382                     Copy(s, dst, invariant_head, char);
3383                     d = dst + invariant_head;
3384                 }
3385
3386                 while (t < e) {
3387                     const UV uv = NATIVE8_TO_UNI(*t++);
3388                     if (UNI_IS_INVARIANT(uv))
3389                         *d++ = (U8)UNI_TO_NATIVE(uv);
3390                     else {
3391                         *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3392                         *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3393                     }
3394                 }
3395                 *d = '\0';
3396                 SvPV_free(sv); /* No longer using pre-existing string */
3397                 SvPV_set(sv, (char*)dst);
3398                 SvCUR_set(sv, d - dst);
3399                 SvLEN_set(sv, size);
3400             } else {
3401
3402                 /* Here, have decided to get the exact size of the string.
3403                  * Currently this happens only when we know that there is
3404                  * guaranteed enough space to fit the converted string, so
3405                  * don't have to worry about growing.  If two_byte_count is 0,
3406                  * then t points to the first byte of the string which hasn't
3407                  * been examined yet.  Otherwise two_byte_count is 1, and t
3408                  * points to the first byte in the string that will expand to
3409                  * two.  Depending on this, start examining at t or 1 after t.
3410                  * */
3411
3412                 U8 *d = t + two_byte_count;
3413
3414
3415                 /* Count up the remaining bytes that expand to two */
3416
3417                 while (d < e) {
3418                     const U8 chr = *d++;
3419                     if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3420                 }
3421
3422                 /* The string will expand by just the number of bytes that
3423                  * occupy two positions.  But we are one afterwards because of
3424                  * the increment just above.  This is the place to put the
3425                  * trailing NUL, and to set the length before we decrement */
3426
3427                 d += two_byte_count;
3428                 SvCUR_set(sv, d - s);
3429                 *d-- = '\0';
3430
3431
3432                 /* Having decremented d, it points to the position to put the
3433                  * very last byte of the expanded string.  Go backwards through
3434                  * the string, copying and expanding as we go, stopping when we
3435                  * get to the part that is invariant the rest of the way down */
3436
3437                 e--;
3438                 while (e >= t) {
3439                     const U8 ch = NATIVE8_TO_UNI(*e--);
3440                     if (UNI_IS_INVARIANT(ch)) {
3441                         *d-- = UNI_TO_NATIVE(ch);
3442                     } else {
3443                         *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3444                         *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3445                     }
3446                 }
3447             }
3448         }
3449     }
3450
3451     /* Mark as UTF-8 even if no variant - saves scanning loop */
3452     SvUTF8_on(sv);
3453     return SvCUR(sv);
3454 }
3455
3456 /*
3457 =for apidoc sv_utf8_downgrade
3458
3459 Attempts to convert the PV of an SV from characters to bytes.
3460 If the PV contains a character that cannot fit
3461 in a byte, this conversion will fail;
3462 in this case, either returns false or, if C<fail_ok> is not
3463 true, croaks.
3464
3465 This is not as a general purpose Unicode to byte encoding interface:
3466 use the Encode extension for that.
3467
3468 =cut
3469 */
3470
3471 bool
3472 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3473 {
3474     dVAR;
3475
3476     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3477
3478     if (SvPOKp(sv) && SvUTF8(sv)) {
3479         if (SvCUR(sv)) {
3480             U8 *s;
3481             STRLEN len;
3482
3483             if (SvIsCOW(sv)) {
3484                 sv_force_normal_flags(sv, 0);
3485             }
3486             s = (U8 *) SvPV(sv, len);
3487             if (!utf8_to_bytes(s, &len)) {
3488                 if (fail_ok)
3489                     return FALSE;
3490                 else {
3491                     if (PL_op)
3492                         Perl_croak(aTHX_ "Wide character in %s",
3493                                    OP_DESC(PL_op));
3494                     else
3495                         Perl_croak(aTHX_ "Wide character");
3496                 }
3497             }
3498             SvCUR_set(sv, len);
3499         }
3500     }
3501     SvUTF8_off(sv);
3502     return TRUE;
3503 }
3504
3505 /*
3506 =for apidoc sv_utf8_encode
3507
3508 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3509 flag off so that it looks like octets again.
3510
3511 =cut
3512 */
3513
3514 void
3515 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3516 {
3517     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3518
3519     if (SvIsCOW(sv)) {
3520         sv_force_normal_flags(sv, 0);
3521     }
3522     if (SvREADONLY(sv)) {
3523         Perl_croak(aTHX_ "%s", PL_no_modify);
3524     }
3525     (void) sv_utf8_upgrade(sv);
3526     SvUTF8_off(sv);
3527 }
3528
3529 /*
3530 =for apidoc sv_utf8_decode
3531
3532 If the PV of the SV is an octet sequence in UTF-8
3533 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3534 so that it looks like a character. If the PV contains only single-byte
3535 characters, the C<SvUTF8> flag stays being off.
3536 Scans PV for validity and returns false if the PV is invalid UTF-8.
3537
3538 =cut
3539 */
3540
3541 bool
3542 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3543 {
3544     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3545
3546     if (SvPOKp(sv)) {
3547         const U8 *c;
3548         const U8 *e;
3549
3550         /* The octets may have got themselves encoded - get them back as
3551          * bytes
3552          */
3553         if (!sv_utf8_downgrade(sv, TRUE))
3554             return FALSE;
3555
3556         /* it is actually just a matter of turning the utf8 flag on, but
3557          * we want to make sure everything inside is valid utf8 first.
3558          */
3559         c = (const U8 *) SvPVX_const(sv);
3560         if (!is_utf8_string(c, SvCUR(sv)+1))
3561             return FALSE;
3562         e = (const U8 *) SvEND(sv);
3563         while (c < e) {
3564             const U8 ch = *c++;
3565             if (!UTF8_IS_INVARIANT(ch)) {
3566                 SvUTF8_on(sv);
3567                 break;
3568             }
3569         }
3570     }
3571     return TRUE;
3572 }
3573
3574 /*
3575 =for apidoc sv_setsv
3576
3577 Copies the contents of the source SV C<ssv> into the destination SV
3578 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3579 function if the source SV needs to be reused. Does not handle 'set' magic.
3580 Loosely speaking, it performs a copy-by-value, obliterating any previous
3581 content of the destination.
3582
3583 You probably want to use one of the assortment of wrappers, such as
3584 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3585 C<SvSetMagicSV_nosteal>.
3586
3587 =for apidoc sv_setsv_flags
3588
3589 Copies the contents of the source SV C<ssv> into the destination SV
3590 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3591 function if the source SV needs to be reused. Does not handle 'set' magic.
3592 Loosely speaking, it performs a copy-by-value, obliterating any previous
3593 content of the destination.
3594 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3595 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3596 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3597 and C<sv_setsv_nomg> are implemented in terms of this function.
3598
3599 You probably want to use one of the assortment of wrappers, such as
3600 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3601 C<SvSetMagicSV_nosteal>.
3602
3603 This is the primary function for copying scalars, and most other
3604 copy-ish functions and macros use this underneath.
3605
3606 =cut
3607 */
3608
3609 static void
3610 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3611 {
3612     I32 mro_changes = 0; /* 1 = method, 2 = isa */
3613
3614     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3615
3616     if (dtype != SVt_PVGV) {
3617         const char * const name = GvNAME(sstr);
3618         const STRLEN len = GvNAMELEN(sstr);
3619         {
3620             if (dtype >= SVt_PV) {
3621                 SvPV_free(dstr);
3622                 SvPV_set(dstr, 0);
3623                 SvLEN_set(dstr, 0);
3624                 SvCUR_set(dstr, 0);
3625             }
3626             SvUPGRADE(dstr, SVt_PVGV);
3627             (void)SvOK_off(dstr);
3628             /* FIXME - why are we doing this, then turning it off and on again
3629                below?  */
3630             isGV_with_GP_on(dstr);
3631         }
3632         GvSTASH(dstr) = GvSTASH(sstr);
3633         if (GvSTASH(dstr))
3634             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3635         gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3636         SvFAKE_on(dstr);        /* can coerce to non-glob */
3637     }
3638
3639     if(GvGP(MUTABLE_GV(sstr))) {
3640         /* If source has method cache entry, clear it */
3641         if(GvCVGEN(sstr)) {
3642             SvREFCNT_dec(GvCV(sstr));
3643             GvCV(sstr) = NULL;
3644             GvCVGEN(sstr) = 0;
3645         }
3646         /* If source has a real method, then a method is
3647            going to change */
3648         else if(GvCV((const GV *)sstr)) {
3649             mro_changes = 1;
3650         }
3651     }
3652
3653     /* If dest already had a real method, that's a change as well */
3654     if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3655         mro_changes = 1;
3656     }
3657
3658     if(strEQ(GvNAME((const GV *)dstr),"ISA"))
3659         mro_changes = 2;
3660
3661     gp_free(MUTABLE_GV(dstr));
3662     isGV_with_GP_off(dstr);
3663     (void)SvOK_off(dstr);
3664     isGV_with_GP_on(dstr);
3665     GvINTRO_off(dstr);          /* one-shot flag */
3666     GvGP(dstr) = gp_ref(GvGP(sstr));
3667     if (SvTAINTED(sstr))
3668         SvTAINT(dstr);
3669     if (GvIMPORTED(dstr) != GVf_IMPORTED
3670         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3671         {
3672             GvIMPORTED_on(dstr);
3673         }
3674     GvMULTI_on(dstr);
3675     if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3676     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3677     return;
3678 }
3679
3680 static void
3681 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3682 {
3683     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3684     SV *dref = NULL;
3685     const int intro = GvINTRO(dstr);
3686     SV **location;
3687     U8 import_flag = 0;
3688     const U32 stype = SvTYPE(sref);
3689
3690     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3691
3692     if (intro) {
3693         GvINTRO_off(dstr);      /* one-shot flag */
3694         GvLINE(dstr) = CopLINE(PL_curcop);
3695         GvEGV(dstr) = MUTABLE_GV(dstr);
3696     }
3697     GvMULTI_on(dstr);
3698     switch (stype) {
3699     case SVt_PVCV:
3700         location = (SV **) &GvCV(dstr);
3701         import_flag = GVf_IMPORTED_CV;
3702         goto common;
3703     case SVt_PVHV:
3704         location = (SV **) &GvHV(dstr);
3705         import_flag = GVf_IMPORTED_HV;
3706         goto common;
3707     case SVt_PVAV:
3708         location = (SV **) &GvAV(dstr);
3709         import_flag = GVf_IMPORTED_AV;
3710         goto common;
3711     case SVt_PVIO:
3712         location = (SV **) &GvIOp(dstr);
3713         goto common;
3714     case SVt_PVFM:
3715         location = (SV **) &GvFORM(dstr);
3716         goto common;
3717     default:
3718         location = &GvSV(dstr);
3719         import_flag = GVf_IMPORTED_SV;
3720     common:
3721         if (intro) {
3722             if (stype == SVt_PVCV) {
3723                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3724                 if (GvCVGEN(dstr)) {
3725                     SvREFCNT_dec(GvCV(dstr));
3726                     GvCV(dstr) = NULL;
3727                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3728                 }
3729             }
3730             SAVEGENERICSV(*location);
3731         }
3732         else
3733             dref = *location;
3734         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3735             CV* const cv = MUTABLE_CV(*location);
3736             if (cv) {
3737                 if (!GvCVGEN((const GV *)dstr) &&
3738                     (CvROOT(cv) || CvXSUB(cv)))
3739                     {
3740                         /* Redefining a sub - warning is mandatory if
3741                            it was a const and its value changed. */
3742                         if (CvCONST(cv) && CvCONST((const CV *)sref)
3743                             && cv_const_sv(cv)
3744                             == cv_const_sv((const CV *)sref)) {
3745                             NOOP;
3746                             /* They are 2 constant subroutines generated from
3747                                the same constant. This probably means that
3748                                they are really the "same" proxy subroutine
3749                                instantiated in 2 places. Most likely this is
3750                                when a constant is exported twice.  Don't warn.
3751                             */
3752                         }
3753                         else if (ckWARN(WARN_REDEFINE)
3754                                  || (CvCONST(cv)
3755                                      && (!CvCONST((const CV *)sref)
3756                                          || sv_cmp(cv_const_sv(cv),
3757                                                    cv_const_sv((const CV *)
3758                                                                sref))))) {
3759                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3760                                         (const char *)
3761                                         (CvCONST(cv)
3762                                          ? "Constant subroutine %s::%s redefined"
3763                                          : "Subroutine %s::%s redefined"),
3764                                         HvNAME_get(GvSTASH((const GV *)dstr)),
3765                                         GvENAME(MUTABLE_GV(dstr)));
3766                         }
3767                     }
3768                 if (!intro)
3769                     cv_ckproto_len(cv, (const GV *)dstr,
3770                                    SvPOK(sref) ? SvPVX_const(sref) : NULL,
3771                                    SvPOK(sref) ? SvCUR(sref) : 0);
3772             }
3773             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3774             GvASSUMECV_on(dstr);
3775             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3776         }
3777         *location = sref;
3778         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3779             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3780             GvFLAGS(dstr) |= import_flag;
3781         }
3782         if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
3783             sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3784             mro_isa_changed_in(GvSTASH(dstr));
3785         }
3786         break;
3787     }
3788     SvREFCNT_dec(dref);
3789     if (SvTAINTED(sstr))
3790         SvTAINT(dstr);
3791     return;
3792 }
3793
3794 void
3795 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3796 {
3797     dVAR;
3798     register U32 sflags;
3799     register int dtype;
3800     register svtype stype;
3801
3802     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3803
3804     if (sstr == dstr)
3805         return;
3806
3807     if (SvIS_FREED(dstr)) {
3808         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3809                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3810     }
3811     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3812     if (!sstr)
3813         sstr = &PL_sv_undef;
3814     if (SvIS_FREED(sstr)) {
3815         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3816                    (void*)sstr, (void*)dstr);
3817     }
3818     stype = SvTYPE(sstr);
3819     dtype = SvTYPE(dstr);
3820
3821     (void)SvAMAGIC_off(dstr);
3822     if ( SvVOK(dstr) )
3823     {
3824         /* need to nuke the magic */
3825         mg_free(dstr);
3826     }
3827
3828     /* There's a lot of redundancy below but we're going for speed here */
3829
3830     switch (stype) {
3831     case SVt_NULL:
3832       undef_sstr:
3833         if (dtype != SVt_PVGV) {
3834             (void)SvOK_off(dstr);
3835             return;
3836         }
3837         break;
3838     case SVt_IV:
3839         if (SvIOK(sstr)) {
3840             switch (dtype) {
3841             case SVt_NULL:
3842                 sv_upgrade(dstr, SVt_IV);
3843                 break;
3844             case SVt_NV:
3845             case SVt_PV:
3846                 sv_upgrade(dstr, SVt_PVIV);
3847                 break;
3848             case SVt_PVGV:
3849                 goto end_of_first_switch;
3850             }
3851             (void)SvIOK_only(dstr);
3852             SvIV_set(dstr,  SvIVX(sstr));
3853             if (SvIsUV(sstr))
3854                 SvIsUV_on(dstr);
3855             /* SvTAINTED can only be true if the SV has taint magic, which in
3856                turn means that the SV type is PVMG (or greater). This is the
3857                case statement for SVt_IV, so this cannot be true (whatever gcov
3858                may say).  */
3859             assert(!SvTAINTED(sstr));
3860             return;
3861         }
3862         if (!SvROK(sstr))
3863             goto undef_sstr;
3864         if (dtype < SVt_PV && dtype != SVt_IV)
3865             sv_upgrade(dstr, SVt_IV);
3866         break;
3867
3868     case SVt_NV:
3869         if (SvNOK(sstr)) {
3870             switch (dtype) {
3871             case SVt_NULL:
3872             case SVt_IV:
3873                 sv_upgrade(dstr, SVt_NV);
3874                 break;
3875             case SVt_PV:
3876             case SVt_PVIV:
3877                 sv_upgrade(dstr, SVt_PVNV);
3878                 break;
3879             case SVt_PVGV:
3880                 goto end_of_first_switch;
3881             }
3882             SvNV_set(dstr, SvNVX(sstr));
3883             (void)SvNOK_only(dstr);
3884             /* SvTAINTED can only be true if the SV has taint magic, which in
3885                turn means that the SV type is PVMG (or greater). This is the
3886                case statement for SVt_NV, so this cannot be true (whatever gcov
3887                may say).  */
3888             assert(!SvTAINTED(sstr));
3889             return;
3890         }
3891         goto undef_sstr;
3892
3893     case SVt_PVFM:
3894 #ifdef PERL_OLD_COPY_ON_WRITE
3895         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3896             if (dtype < SVt_PVIV)
3897                 sv_upgrade(dstr, SVt_PVIV);
3898             break;
3899         }
3900         /* Fall through */
3901 #endif
3902     case SVt_PV:
3903         if (dtype < SVt_PV)
3904             sv_upgrade(dstr, SVt_PV);
3905         break;
3906     case SVt_PVIV:
3907         if (dtype < SVt_PVIV)
3908             sv_upgrade(dstr, SVt_PVIV);
3909         break;
3910     case SVt_PVNV:
3911         if (dtype < SVt_PVNV)
3912             sv_upgrade(dstr, SVt_PVNV);
3913         break;
3914     default:
3915         {
3916         const char * const type = sv_reftype(sstr,0);
3917         if (PL_op)
3918             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
3919         else
3920             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3921         }
3922         break;
3923
3924     case SVt_REGEXP:
3925         if (dtype < SVt_REGEXP)
3926             sv_upgrade(dstr, SVt_REGEXP);
3927         break;
3928
3929         /* case SVt_BIND: */
3930     case SVt_PVLV:
3931     case SVt_PVGV:
3932         if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3933             glob_assign_glob(dstr, sstr, dtype);
3934             return;
3935         }
3936         /* SvVALID means that this PVGV is playing at being an FBM.  */
3937         /*FALLTHROUGH*/
3938
3939     case SVt_PVMG:
3940         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3941             mg_get(sstr);
3942             if (SvTYPE(sstr) != stype) {
3943                 stype = SvTYPE(sstr);
3944                 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3945                     glob_assign_glob(dstr, sstr, dtype);
3946                     return;
3947                 }
3948             }
3949         }
3950         if (stype == SVt_PVLV)
3951             SvUPGRADE(dstr, SVt_PVNV);
3952         else
3953             SvUPGRADE(dstr, (svtype)stype);
3954     }
3955  end_of_first_switch:
3956
3957     /* dstr may have been upgraded.  */
3958     dtype = SvTYPE(dstr);
3959     sflags = SvFLAGS(sstr);
3960
3961     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3962         /* Assigning to a subroutine sets the prototype.  */
3963         if (SvOK(sstr)) {
3964             STRLEN len;
3965             const char *const ptr = SvPV_const(sstr, len);
3966
3967             SvGROW(dstr, len + 1);
3968             Copy(ptr, SvPVX(dstr), len + 1, char);
3969             SvCUR_set(dstr, len);
3970             SvPOK_only(dstr);
3971             SvFLAGS(dstr) |= sflags & SVf_UTF8;
3972         } else {
3973             SvOK_off(dstr);
3974         }
3975     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3976         const char * const type = sv_reftype(dstr,0);
3977         if (PL_op)
3978             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
3979         else
3980             Perl_croak(aTHX_ "Cannot copy to %s", type);
3981     } else if (sflags & SVf_ROK) {
3982         if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3983             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3984             sstr = SvRV(sstr);
3985             if (sstr == dstr) {
3986                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3987                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3988                 {
3989                     GvIMPORTED_on(dstr);
3990                 }
3991                 GvMULTI_on(dstr);
3992                 return;
3993             }
3994             glob_assign_glob(dstr, sstr, dtype);
3995             return;
3996         }
3997
3998         if (dtype >= SVt_PV) {
3999             if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
4000                 glob_assign_ref(dstr, sstr);
4001                 return;
4002             }
4003             if (SvPVX_const(dstr)) {
4004                 SvPV_free(dstr);
4005                 SvLEN_set(dstr, 0);
4006                 SvCUR_set(dstr, 0);
4007             }
4008         }
4009         (void)SvOK_off(dstr);
4010         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4011         SvFLAGS(dstr) |= sflags & SVf_ROK;
4012         assert(!(sflags & SVp_NOK));
4013         assert(!(sflags & SVp_IOK));
4014         assert(!(sflags & SVf_NOK));
4015         assert(!(sflags & SVf_IOK));
4016     }
4017     else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
4018         if (!(sflags & SVf_OK)) {
4019             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4020                            "Undefined value assigned to typeglob");
4021         }
4022         else {
4023             GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4024             if (dstr != (const SV *)gv) {
4025                 if (GvGP(dstr))
4026                     gp_free(MUTABLE_GV(dstr));
4027                 GvGP(dstr) = gp_ref(GvGP(gv));
4028             }
4029         }
4030     }
4031     else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4032         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4033     }
4034     else if (sflags & SVp_POK) {
4035         bool isSwipe = 0;
4036
4037         /*
4038          * Check to see if we can just swipe the string.  If so, it's a
4039          * possible small lose on short strings, but a big win on long ones.
4040          * It might even be a win on short strings if SvPVX_const(dstr)
4041          * has to be allocated and SvPVX_const(sstr) has to be freed.
4042          * Likewise if we can set up COW rather than doing an actual copy, we
4043          * drop to the else clause, as the swipe code and the COW setup code
4044          * have much in common.
4045          */
4046
4047         /* Whichever path we take through the next code, we want this true,
4048            and doing it now facilitates the COW check.  */
4049         (void)SvPOK_only(dstr);
4050
4051         if (
4052             /* If we're already COW then this clause is not true, and if COW
4053                is allowed then we drop down to the else and make dest COW
4054                with us.  If caller hasn't said that we're allowed to COW
4055                shared hash keys then we don't do the COW setup, even if the
4056                source scalar is a shared hash key scalar.  */
4057             (((flags & SV_COW_SHARED_HASH_KEYS)
4058                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4059                : 1 /* If making a COW copy is forbidden then the behaviour we
4060                        desire is as if the source SV isn't actually already
4061                        COW, even if it is.  So we act as if the source flags
4062                        are not COW, rather than actually testing them.  */
4063               )
4064 #ifndef PERL_OLD_COPY_ON_WRITE
4065              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4066                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4067                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4068                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4069                 but in turn, it's somewhat dead code, never expected to go
4070                 live, but more kept as a placeholder on how to do it better
4071                 in a newer implementation.  */
4072              /* If we are COW and dstr is a suitable target then we drop down
4073                 into the else and make dest a COW of us.  */
4074              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4075 #endif
4076              )
4077             &&
4078             !(isSwipe =
4079                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4080                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4081                  (!(flags & SV_NOSTEAL)) &&
4082                                         /* and we're allowed to steal temps */
4083                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4084                  SvLEN(sstr))             /* and really is a string */
4085 #ifdef PERL_OLD_COPY_ON_WRITE
4086             && ((flags & SV_COW_SHARED_HASH_KEYS)
4087                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4088                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4089                      && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4090                 : 1)
4091 #endif
4092             ) {
4093             /* Failed the swipe test, and it's not a shared hash key either.
4094                Have to copy the string.  */
4095             STRLEN len = SvCUR(sstr);
4096             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4097             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4098             SvCUR_set(dstr, len);
4099             *SvEND(dstr) = '\0';
4100         } else {
4101             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4102                be true in here.  */
4103             /* Either it's a shared hash key, or it's suitable for
4104                copy-on-write or we can swipe the string.  */
4105             if (DEBUG_C_TEST) {
4106                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4107                 sv_dump(sstr);
4108                 sv_dump(dstr);
4109             }
4110 #ifdef PERL_OLD_COPY_ON_WRITE
4111             if (!isSwipe) {
4112                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4113                     != (SVf_FAKE | SVf_READONLY)) {
4114                     SvREADONLY_on(sstr);
4115                     SvFAKE_on(sstr);
4116                     /* Make the source SV into a loop of 1.
4117                        (about to become 2) */
4118                     SV_COW_NEXT_SV_SET(sstr, sstr);
4119                 }
4120             }
4121 #endif
4122             /* Initial code is common.  */
4123             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4124                 SvPV_free(dstr);
4125             }
4126
4127             if (!isSwipe) {
4128                 /* making another shared SV.  */
4129                 STRLEN cur = SvCUR(sstr);
4130                 STRLEN len = SvLEN(sstr);
4131 #ifdef PERL_OLD_COPY_ON_WRITE
4132                 if (len) {
4133                     assert (SvTYPE(dstr) >= SVt_PVIV);
4134                     /* SvIsCOW_normal */
4135                     /* splice us in between source and next-after-source.  */
4136                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4137                     SV_COW_NEXT_SV_SET(sstr, dstr);
4138                     SvPV_set(dstr, SvPVX_mutable(sstr));
4139                 } else
4140 #endif
4141                 {
4142                     /* SvIsCOW_shared_hash */
4143                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4144                                           "Copy on write: Sharing hash\n"));
4145
4146                     assert (SvTYPE(dstr) >= SVt_PV);
4147                     SvPV_set(dstr,
4148                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4149                 }
4150                 SvLEN_set(dstr, len);
4151                 SvCUR_set(dstr, cur);
4152                 SvREADONLY_on(dstr);
4153                 SvFAKE_on(dstr);
4154             }
4155             else
4156                 {       /* Passes the swipe test.  */
4157                 SvPV_set(dstr, SvPVX_mutable(sstr));
4158                 SvLEN_set(dstr, SvLEN(sstr));
4159                 SvCUR_set(dstr, SvCUR(sstr));
4160
4161                 SvTEMP_off(dstr);
4162                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4163                 SvPV_set(sstr, NULL);
4164                 SvLEN_set(sstr, 0);
4165                 SvCUR_set(sstr, 0);
4166                 SvTEMP_off(sstr);
4167             }
4168         }
4169         if (sflags & SVp_NOK) {
4170             SvNV_set(dstr, SvNVX(sstr));
4171         }
4172         if (sflags & SVp_IOK) {
4173             SvIV_set(dstr, SvIVX(sstr));
4174             /* Must do this otherwise some other overloaded use of 0x80000000
4175                gets confused. I guess SVpbm_VALID */
4176             if (sflags & SVf_IVisUV)
4177                 SvIsUV_on(dstr);
4178         }
4179         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4180         {
4181             const MAGIC * const smg = SvVSTRING_mg(sstr);
4182             if (smg) {
4183                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4184                          smg->mg_ptr, smg->mg_len);
4185                 SvRMAGICAL_on(dstr);
4186             }
4187         }
4188     }
4189     else if (sflags & (SVp_IOK|SVp_NOK)) {
4190         (void)SvOK_off(dstr);
4191         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4192         if (sflags & SVp_IOK) {
4193             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4194             SvIV_set(dstr, SvIVX(sstr));
4195         }
4196         if (sflags & SVp_NOK) {
4197             SvNV_set(dstr, SvNVX(sstr));
4198         }
4199     }
4200     else {
4201         if (isGV_with_GP(sstr)) {
4202             /* This stringification rule for globs is spread in 3 places.
4203                This feels bad. FIXME.  */
4204             const U32 wasfake = sflags & SVf_FAKE;
4205
4206             /* FAKE globs can get coerced, so need to turn this off
4207                temporarily if it is on.  */
4208             SvFAKE_off(sstr);
4209             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4210             SvFLAGS(sstr) |= wasfake;
4211         }
4212         else
4213             (void)SvOK_off(dstr);
4214     }
4215     if (SvTAINTED(sstr))
4216         SvTAINT(dstr);
4217 }
4218
4219 /*
4220 =for apidoc sv_setsv_mg
4221
4222 Like C<sv_setsv>, but also handles 'set' magic.
4223
4224 =cut
4225 */
4226
4227 void
4228 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4229 {
4230     PERL_ARGS_ASSERT_SV_SETSV_MG;
4231
4232     sv_setsv(dstr,sstr);
4233     SvSETMAGIC(dstr);
4234 }
4235
4236 #ifdef PERL_OLD_COPY_ON_WRITE
4237 SV *
4238 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4239 {
4240     STRLEN cur = SvCUR(sstr);
4241     STRLEN len = SvLEN(sstr);
4242     register char *new_pv;
4243
4244     PERL_ARGS_ASSERT_SV_SETSV_COW;
4245
4246     if (DEBUG_C_TEST) {
4247         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4248                       (void*)sstr, (void*)dstr);
4249         sv_dump(sstr);
4250         if (dstr)
4251                     sv_dump(dstr);
4252     }
4253
4254     if (dstr) {
4255         if (SvTHINKFIRST(dstr))
4256             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4257         else if (SvPVX_const(dstr))
4258             Safefree(SvPVX_const(dstr));
4259     }
4260     else
4261         new_SV(dstr);
4262     SvUPGRADE(dstr, SVt_PVIV);
4263
4264     assert (SvPOK(sstr));
4265     assert (SvPOKp(sstr));
4266     assert (!SvIOK(sstr));
4267     assert (!SvIOKp(sstr));
4268     assert (!SvNOK(sstr));
4269     assert (!SvNOKp(sstr));
4270
4271     if (SvIsCOW(sstr)) {
4272
4273         if (SvLEN(sstr) == 0) {
4274             /* source is a COW shared hash key.  */
4275             DEBUG_C(PerlIO_printf(Perl_debug_log,
4276                                   "Fast copy on write: Sharing hash\n"));
4277             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4278             goto common_exit;
4279         }
4280         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4281     } else {
4282         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4283         SvUPGRADE(sstr, SVt_PVIV);
4284         SvREADONLY_on(sstr);
4285         SvFAKE_on(sstr);
4286         DEBUG_C(PerlIO_printf(Perl_debug_log,
4287                               "Fast copy on write: Converting sstr to COW\n"));
4288         SV_COW_NEXT_SV_SET(dstr, sstr);
4289     }
4290     SV_COW_NEXT_SV_SET(sstr, dstr);
4291     new_pv = SvPVX_mutable(sstr);
4292
4293   common_exit:
4294     SvPV_set(dstr, new_pv);
4295     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4296     if (SvUTF8(sstr))
4297         SvUTF8_on(dstr);
4298     SvLEN_set(dstr, len);
4299     SvCUR_set(dstr, cur);
4300     if (DEBUG_C_TEST) {
4301         sv_dump(dstr);
4302     }
4303     return dstr;
4304 }
4305 #endif
4306
4307 /*
4308 =for apidoc sv_setpvn
4309
4310 Copies a string into an SV.  The C<len> parameter indicates the number of
4311 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4312 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4313
4314 =cut
4315 */
4316
4317 void
4318 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4319 {
4320     dVAR;
4321     register char *dptr;
4322
4323     PERL_ARGS_ASSERT_SV_SETPVN;
4324
4325     SV_CHECK_THINKFIRST_COW_DROP(sv);
4326     if (!ptr) {
4327         (void)SvOK_off(sv);
4328         return;
4329     }
4330     else {
4331         /* len is STRLEN which is unsigned, need to copy to signed */
4332         const IV iv = len;
4333         if (iv < 0)
4334             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4335     }
4336     SvUPGRADE(sv, SVt_PV);
4337
4338     dptr = SvGROW(sv, len + 1);
4339     Move(ptr,dptr,len,char);
4340     dptr[len] = '\0';
4341     SvCUR_set(sv, len);
4342     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4343     SvTAINT(sv);
4344 }
4345
4346 /*
4347 =for apidoc sv_setpvn_mg
4348
4349 Like C<sv_setpvn>, but also handles 'set' magic.
4350
4351 =cut
4352 */
4353
4354 void
4355 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4356 {
4357     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4358
4359     sv_setpvn(sv,ptr,len);
4360     SvSETMAGIC(sv);
4361 }
4362
4363 /*
4364 =for apidoc sv_setpv
4365
4366 Copies a string into an SV.  The string must be null-terminated.  Does not
4367 handle 'set' magic.  See C<sv_setpv_mg>.
4368
4369 =cut
4370 */
4371
4372 void
4373 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4374 {
4375     dVAR;
4376     register STRLEN len;
4377
4378     PERL_ARGS_ASSERT_SV_SETPV;
4379
4380     SV_CHECK_THINKFIRST_COW_DROP(sv);
4381     if (!ptr) {
4382         (void)SvOK_off(sv);
4383         return;
4384     }
4385     len = strlen(ptr);
4386     SvUPGRADE(sv, SVt_PV);
4387
4388     SvGROW(sv, len + 1);
4389     Move(ptr,SvPVX(sv),len+1,char);
4390     SvCUR_set(sv, len);
4391     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4392     SvTAINT(sv);
4393 }
4394
4395 /*
4396 =for apidoc sv_setpv_mg
4397
4398 Like C<sv_setpv>, but also handles 'set' magic.
4399
4400 =cut
4401 */
4402
4403 void
4404 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4405 {
4406     PERL_ARGS_ASSERT_SV_SETPV_MG;
4407
4408     sv_setpv(sv,ptr);
4409     SvSETMAGIC(sv);
4410 }
4411
4412 /*
4413 =for apidoc sv_usepvn_flags
4414
4415 Tells an SV to use C<ptr> to find its string value.  Normally the
4416 string is stored inside the SV but sv_usepvn allows the SV to use an
4417 outside string.  The C<ptr> should point to memory that was allocated
4418 by C<malloc>.  The string length, C<len>, must be supplied.  By default
4419 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4420 so that pointer should not be freed or used by the programmer after
4421 giving it to sv_usepvn, and neither should any pointers from "behind"
4422 that pointer (e.g. ptr + 1) be used.
4423
4424 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4425 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4426 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4427 C<len>, and already meets the requirements for storing in C<SvPVX>)
4428
4429 =cut
4430 */
4431
4432 void
4433 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4434 {
4435     dVAR;
4436     STRLEN allocate;
4437
4438     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4439
4440     SV_CHECK_THINKFIRST_COW_DROP(sv);
4441     SvUPGRADE(sv, SVt_PV);
4442     if (!ptr) {
4443         (void)SvOK_off(sv);
4444         if (flags & SV_SMAGIC)
4445             SvSETMAGIC(sv);
4446         return;
4447     }
4448     if (SvPVX_const(sv))
4449         SvPV_free(sv);
4450
4451 #ifdef DEBUGGING
4452     if (flags & SV_HAS_TRAILING_NUL)
4453         assert(ptr[len] == '\0');
4454 #endif
4455
4456     allocate = (flags & SV_HAS_TRAILING_NUL)
4457         ? len + 1 :
4458 #ifdef Perl_safesysmalloc_size
4459         len + 1;
4460 #else
4461         PERL_STRLEN_ROUNDUP(len + 1);
4462 #endif
4463     if (flags & SV_HAS_TRAILING_NUL) {
4464         /* It's long enough - do nothing.
4465            Specfically Perl_newCONSTSUB is relying on this.  */
4466     } else {
4467 #ifdef DEBUGGING
4468         /* Force a move to shake out bugs in callers.  */
4469         char *new_ptr = (char*)safemalloc(allocate);
4470         Copy(ptr, new_ptr, len, char);
4471         PoisonFree(ptr,len,char);
4472         Safefree(ptr);
4473         ptr = new_ptr;
4474 #else
4475         ptr = (char*) saferealloc (ptr, allocate);
4476 #endif
4477     }
4478 #ifdef Perl_safesysmalloc_size
4479     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4480 #else
4481     SvLEN_set(sv, allocate);
4482 #endif
4483     SvCUR_set(sv, len);
4484     SvPV_set(sv, ptr);
4485     if (!(flags & SV_HAS_TRAILING_NUL)) {
4486         ptr[len] = '\0';
4487     }
4488     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4489     SvTAINT(sv);
4490     if (flags & SV_SMAGIC)
4491         SvSETMAGIC(sv);
4492 }
4493
4494 #ifdef PERL_OLD_COPY_ON_WRITE
4495 /* Need to do this *after* making the SV normal, as we need the buffer
4496    pointer to remain valid until after we've copied it.  If we let go too early,
4497    another thread could invalidate it by unsharing last of the same hash key
4498    (which it can do by means other than releasing copy-on-write Svs)
4499    or by changing the other copy-on-write SVs in the loop.  */
4500 STATIC void
4501 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4502 {
4503     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4504
4505     { /* this SV was SvIsCOW_normal(sv) */
4506          /* we need to find the SV pointing to us.  */
4507         SV *current = SV_COW_NEXT_SV(after);
4508
4509         if (current == sv) {
4510             /* The SV we point to points back to us (there were only two of us
4511                in the loop.)
4512                Hence other SV is no longer copy on write either.  */
4513             SvFAKE_off(after);
4514             SvREADONLY_off(after);
4515         } else {
4516             /* We need to follow the pointers around the loop.  */
4517             SV *next;
4518             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4519                 assert (next);
4520                 current = next;
4521                  /* don't loop forever if the structure is bust, and we have
4522                     a pointer into a closed loop.  */
4523                 assert (current != after);
4524                 assert (SvPVX_const(current) == pvx);
4525             }
4526             /* Make the SV before us point to the SV after us.  */
4527             SV_COW_NEXT_SV_SET(current, after);
4528         }
4529     }
4530 }
4531 #endif
4532 /*
4533 =for apidoc sv_force_normal_flags
4534
4535 Undo various types of fakery on an SV: if the PV is a shared string, make
4536 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4537 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4538 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4539 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4540 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4541 set to some other value.) In addition, the C<flags> parameter gets passed to
4542 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4543 with flags set to 0.
4544
4545 =cut
4546 */
4547
4548 void
4549 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4550 {
4551     dVAR;
4552
4553     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4554
4555 #ifdef PERL_OLD_COPY_ON_WRITE
4556     if (SvREADONLY(sv)) {
4557         if (SvFAKE(sv)) {
4558             const char * const pvx = SvPVX_const(sv);
4559             const STRLEN len = SvLEN(sv);
4560             const STRLEN cur = SvCUR(sv);
4561             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4562                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4563                we'll fail an assertion.  */
4564             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4565
4566             if (DEBUG_C_TEST) {
4567                 PerlIO_printf(Perl_debug_log,
4568                               "Copy on write: Force normal %ld\n",
4569                               (long) flags);
4570                 sv_dump(sv);
4571             }
4572             SvFAKE_off(sv);
4573             SvREADONLY_off(sv);
4574             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4575             SvPV_set(sv, NULL);
4576             SvLEN_set(sv, 0);
4577             if (flags & SV_COW_DROP_PV) {
4578                 /* OK, so we don't need to copy our buffer.  */
4579                 SvPOK_off(sv);
4580             } else {
4581                 SvGROW(sv, cur + 1);
4582                 Move(pvx,SvPVX(sv),cur,char);
4583                 SvCUR_set(sv, cur);
4584                 *SvEND(sv) = '\0';
4585             }
4586             if (len) {
4587                 sv_release_COW(sv, pvx, next);
4588             } else {
4589                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4590             }
4591             if (DEBUG_C_TEST) {
4592                 sv_dump(sv);
4593             }
4594         }
4595         else if (IN_PERL_RUNTIME)
4596             Perl_croak(aTHX_ "%s", PL_no_modify);
4597     }
4598 #else
4599     if (SvREADONLY(sv)) {
4600         if (SvFAKE(sv)) {
4601             const char * const pvx = SvPVX_const(sv);
4602             const STRLEN len = SvCUR(sv);
4603             SvFAKE_off(sv);
4604             SvREADONLY_off(sv);
4605             SvPV_set(sv, NULL);
4606             SvLEN_set(sv, 0);
4607             SvGROW(sv, len + 1);
4608             Move(pvx,SvPVX(sv),len,char);
4609             *SvEND(sv) = '\0';
4610             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4611         }
4612         else if (IN_PERL_RUNTIME)
4613             Perl_croak(aTHX_ "%s", PL_no_modify);
4614     }
4615 #endif
4616     if (SvROK(sv))
4617         sv_unref_flags(sv, flags);
4618     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4619         sv_unglob(sv);
4620     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4621         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4622            to sv_unglob. We only need it here, so inline it.  */
4623         const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4624         SV *const temp = newSV_type(new_type);
4625         void *const temp_p = SvANY(sv);
4626
4627         if (new_type == SVt_PVMG) {
4628             SvMAGIC_set(temp, SvMAGIC(sv));
4629             SvMAGIC_set(sv, NULL);
4630             SvSTASH_set(temp, SvSTASH(sv));
4631             SvSTASH_set(sv, NULL);
4632         }
4633         SvCUR_set(temp, SvCUR(sv));
4634         /* Remember that SvPVX is in the head, not the body. */
4635         if (SvLEN(temp)) {
4636             SvLEN_set(temp, SvLEN(sv));
4637             /* This signals "buffer is owned by someone else" in sv_clear,
4638                which is the least effort way to stop it freeing the buffer.
4639             */
4640             SvLEN_set(sv, SvLEN(sv)+1);
4641         } else {
4642             /* Their buffer is already owned by someone else. */
4643             SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4644             SvLEN_set(temp, SvCUR(sv)+1);
4645         }
4646
4647         /* Now swap the rest of the bodies. */
4648
4649         SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4650         SvFLAGS(sv) |= new_type;
4651         SvANY(sv) = SvANY(temp);
4652
4653         SvFLAGS(temp) &= ~(SVTYPEMASK);
4654         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4655         SvANY(temp) = temp_p;
4656
4657         SvREFCNT_dec(temp);
4658     }
4659 }
4660
4661 /*
4662 =for apidoc sv_chop
4663
4664 Efficient removal of characters from the beginning of the string buffer.
4665 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4666 the string buffer.  The C<ptr> becomes the first character of the adjusted
4667 string. Uses the "OOK hack".
4668 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4669 refer to the same chunk of data.
4670
4671 =cut
4672 */
4673
4674 void
4675 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4676 {
4677     STRLEN delta;
4678     STRLEN old_delta;
4679     U8 *p;
4680 #ifdef DEBUGGING
4681     const U8 *real_start;
4682 #endif
4683     STRLEN max_delta;
4684
4685     PERL_ARGS_ASSERT_SV_CHOP;
4686
4687     if (!ptr || !SvPOKp(sv))
4688         return;
4689     delta = ptr - SvPVX_const(sv);
4690     if (!delta) {
4691         /* Nothing to do.  */
4692         return;
4693     }
4694     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4695        nothing uses the value of ptr any more.  */
4696     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4697     if (ptr <= SvPVX_const(sv))
4698         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4699                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4700     SV_CHECK_THINKFIRST(sv);
4701     if (delta > max_delta)
4702         Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4703                    SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4704                    SvPVX_const(sv) + max_delta);
4705
4706     if (!SvOOK(sv)) {
4707         if (!SvLEN(sv)) { /* make copy of shared string */
4708             const char *pvx = SvPVX_const(sv);
4709             const STRLEN len = SvCUR(sv);
4710             SvGROW(sv, len + 1);
4711             Move(pvx,SvPVX(sv),len,char);
4712             *SvEND(sv) = '\0';
4713         }
4714         SvFLAGS(sv) |= SVf_OOK;
4715         old_delta = 0;
4716     } else {
4717         SvOOK_offset(sv, old_delta);
4718     }
4719     SvLEN_set(sv, SvLEN(sv) - delta);
4720     SvCUR_set(sv, SvCUR(sv) - delta);
4721     SvPV_set(sv, SvPVX(sv) + delta);
4722
4723     p = (U8 *)SvPVX_const(sv);
4724
4725     delta += old_delta;
4726
4727 #ifdef DEBUGGING
4728     real_start = p - delta;
4729 #endif
4730
4731     assert(delta);
4732     if (delta < 0x100) {
4733         *--p = (U8) delta;
4734     } else {
4735         *--p = 0;
4736         p -= sizeof(STRLEN);
4737         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4738     }
4739
4740 #ifdef DEBUGGING
4741     /* Fill the preceding buffer with sentinals to verify that no-one is
4742        using it.  */
4743     while (p > real_start) {
4744         --p;
4745         *p = (U8)PTR2UV(p);
4746     }
4747 #endif
4748 }
4749
4750 /*
4751 =for apidoc sv_catpvn
4752
4753 Concatenates the string onto the end of the string which is in the SV.  The
4754 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4755 status set, then the bytes appended should be valid UTF-8.
4756 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4757
4758 =for apidoc sv_catpvn_flags
4759
4760 Concatenates the string onto the end of the string which is in the SV.  The
4761 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4762 status set, then the bytes appended should be valid UTF-8.
4763 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4764 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4765 in terms of this function.
4766
4767 =cut
4768 */
4769
4770 void
4771 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4772 {
4773     dVAR;
4774     STRLEN dlen;
4775     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4776
4777     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4778
4779     SvGROW(dsv, dlen + slen + 1);
4780     if (sstr == dstr)
4781         sstr = SvPVX_const(dsv);
4782     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4783     SvCUR_set(dsv, SvCUR(dsv) + slen);
4784     *SvEND(dsv) = '\0';
4785     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4786     SvTAINT(dsv);
4787     if (flags & SV_SMAGIC)
4788         SvSETMAGIC(dsv);
4789 }
4790
4791 /*
4792 =for apidoc sv_catsv
4793
4794 Concatenates the string from SV C<ssv> onto the end of the string in
4795 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4796 not 'set' magic.  See C<sv_catsv_mg>.
4797
4798 =for apidoc sv_catsv_flags
4799
4800 Concatenates the string from SV C<ssv> onto the end of the string in
4801 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4802 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4803 and C<sv_catsv_nomg> are implemented in terms of this function.
4804
4805 =cut */
4806
4807 void
4808 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4809 {
4810     dVAR;
4811
4812     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4813
4814    if (ssv) {
4815         STRLEN slen;
4816         const char *spv = SvPV_const(ssv, slen);
4817         if (spv) {
4818             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4819                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4820                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4821                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4822                 dsv->sv_flags doesn't have that bit set.
4823                 Andy Dougherty  12 Oct 2001
4824             */
4825             const I32 sutf8 = DO_UTF8(ssv);
4826             I32 dutf8;
4827
4828             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4829                 mg_get(dsv);
4830             dutf8 = DO_UTF8(dsv);
4831
4832             if (dutf8 != sutf8) {
4833                 if (dutf8) {
4834                     /* Not modifying source SV, so taking a temporary copy. */
4835                     SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4836
4837                     sv_utf8_upgrade(csv);
4838                     spv = SvPV_const(csv, slen);
4839                 }
4840                 else
4841                     /* Leave enough space for the cat that's about to happen */
4842                     sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4843             }
4844             sv_catpvn_nomg(dsv, spv, slen);
4845         }
4846     }
4847     if (flags & SV_SMAGIC)
4848         SvSETMAGIC(dsv);
4849 }
4850
4851 /*
4852 =for apidoc sv_catpv
4853
4854 Concatenates the string onto the end of the string which is in the SV.
4855 If the SV has the UTF-8 status set, then the bytes appended should be
4856 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4857
4858 =cut */
4859
4860 void
4861 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4862 {
4863     dVAR;
4864     register STRLEN len;
4865     STRLEN tlen;
4866     char *junk;
4867
4868     PERL_ARGS_ASSERT_SV_CATPV;
4869
4870     if (!ptr)
4871         return;
4872     junk = SvPV_force(sv, tlen);
4873     len = strlen(ptr);
4874     SvGROW(sv, tlen + len + 1);
4875     if (ptr == junk)
4876         ptr = SvPVX_const(sv);
4877     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4878     SvCUR_set(sv, SvCUR(sv) + len);
4879     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4880     SvTAINT(sv);
4881 }
4882
4883 /*
4884 =for apidoc sv_catpv_mg
4885
4886 Like C<sv_catpv>, but also handles 'set' magic.
4887
4888 =cut
4889 */
4890
4891 void
4892 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4893 {
4894     PERL_ARGS_ASSERT_SV_CATPV_MG;
4895
4896     sv_catpv(sv,ptr);
4897     SvSETMAGIC(sv);
4898 }
4899
4900 /*
4901 =for apidoc newSV
4902
4903 Creates a new SV.  A non-zero C<len> parameter indicates the number of
4904 bytes of preallocated string space the SV should have.  An extra byte for a
4905 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
4906 space is allocated.)  The reference count for the new SV is set to 1.
4907
4908 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4909 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4910 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4911 L<perlhack/PERL_MEM_LOG>).  The older API is still there for use in XS
4912 modules supporting older perls.
4913
4914 =cut
4915 */
4916
4917 SV *
4918 Perl_newSV(pTHX_ const STRLEN len)
4919 {
4920     dVAR;
4921     register SV *sv;
4922
4923     new_SV(sv);
4924     if (len) {
4925         sv_upgrade(sv, SVt_PV);
4926         SvGROW(sv, len + 1);
4927     }
4928     return sv;
4929 }
4930 /*
4931 =for apidoc sv_magicext
4932
4933 Adds magic to an SV, upgrading it if necessary. Applies the
4934 supplied vtable and returns a pointer to the magic added.
4935
4936 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4937 In particular, you can add magic to SvREADONLY SVs, and add more than
4938 one instance of the same 'how'.
4939
4940 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4941 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4942 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4943 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4944
4945 (This is now used as a subroutine by C<sv_magic>.)
4946
4947 =cut
4948 */
4949 MAGIC *
4950 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4951                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4952 {
4953     dVAR;
4954     MAGIC* mg;
4955
4956     PERL_ARGS_ASSERT_SV_MAGICEXT;
4957
4958     SvUPGRADE(sv, SVt_PVMG);
4959     Newxz(mg, 1, MAGIC);
4960     mg->mg_moremagic = SvMAGIC(sv);
4961     SvMAGIC_set(sv, mg);
4962
4963     /* Sometimes a magic contains a reference loop, where the sv and
4964        object refer to each other.  To prevent a reference loop that
4965        would prevent such objects being freed, we look for such loops
4966        and if we find one we avoid incrementing the object refcount.
4967
4968        Note we cannot do this to avoid self-tie loops as intervening RV must
4969        have its REFCNT incremented to keep it in existence.
4970
4971     */
4972     if (!obj || obj == sv ||
4973         how == PERL_MAGIC_arylen ||
4974         how == PERL_MAGIC_symtab ||
4975         (SvTYPE(obj) == SVt_PVGV &&
4976             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4977              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4978              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4979     {
4980         mg->mg_obj = obj;
4981     }
4982     else {
4983         mg->mg_obj = SvREFCNT_inc_simple(obj);
4984         mg->mg_flags |= MGf_REFCOUNTED;
4985     }
4986
4987     /* Normal self-ties simply pass a null object, and instead of
4988        using mg_obj directly, use the SvTIED_obj macro to produce a
4989        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4990        with an RV obj pointing to the glob containing the PVIO.  In
4991        this case, to avoid a reference loop, we need to weaken the
4992        reference.
4993     */
4994
4995     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4996         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
4997     {
4998       sv_rvweaken(obj);
4999     }
5000
5001     mg->mg_type = how;
5002     mg->mg_len = namlen;
5003     if (name) {
5004         if (namlen > 0)
5005             mg->mg_ptr = savepvn(name, namlen);
5006         else if (namlen == HEf_SVKEY) {
5007             /* Yes, this is casting away const. This is only for the case of
5008                HEf_SVKEY. I think we need to document this abberation of the
5009                constness of the API, rather than making name non-const, as
5010                that change propagating outwards a long way.  */
5011             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5012         } else
5013             mg->mg_ptr = (char *) name;
5014     }
5015     mg->mg_virtual = (MGVTBL *) vtable;
5016
5017     mg_magical(sv);
5018     if (SvGMAGICAL(sv))
5019         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5020     return mg;
5021 }
5022
5023 /*
5024 =for apidoc sv_magic
5025
5026 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5027 then adds a new magic item of type C<how> to the head of the magic list.
5028
5029 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5030 handling of the C<name> and C<namlen> arguments.
5031
5032 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5033 to add more than one instance of the same 'how'.
5034
5035 =cut
5036 */
5037
5038 void
5039 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5040              const char *const name, const I32 namlen)
5041 {
5042     dVAR;
5043     const MGVTBL *vtable;
5044     MAGIC* mg;
5045
5046     PERL_ARGS_ASSERT_SV_MAGIC;
5047
5048 #ifdef PERL_OLD_COPY_ON_WRITE
5049     if (SvIsCOW(sv))
5050         sv_force_normal_flags(sv, 0);
5051 #endif
5052     if (SvREADONLY(sv)) {
5053         if (
5054             /* its okay to attach magic to shared strings; the subsequent
5055              * upgrade to PVMG will unshare the string */
5056             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5057
5058             && IN_PERL_RUNTIME
5059             && how != PERL_MAGIC_regex_global
5060             && how != PERL_MAGIC_bm
5061             && how != PERL_MAGIC_fm
5062             && how != PERL_MAGIC_sv
5063             && how != PERL_MAGIC_backref
5064            )
5065         {
5066             Perl_croak(aTHX_ "%s", PL_no_modify);
5067         }
5068     }
5069     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5070         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5071             /* sv_magic() refuses to add a magic of the same 'how' as an
5072                existing one
5073              */
5074             if (how == PERL_MAGIC_taint) {
5075                 mg->mg_len |= 1;
5076                 /* Any scalar which already had taint magic on which someone
5077                    (erroneously?) did SvIOK_on() or similar will now be
5078                    incorrectly sporting public "OK" flags.  */
5079                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5080             }
5081             return;
5082         }
5083     }
5084
5085     switch (how) {
5086     case PERL_MAGIC_sv:
5087         vtable = &PL_vtbl_sv;
5088         break;
5089     case PERL_MAGIC_overload:
5090         vtable = &PL_vtbl_amagic;
5091         break;
5092     case PERL_MAGIC_overload_elem:
5093         vtable = &PL_vtbl_amagicelem;
5094         break;
5095     case PERL_MAGIC_overload_table:
5096         vtable = &PL_vtbl_ovrld;
5097         break;
5098     case PERL_MAGIC_bm:
5099         vtable = &PL_vtbl_bm;
5100         break;
5101     case PERL_MAGIC_regdata:
5102         vtable = &PL_vtbl_regdata;
5103         break;
5104     case PERL_MAGIC_regdatum:
5105         vtable = &PL_vtbl_regdatum;
5106         break;
5107     case PERL_MAGIC_env:
5108         vtable = &PL_vtbl_env;
5109         break;
5110     case PERL_MAGIC_fm:
5111         vtable = &PL_vtbl_fm;
5112         break;
5113     case PERL_MAGIC_envelem:
5114         vtable = &PL_vtbl_envelem;
5115         break;
5116     case PERL_MAGIC_regex_global:
5117         vtable = &PL_vtbl_mglob;
5118         break;
5119     case PERL_MAGIC_isa:
5120         vtable = &PL_vtbl_isa;
5121         break;
5122     case PERL_MAGIC_isaelem:
5123         vtable = &PL_vtbl_isaelem;
5124         break;
5125     case PERL_MAGIC_nkeys:
5126         vtable = &PL_vtbl_nkeys;
5127         break;
5128     case PERL_MAGIC_dbfile:
5129         vtable = NULL;
5130         break;
5131     case PERL_MAGIC_dbline:
5132         vtable = &PL_vtbl_dbline;
5133         break;
5134 #ifdef USE_LOCALE_COLLATE
5135     case PERL_MAGIC_collxfrm:
5136         vtable = &PL_vtbl_collxfrm;
5137         break;
5138 #endif /* USE_LOCALE_COLLATE */
5139     case PERL_MAGIC_tied:
5140         vtable = &PL_vtbl_pack;
5141         break;
5142     case PERL_MAGIC_tiedelem:
5143     case PERL_MAGIC_tiedscalar:
5144         vtable = &PL_vtbl_packelem;
5145         break;
5146     case PERL_MAGIC_qr:
5147         vtable = &PL_vtbl_regexp;
5148         break;
5149     case PERL_MAGIC_sig:
5150         vtable = &PL_vtbl_sig;
5151         break;
5152     case PERL_MAGIC_sigelem:
5153         vtable = &PL_vtbl_sigelem;
5154         break;
5155     case PERL_MAGIC_taint:
5156         vtable = &PL_vtbl_taint;
5157         break;
5158     case PERL_MAGIC_uvar:
5159         vtable = &PL_vtbl_uvar;
5160         break;
5161     case PERL_MAGIC_vec:
5162         vtable = &PL_vtbl_vec;
5163         break;
5164     case PERL_MAGIC_arylen_p:
5165     case PERL_MAGIC_rhash:
5166     case PERL_MAGIC_symtab:
5167     case PERL_MAGIC_vstring:
5168         vtable = NULL;
5169         break;
5170     case PERL_MAGIC_utf8:
5171         vtable = &PL_vtbl_utf8;
5172         break;
5173     case PERL_MAGIC_substr:
5174         vtable = &PL_vtbl_substr;
5175         break;
5176     case PERL_MAGIC_defelem:
5177         vtable = &PL_vtbl_defelem;
5178         break;
5179     case PERL_MAGIC_arylen:
5180         vtable = &PL_vtbl_arylen;
5181         break;
5182     case PERL_MAGIC_pos:
5183         vtable = &PL_vtbl_pos;
5184         break;
5185     case PERL_MAGIC_backref:
5186         vtable = &PL_vtbl_backref;
5187         break;
5188     case PERL_MAGIC_hintselem:
5189         vtable = &PL_vtbl_hintselem;
5190         break;
5191     case PERL_MAGIC_hints:
5192         vtable = &PL_vtbl_hints;
5193         break;
5194     case PERL_MAGIC_ext:
5195         /* Reserved for use by extensions not perl internals.           */
5196         /* Useful for attaching extension internal data to perl vars.   */
5197         /* Note that multiple extensions may clash if magical scalars   */
5198         /* etc holding private data from one are passed to another.     */
5199         vtable = NULL;
5200         break;
5201     default:
5202         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5203     }
5204
5205     /* Rest of work is done else where */
5206     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5207
5208     switch (how) {
5209     case PERL_MAGIC_taint:
5210         mg->mg_len = 1;
5211         break;
5212     case PERL_MAGIC_ext:
5213     case PERL_MAGIC_dbfile:
5214         SvRMAGICAL_on(sv);
5215         break;
5216     }
5217 }
5218
5219 /*
5220 =for apidoc sv_unmagic
5221
5222 Removes all magic of type C<type> from an SV.
5223
5224 =cut
5225 */
5226
5227 int
5228 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5229 {
5230     MAGIC* mg;
5231     MAGIC** mgp;
5232
5233     PERL_ARGS_ASSERT_SV_UNMAGIC;
5234
5235     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5236         return 0;
5237     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5238     for (mg = *mgp; mg; mg = *mgp) {
5239         if (mg->mg_type == type) {
5240             const MGVTBL* const vtbl = mg->mg_virtual;
5241             *mgp = mg->mg_moremagic;
5242             if (vtbl && vtbl->svt_free)
5243                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5244             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5245                 if (mg->mg_len > 0)
5246                     Safefree(mg->mg_ptr);
5247                 else if (mg->mg_len == HEf_SVKEY)
5248                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5249                 else if (mg->mg_type == PERL_MAGIC_utf8)
5250                     Safefree(mg->mg_ptr);
5251             }
5252             if (mg->mg_flags & MGf_REFCOUNTED)
5253                 SvREFCNT_dec(mg->mg_obj);
5254             Safefree(mg);
5255         }
5256         else
5257             mgp = &mg->mg_moremagic;
5258     }
5259     if (SvMAGIC(sv)) {
5260         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5261             mg_magical(sv);     /*    else fix the flags now */
5262     }
5263     else {
5264         SvMAGICAL_off(sv);
5265         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5266     }
5267     return 0;
5268 }
5269
5270 /*
5271 =for apidoc sv_rvweaken
5272
5273 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5274 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5275 push a back-reference to this RV onto the array of backreferences
5276 associated with that magic. If the RV is magical, set magic will be
5277 called after the RV is cleared.
5278
5279 =cut
5280 */
5281
5282 SV *
5283 Perl_sv_rvweaken(pTHX_ SV *const sv)
5284 {
5285     SV *tsv;
5286
5287     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5288
5289     if (!SvOK(sv))  /* let undefs pass */
5290         return sv;
5291     if (!SvROK(sv))
5292         Perl_croak(aTHX_ "Can't weaken a nonreference");
5293     else if (SvWEAKREF(sv)) {
5294         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5295         return sv;
5296     }
5297     tsv = SvRV(sv);
5298     Perl_sv_add_backref(aTHX_ tsv, sv);
5299     SvWEAKREF_on(sv);
5300     SvREFCNT_dec(tsv);
5301     return sv;
5302 }
5303
5304 /* Give tsv backref magic if it hasn't already got it, then push a
5305  * back-reference to sv onto the array associated with the backref magic.
5306  */
5307
5308 /* A discussion about the backreferences array and its refcount:
5309  *
5310  * The AV holding the backreferences is pointed to either as the mg_obj of
5311  * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5312  * structure, from the xhv_backreferences field. (A HV without hv_aux will
5313  * have the standard magic instead.) The array is created with a refcount
5314  * of 2. This means that if during global destruction the array gets
5315  * picked on first to have its refcount decremented by the random zapper,
5316  * it won't actually be freed, meaning it's still theere for when its
5317  * parent gets freed.
5318  * When the parent SV is freed, in the case of magic, the magic is freed,
5319  * Perl_magic_killbackrefs is called which decrements one refcount, then
5320  * mg_obj is freed which kills the second count.
5321  * In the vase of a HV being freed, one ref is removed by
5322  * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5323  * calls.
5324  */
5325
5326 void
5327 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5328 {
5329     dVAR;
5330     AV *av;
5331
5332     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5333
5334     if (SvTYPE(tsv) == SVt_PVHV) {
5335         AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5336
5337         av = *avp;
5338         if (!av) {
5339             /* There is no AV in the offical place - try a fixup.  */
5340             MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5341
5342             if (mg) {
5343                 /* Aha. They've got it stowed in magic.  Bring it back.  */
5344                 av = MUTABLE_AV(mg->mg_obj);
5345                 /* Stop mg_free decreasing the refernce count.  */
5346                 mg->mg_obj = NULL;
5347                 /* Stop mg_free even calling the destructor, given that
5348                    there's no AV to free up.  */
5349                 mg->mg_virtual = 0;
5350                 sv_unmagic(tsv, PERL_MAGIC_backref);
5351             } else {
5352                 av = newAV();
5353                 AvREAL_off(av);
5354                 SvREFCNT_inc_simple_void(av); /* see discussion above */
5355             }
5356             *avp = av;
5357         }
5358     } else {
5359         const MAGIC *const mg
5360             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5361         if (mg)
5362             av = MUTABLE_AV(mg->mg_obj);
5363         else {
5364             av = newAV();
5365             AvREAL_off(av);
5366             sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
5367             /* av now has a refcnt of 2; see discussion above */
5368         }
5369     }
5370     if (AvFILLp(av) >= AvMAX(av)) {
5371         av_extend(av, AvFILLp(av)+1);
5372     }
5373     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5374 }
5375
5376 /* delete a back-reference to ourselves from the backref magic associated
5377  * with the SV we point to.
5378  */
5379
5380 STATIC void
5381 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5382 {
5383     dVAR;
5384     AV *av = NULL;
5385     SV **svp;
5386     I32 i;
5387
5388     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5389
5390     if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5391         av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5392         /* We mustn't attempt to "fix up" the hash here by moving the
5393            backreference array back to the hv_aux structure, as that is stored
5394            in the main HvARRAY(), and hfreentries assumes that no-one
5395            reallocates HvARRAY() while it is running.  */
5396     }
5397     if (!av) {
5398         const MAGIC *const mg
5399             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5400         if (mg)
5401             av = MUTABLE_AV(mg->mg_obj);
5402     }
5403
5404     if (!av)
5405         Perl_croak(aTHX_ "panic: del_backref");
5406
5407     assert(!SvIS_FREED(av));
5408
5409     svp = AvARRAY(av);
5410     /* We shouldn't be in here more than once, but for paranoia reasons lets
5411        not assume this.  */
5412     for (i = AvFILLp(av); i >= 0; i--) {
5413         if (svp[i] == sv) {
5414             const SSize_t fill = AvFILLp(av);
5415             if (i != fill) {
5416                 /* We weren't the last entry.
5417                    An unordered list has this property that you can take the
5418                    last element off the end to fill the hole, and it's still
5419                    an unordered list :-)
5420                 */
5421                 svp[i] = svp[fill];
5422             }
5423             svp[fill] = NULL;
5424             AvFILLp(av) = fill - 1;
5425         }
5426     }
5427 }
5428
5429 int
5430 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5431 {
5432     SV **svp = AvARRAY(av);
5433
5434     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5435     PERL_UNUSED_ARG(sv);
5436
5437     assert(!svp || !SvIS_FREED(av));
5438     if (svp) {
5439         SV *const *const last = svp + AvFILLp(av);
5440
5441         while (svp <= last) {
5442             if (*svp) {
5443                 SV *const referrer = *svp;
5444                 if (SvWEAKREF(referrer)) {
5445                     /* XXX Should we check that it hasn't changed? */
5446                     SvRV_set(referrer, 0);
5447                     SvOK_off(referrer);
5448                     SvWEAKREF_off(referrer);
5449                     SvSETMAGIC(referrer);
5450                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5451                            SvTYPE(referrer) == SVt_PVLV) {
5452                     /* You lookin' at me?  */
5453                     assert(GvSTASH(referrer));
5454                     assert(GvSTASH(referrer) == (const HV *)sv);
5455                     GvSTASH(referrer) = 0;
5456                 } else {
5457                     Perl_croak(aTHX_
5458                                "panic: magic_killbackrefs (flags=%"UVxf")",
5459                                (UV)SvFLAGS(referrer));
5460                 }
5461
5462                 *svp = NULL;
5463             }
5464             svp++;
5465         }
5466     }
5467     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5468     return 0;
5469 }
5470
5471 /*
5472 =for apidoc sv_insert
5473
5474 Inserts a string at the specified offset/length within the SV. Similar to
5475 the Perl substr() function. Handles get magic.
5476
5477 =for apidoc sv_insert_flags
5478
5479 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5480
5481 =cut
5482 */
5483
5484 void
5485 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5486 {
5487     dVAR;
5488     register char *big;
5489     register char *mid;
5490     register char *midend;
5491     register char *bigend;
5492     register I32 i;
5493     STRLEN curlen;
5494
5495     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5496
5497     if (!bigstr)
5498         Perl_croak(aTHX_ "Can't modify non-existent substring");
5499     SvPV_force_flags(bigstr, curlen, flags);
5500     (void)SvPOK_only_UTF8(bigstr);
5501     if (offset + len > curlen) {
5502         SvGROW(bigstr, offset+len+1);
5503         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5504         SvCUR_set(bigstr, offset+len);
5505     }
5506
5507     SvTAINT(bigstr);
5508     i = littlelen - len;
5509     if (i > 0) {                        /* string might grow */
5510         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5511         mid = big + offset + len;
5512         midend = bigend = big + SvCUR(bigstr);
5513         bigend += i;
5514         *bigend = '\0';
5515         while (midend > mid)            /* shove everything down */
5516             *--bigend = *--midend;
5517         Move(little,big+offset,littlelen,char);
5518         SvCUR_set(bigstr, SvCUR(bigstr) + i);
5519         SvSETMAGIC(bigstr);
5520         return;
5521     }
5522     else if (i == 0) {
5523         Move(little,SvPVX(bigstr)+offset,len,char);
5524         SvSETMAGIC(bigstr);
5525         return;
5526     }
5527
5528     big = SvPVX(bigstr);
5529     mid = big + offset;
5530     midend = mid + len;
5531     bigend = big + SvCUR(bigstr);
5532
5533     if (midend > bigend)
5534         Perl_croak(aTHX_ "panic: sv_insert");
5535
5536     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5537         if (littlelen) {
5538             Move(little, mid, littlelen,char);
5539             mid += littlelen;
5540         }
5541         i = bigend - midend;
5542         if (i > 0) {
5543             Move(midend, mid, i,char);
5544             mid += i;
5545         }
5546         *mid = '\0';
5547         SvCUR_set(bigstr, mid - big);
5548     }
5549     else if ((i = mid - big)) { /* faster from front */
5550         midend -= littlelen;
5551         mid = midend;
5552         Move(big, midend - i, i, char);
5553         sv_chop(bigstr,midend-i);
5554         if (littlelen)
5555             Move(little, mid, littlelen,char);
5556     }
5557     else if (littlelen) {
5558         midend -= littlelen;
5559         sv_chop(bigstr,midend);
5560         Move(little,midend,littlelen,char);
5561     }
5562     else {
5563         sv_chop(bigstr,midend);
5564     }
5565     SvSETMAGIC(bigstr);
5566 }
5567
5568 /*
5569 =for apidoc sv_replace
5570
5571 Make the first argument a copy of the second, then delete the original.
5572 The target SV physically takes over ownership of the body of the source SV
5573 and inherits its flags; however, the target keeps any magic it owns,
5574 and any magic in the source is discarded.
5575 Note that this is a rather specialist SV copying operation; most of the
5576 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5577
5578 =cut
5579 */
5580
5581 void
5582 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5583 {
5584     dVAR;
5585     const U32 refcnt = SvREFCNT(sv);
5586
5587     PERL_ARGS_ASSERT_SV_REPLACE;
5588
5589     SV_CHECK_THINKFIRST_COW_DROP(sv);
5590     if (SvREFCNT(nsv) != 1) {
5591         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5592                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5593     }
5594     if (SvMAGICAL(sv)) {
5595         if (SvMAGICAL(nsv))
5596             mg_free(nsv);
5597         else
5598             sv_upgrade(nsv, SVt_PVMG);
5599         SvMAGIC_set(nsv, SvMAGIC(sv));
5600         SvFLAGS(nsv) |= SvMAGICAL(sv);
5601         SvMAGICAL_off(sv);
5602         SvMAGIC_set(sv, NULL);
5603     }
5604     SvREFCNT(sv) = 0;
5605     sv_clear(sv);
5606     assert(!SvREFCNT(sv));
5607 #ifdef DEBUG_LEAKING_SCALARS
5608     sv->sv_flags  = nsv->sv_flags;
5609     sv->sv_any    = nsv->sv_any;
5610     sv->sv_refcnt = nsv->sv_refcnt;
5611     sv->sv_u      = nsv->sv_u;
5612 #else
5613     StructCopy(nsv,sv,SV);
5614 #endif
5615     if(SvTYPE(sv) == SVt_IV) {
5616         SvANY(sv)
5617             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5618     }
5619
5620
5621 #ifdef PERL_OLD_COPY_ON_WRITE
5622     if (SvIsCOW_normal(nsv)) {
5623         /* We need to follow the pointers around the loop to make the
5624            previous SV point to sv, rather than nsv.  */
5625         SV *next;
5626         SV *current = nsv;
5627         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5628             assert(next);
5629             current = next;
5630             assert(SvPVX_const(current) == SvPVX_const(nsv));
5631         }
5632         /* Make the SV before us point to the SV after us.  */
5633         if (DEBUG_C_TEST) {
5634             PerlIO_printf(Perl_debug_log, "previous is\n");
5635             sv_dump(current);
5636             PerlIO_printf(Perl_debug_log,
5637                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5638                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5639         }
5640         SV_COW_NEXT_SV_SET(current, sv);
5641     }
5642 #endif
5643     SvREFCNT(sv) = refcnt;
5644     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5645     SvREFCNT(nsv) = 0;
5646     del_SV(nsv);
5647 }
5648
5649 /*
5650 =for apidoc sv_clear
5651
5652 Clear an SV: call any destructors, free up any memory used by the body,
5653 and free the body itself. The SV's head is I<not> freed, although
5654 its type is set to all 1's so that it won't inadvertently be assumed
5655 to be live during global destruction etc.
5656 This function should only be called when REFCNT is zero. Most of the time
5657 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5658 instead.
5659
5660 =cut
5661 */
5662
5663 void
5664 Perl_sv_clear(pTHX_ register SV *const sv)
5665 {
5666     dVAR;
5667     const U32 type = SvTYPE(sv);
5668     const struct body_details *const sv_type_details
5669         = bodies_by_type + type;
5670     HV *stash;
5671
5672     PERL_ARGS_ASSERT_SV_CLEAR;
5673     assert(SvREFCNT(sv) == 0);
5674     assert(SvTYPE(sv) != SVTYPEMASK);
5675
5676     if (type <= SVt_IV) {
5677         /* See the comment in sv.h about the collusion between this early
5678            return and the overloading of the NULL slots in the size table.  */
5679         if (SvROK(sv))
5680             goto free_rv;
5681         SvFLAGS(sv) &= SVf_BREAK;
5682         SvFLAGS(sv) |= SVTYPEMASK;
5683         return;
5684     }
5685
5686     if (SvOBJECT(sv)) {
5687         if (PL_defstash &&      /* Still have a symbol table? */
5688             SvDESTROYABLE(sv))
5689         {
5690             dSP;
5691             HV* stash;
5692             do {
5693                 CV* destructor;
5694                 stash = SvSTASH(sv);
5695                 destructor = StashHANDLER(stash,DESTROY);
5696                 if (destructor
5697                         /* A constant subroutine can have no side effects, so
5698                            don't bother calling it.  */
5699                         && !CvCONST(destructor)
5700                         /* Don't bother calling an empty destructor */
5701                         && (CvISXSUB(destructor)
5702                         || (CvSTART(destructor)
5703                             && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))))
5704                 {
5705                     SV* const tmpref = newRV(sv);
5706                     SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
5707                     ENTER;
5708                     PUSHSTACKi(PERLSI_DESTROY);
5709                     EXTEND(SP, 2);
5710                     PUSHMARK(SP);
5711                     PUSHs(tmpref);
5712                     PUTBACK;
5713                     call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5714
5715
5716                     POPSTACK;
5717                     SPAGAIN;
5718                     LEAVE;
5719                     if(SvREFCNT(tmpref) < 2) {
5720                         /* tmpref is not kept alive! */
5721                         SvREFCNT(sv)--;
5722                         SvRV_set(tmpref, NULL);
5723                         SvROK_off(tmpref);
5724                     }
5725                     SvREFCNT_dec(tmpref);
5726                 }
5727             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5728
5729
5730             if (SvREFCNT(sv)) {
5731                 if (PL_in_clean_objs)
5732                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5733                           HvNAME_get(stash));
5734                 /* DESTROY gave object new lease on life */
5735                 return;
5736             }
5737         }
5738
5739         if (SvOBJECT(sv)) {
5740             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
5741             SvOBJECT_off(sv);   /* Curse the object. */
5742             if (type != SVt_PVIO)
5743                 --PL_sv_objcount;       /* XXX Might want something more general */
5744         }
5745     }
5746     if (type >= SVt_PVMG) {
5747         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5748             SvREFCNT_dec(SvOURSTASH(sv));
5749         } else if (SvMAGIC(sv))
5750             mg_free(sv);
5751         if (type == SVt_PVMG && SvPAD_TYPED(sv))
5752             SvREFCNT_dec(SvSTASH(sv));
5753     }
5754     switch (type) {
5755         /* case SVt_BIND: */
5756     case SVt_PVIO:
5757         if (IoIFP(sv) &&
5758             IoIFP(sv) != PerlIO_stdin() &&
5759             IoIFP(sv) != PerlIO_stdout() &&
5760             IoIFP(sv) != PerlIO_stderr())
5761         {
5762             io_close(MUTABLE_IO(sv), FALSE);
5763         }
5764         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5765             PerlDir_close(IoDIRP(sv));
5766         IoDIRP(sv) = (DIR*)NULL;
5767         Safefree(IoTOP_NAME(sv));
5768         Safefree(IoFMT_NAME(sv));
5769         Safefree(IoBOTTOM_NAME(sv));
5770         goto freescalar;
5771     case SVt_REGEXP:
5772         /* FIXME for plugins */
5773         pregfree2((REGEXP*) sv);
5774         goto freescalar;
5775     case SVt_PVCV:
5776     case SVt_PVFM:
5777         cv_undef(MUTABLE_CV(sv));
5778         goto freescalar;
5779     case SVt_PVHV:
5780         if (PL_last_swash_hv == (const HV *)sv) {
5781             PL_last_swash_hv = NULL;
5782         }
5783         Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5784         hv_undef(MUTABLE_HV(sv));
5785         break;
5786     case SVt_PVAV:
5787         if (PL_comppad == MUTABLE_AV(sv)) {
5788             PL_comppad = NULL;
5789             PL_curpad = NULL;
5790         }
5791         av_undef(MUTABLE_AV(sv));
5792         break;
5793     case SVt_PVLV:
5794         if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5795             SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5796             HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5797             PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5798         }
5799         else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
5800             SvREFCNT_dec(LvTARG(sv));
5801     case SVt_PVGV:
5802         if (isGV_with_GP(sv)) {
5803             if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5804                && HvNAME_get(stash))
5805                 mro_method_changed_in(stash);
5806             gp_free(MUTABLE_GV(sv));
5807             if (GvNAME_HEK(sv))
5808                 unshare_hek(GvNAME_HEK(sv));
5809             /* If we're in a stash, we don't own a reference to it. However it does
5810                have a back reference to us, which needs to be cleared.  */
5811             if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5812                     sv_del_backref(MUTABLE_SV(stash), sv);
5813         }
5814         /* FIXME. There are probably more unreferenced pointers to SVs in the
5815            interpreter struct that we should check and tidy in a similar
5816            fashion to this:  */
5817         if ((const GV *)sv == PL_last_in_gv)
5818             PL_last_in_gv = NULL;
5819     case SVt_PVMG:
5820     case SVt_PVNV:
5821     case SVt_PVIV:
5822     case SVt_PV:
5823       freescalar:
5824         /* Don't bother with SvOOK_off(sv); as we're only going to free it.  */
5825         if (SvOOK(sv)) {
5826             STRLEN offset;
5827             SvOOK_offset(sv, offset);
5828             SvPV_set(sv, SvPVX_mutable(sv) - offset);
5829             /* Don't even bother with turning off the OOK flag.  */
5830         }
5831         if (SvROK(sv)) {
5832         free_rv:
5833             {
5834                 SV * const target = SvRV(sv);
5835                 if (SvWEAKREF(sv))
5836                     sv_del_backref(target, sv);
5837                 else
5838                     SvREFCNT_dec(target);
5839             }
5840         }
5841 #ifdef PERL_OLD_COPY_ON_WRITE
5842         else if (SvPVX_const(sv)) {
5843             if (SvIsCOW(sv)) {
5844                 if (DEBUG_C_TEST) {
5845                     PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5846                     sv_dump(sv);
5847                 }
5848                 if (SvLEN(sv)) {
5849                     sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5850                 } else {
5851                     unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5852                 }
5853
5854                 SvFAKE_off(sv);
5855             } else if (SvLEN(sv)) {
5856                 Safefree(SvPVX_const(sv));
5857             }
5858         }
5859 #else
5860         else if (SvPVX_const(sv) && SvLEN(sv))
5861             Safefree(SvPVX_mutable(sv));
5862         else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5863             unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5864             SvFAKE_off(sv);
5865         }
5866 #endif
5867         break;
5868     case SVt_NV:
5869         break;
5870     }
5871
5872     SvFLAGS(sv) &= SVf_BREAK;
5873     SvFLAGS(sv) |= SVTYPEMASK;
5874
5875     if (sv_type_details->arena) {
5876         del_body(((char *)SvANY(sv) + sv_type_details->offset),
5877                  &PL_body_roots[type]);
5878     }
5879     else if (sv_type_details->body_size) {
5880         my_safefree(SvANY(sv));
5881     }
5882 }
5883
5884 /*
5885 =for apidoc sv_newref
5886
5887 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5888 instead.
5889
5890 =cut
5891 */
5892
5893 SV *
5894 Perl_sv_newref(pTHX_ SV *const sv)
5895 {
5896     PERL_UNUSED_CONTEXT;
5897     if (sv)
5898         (SvREFCNT(sv))++;
5899     return sv;
5900 }
5901
5902 /*
5903 =for apidoc sv_free
5904
5905 Decrement an SV's reference count, and if it drops to zero, call
5906 C<sv_clear> to invoke destructors and free up any memory used by
5907 the body; finally, deallocate the SV's head itself.
5908 Normally called via a wrapper macro C<SvREFCNT_dec>.
5909
5910 =cut
5911 */
5912
5913 void
5914 Perl_sv_free(pTHX_ SV *const sv)
5915 {
5916     dVAR;
5917     if (!sv)
5918         return;
5919     if (SvREFCNT(sv) == 0) {
5920         if (SvFLAGS(sv) & SVf_BREAK)
5921             /* this SV's refcnt has been artificially decremented to
5922              * trigger cleanup */
5923             return;
5924         if (PL_in_clean_all) /* All is fair */
5925             return;
5926         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5927             /* make sure SvREFCNT(sv)==0 happens very seldom */
5928             SvREFCNT(sv) = (~(U32)0)/2;
5929             return;
5930         }
5931         if (ckWARN_d(WARN_INTERNAL)) {
5932 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5933             Perl_dump_sv_child(aTHX_ sv);
5934 #else
5935   #ifdef DEBUG_LEAKING_SCALARS
5936             sv_dump(sv);
5937   #endif
5938 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5939             if (PL_warnhook == PERL_WARNHOOK_FATAL
5940                 || ckDEAD(packWARN(WARN_INTERNAL))) {
5941                 /* Don't let Perl_warner cause us to escape our fate:  */
5942                 abort();
5943             }
5944 #endif
5945             /* This may not return:  */
5946             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5947                         "Attempt to free unreferenced scalar: SV 0x%"UVxf
5948                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5949 #endif
5950         }
5951 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5952         abort();
5953 #endif
5954         return;
5955     }
5956     if (--(SvREFCNT(sv)) > 0)
5957         return;
5958     Perl_sv_free2(aTHX_ sv);
5959 }
5960
5961 void
5962 Perl_sv_free2(pTHX_ SV *const sv)
5963 {
5964     dVAR;
5965
5966     PERL_ARGS_ASSERT_SV_FREE2;
5967
5968 #ifdef DEBUGGING
5969     if (SvTEMP(sv)) {
5970         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
5971                          "Attempt to free temp prematurely: SV 0x%"UVxf
5972                          pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5973         return;
5974     }
5975 #endif
5976     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5977         /* make sure SvREFCNT(sv)==0 happens very seldom */
5978         SvREFCNT(sv) = (~(U32)0)/2;
5979         return;
5980     }
5981     sv_clear(sv);
5982     if (! SvREFCNT(sv))
5983         del_SV(sv);
5984 }
5985
5986 /*
5987 =for apidoc sv_len
5988
5989 Returns the length of the string in the SV. Handles magic and type
5990 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5991
5992 =cut
5993 */
5994
5995 STRLEN
5996 Perl_sv_len(pTHX_ register SV *const sv)
5997 {
5998     STRLEN len;
5999
6000     if (!sv)
6001         return 0;
6002
6003     if (SvGMAGICAL(sv))
6004         len = mg_length(sv);
6005     else
6006         (void)SvPV_const(sv, len);
6007     return len;
6008 }
6009
6010 /*
6011 =for apidoc sv_len_utf8
6012
6013 Returns the number of characters in the string in an SV, counting wide
6014 UTF-8 bytes as a single character. Handles magic and type coercion.
6015
6016 =cut
6017 */
6018
6019 /*
6020  * The length is cached in PERL_MAGIC_utf8, in the mg_len field.  Also the
6021  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6022  * (Note that the mg_len is not the length of the mg_ptr field.
6023  * This allows the cache to store the character length of the string without
6024  * needing to malloc() extra storage to attach to the mg_ptr.)
6025  *
6026  */
6027
6028 STRLEN
6029 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6030 {
6031     if (!sv)
6032         return 0;
6033
6034     if (SvGMAGICAL(sv))
6035         return mg_length(sv);
6036     else
6037     {
6038         STRLEN len;
6039         const U8 *s = (U8*)SvPV_const(sv, len);
6040
6041         if (PL_utf8cache) {
6042             STRLEN ulen;
6043             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6044
6045             if (mg && mg->mg_len != -1) {
6046                 ulen = mg->mg_len;
6047                 if (PL_utf8cache < 0) {
6048                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6049                     if (real != ulen) {
6050                         /* Need to turn the assertions off otherwise we may
6051                            recurse infinitely while printing error messages.
6052                         */
6053                         SAVEI8(PL_utf8cache);
6054                         PL_utf8cache = 0;
6055                         Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
6056                                    " real %"UVuf" for %"SVf,
6057                                    (UV) ulen, (UV) real, SVfARG(sv));
6058                     }
6059                 }
6060             }
6061             else {
6062                 ulen = Perl_utf8_length(aTHX_ s, s + len);
6063                 if (!SvREADONLY(sv)) {
6064                     if (!mg && (SvTYPE(sv) < SVt_PVMG ||
6065                                 !(mg = mg_find(sv, PERL_MAGIC_utf8)))) {
6066                         mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
6067                                          &PL_vtbl_utf8, 0, 0);
6068                     }
6069                     assert(mg);
6070                     mg->mg_len = ulen;
6071                     /* For now, treat "overflowed" as "still unknown".
6072                        See RT #72924.  */
6073                     if (ulen != (STRLEN) mg->mg_len)
6074                         mg->mg_len = -1;
6075                 }
6076             }
6077             return ulen;
6078         }
6079         return Perl_utf8_length(aTHX_ s, s + len);
6080     }
6081 }
6082
6083 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6084    offset.  */
6085 static STRLEN
6086 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6087                       STRLEN uoffset)
6088 {
6089     const U8 *s = start;
6090
6091     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6092
6093     while (s < send && uoffset--)
6094         s += UTF8SKIP(s);
6095     if (s > send) {
6096         /* This is the existing behaviour. Possibly it should be a croak, as
6097            it's actually a bounds error  */
6098         s = send;
6099     }
6100     return s - start;
6101 }
6102
6103 /* Given the length of the string in both bytes and UTF-8 characters, decide
6104    whether to walk forwards or backwards to find the byte corresponding to
6105    the passed in UTF-8 offset.  */
6106 static STRLEN
6107 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6108                       const STRLEN uoffset, const STRLEN uend)
6109 {
6110     STRLEN backw = uend - uoffset;
6111
6112     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6113
6114     if (uoffset < 2 * backw) {
6115         /* The assumption is that going forwards is twice the speed of going
6116            forward (that's where the 2 * backw comes from).
6117            (The real figure of course depends on the UTF-8 data.)  */
6118         return sv_pos_u2b_forwards(start, send, uoffset);
6119     }
6120
6121     while (backw--) {
6122         send--;
6123         while (UTF8_IS_CONTINUATION(*send))
6124             send--;
6125     }
6126     return send - start;
6127 }
6128
6129 /* For the string representation of the given scalar, find the byte
6130    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
6131    give another position in the string, *before* the sought offset, which
6132    (which is always true, as 0, 0 is a valid pair of positions), which should
6133    help reduce the amount of linear searching.
6134    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6135    will be used to reduce the amount of linear searching. The cache will be
6136    created if necessary, and the found value offered to it for update.  */
6137 static STRLEN
6138 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6139                     const U8 *const send, const STRLEN uoffset,
6140                     STRLEN uoffset0, STRLEN boffset0)
6141 {
6142     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
6143     bool found = FALSE;
6144
6145     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6146
6147     assert (uoffset >= uoffset0);
6148
6149     if (!SvREADONLY(sv)
6150         && PL_utf8cache
6151         && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6152                      (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6153         if ((*mgp)->mg_ptr) {
6154             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6155             if (cache[0] == uoffset) {
6156                 /* An exact match. */
6157                 return cache[1];
6158             }
6159             if (cache[2] == uoffset) {
6160                 /* An exact match. */
6161                 return cache[3];
6162             }
6163
6164             if (cache[0] < uoffset) {
6165                 /* The cache already knows part of the way.   */
6166                 if (cache[0] > uoffset0) {
6167                     /* The cache knows more than the passed in pair  */
6168                     uoffset0 = cache[0];
6169                     boffset0 = cache[1];
6170                 }
6171                 if ((*mgp)->mg_len != -1) {
6172                     /* And we know the end too.  */
6173                     boffset = boffset0
6174                         + sv_pos_u2b_midway(start + boffset0, send,
6175                                               uoffset - uoffset0,
6176                                               (*mgp)->mg_len - uoffset0);
6177                 } else {
6178                     boffset = boffset0
6179                         + sv_pos_u2b_forwards(start + boffset0,
6180                                                 send, uoffset - uoffset0);
6181                 }
6182             }
6183             else if (cache[2] < uoffset) {
6184                 /* We're between the two cache entries.  */
6185                 if (cache[2] > uoffset0) {
6186                     /* and the cache knows more than the passed in pair  */
6187                     uoffset0 = cache[2];
6188                     boffset0 = cache[3];
6189                 }
6190
6191                 boffset = boffset0
6192                     + sv_pos_u2b_midway(start + boffset0,
6193                                           start + cache[1],
6194                                           uoffset - uoffset0,
6195                                           cache[0] - uoffset0);
6196             } else {
6197                 boffset = boffset0
6198                     + sv_pos_u2b_midway(start + boffset0,
6199                                           start + cache[3],
6200                                           uoffset - uoffset0,
6201                                           cache[2] - uoffset0);
6202             }
6203             found = TRUE;
6204         }
6205         else if ((*mgp)->mg_len != -1) {
6206             /* If we can take advantage of a passed in offset, do so.  */
6207             /* In fact, offset0 is either 0, or less than offset, so don't
6208                need to worry about the other possibility.  */
6209             boffset = boffset0
6210                 + sv_pos_u2b_midway(start + boffset0, send,
6211                                       uoffset - uoffset0,
6212                                       (*mgp)->mg_len - uoffset0);
6213             found = TRUE;
6214         }
6215     }
6216
6217     if (!found || PL_utf8cache < 0) {
6218         const STRLEN real_boffset
6219             = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6220                                                send, uoffset - uoffset0);
6221
6222         if (found && PL_utf8cache < 0) {
6223             if (real_boffset != boffset) {
6224                 /* Need to turn the assertions off otherwise we may recurse
6225                    infinitely while printing error messages.  */
6226                 SAVEI8(PL_utf8cache);
6227                 PL_utf8cache = 0;
6228                 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
6229                            " real %"UVuf" for %"SVf,
6230                            (UV) boffset, (UV) real_boffset, SVfARG(sv));
6231             }
6232         }
6233         boffset = real_boffset;
6234     }
6235
6236     if (PL_utf8cache)
6237         utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6238     return boffset;
6239 }
6240
6241
6242 /*
6243 =for apidoc sv_pos_u2b_flags
6244
6245 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6246 the start of the string, to a count of the equivalent number of bytes; if
6247 lenp is non-zero, it does the same to lenp, but this time starting from
6248 the offset, rather than from the start of the string. Handles type coercion.
6249 I<flags> is passed to C<SvPV_flags>, and usually should be
6250 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6251
6252 =cut
6253 */
6254
6255 /*
6256  * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6257  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6258  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6259  *
6260  */
6261
6262 STRLEN
6263 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6264                       U32 flags)
6265 {
6266     const U8 *start;
6267     STRLEN len;
6268     STRLEN boffset;
6269
6270     PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6271
6272     start = (U8*)SvPV_flags(sv, len, flags);
6273     if (len) {
6274         const U8 * const send = start + len;
6275         MAGIC *mg = NULL;
6276         boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6277
6278         if (lenp) {
6279             /* Convert the relative offset to absolute.  */
6280             const STRLEN uoffset2 = uoffset + *lenp;
6281             const STRLEN boffset2
6282                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6283                                       uoffset, boffset) - boffset;
6284
6285             *lenp = boffset2;
6286         }
6287     } else {
6288         if (lenp)
6289             *lenp = 0;
6290         boffset = 0;
6291     }
6292
6293     return boffset;
6294 }
6295
6296 /*
6297 =for apidoc sv_pos_u2b
6298
6299 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6300 the start of the string, to a count of the equivalent number of bytes; if
6301 lenp is non-zero, it does the same to lenp, but this time starting from
6302 the offset, rather than from the start of the string. Handles magic and
6303 type coercion.
6304
6305 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6306 than 2Gb.
6307
6308 =cut
6309 */
6310
6311 /*
6312  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6313  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6314  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6315  *
6316  */
6317
6318 /* This function is subject to size and sign problems */
6319
6320 void
6321 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6322 {
6323     PERL_ARGS_ASSERT_SV_POS_U2B;
6324
6325     if (lenp) {
6326         STRLEN ulen = (STRLEN)*lenp;
6327         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6328                                          SV_GMAGIC|SV_CONST_RETURN);
6329         *lenp = (I32)ulen;
6330     } else {
6331         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6332                                          SV_GMAGIC|SV_CONST_RETURN);
6333     }
6334 }
6335
6336 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6337    byte length pairing. The (byte) length of the total SV is passed in too,
6338    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6339    may not have updated SvCUR, so we can't rely on reading it directly.
6340
6341    The proffered utf8/byte length pairing isn't used if the cache already has
6342    two pairs, and swapping either for the proffered pair would increase the
6343    RMS of the intervals between known byte offsets.
6344
6345    The cache itself consists of 4 STRLEN values
6346    0: larger UTF-8 offset
6347    1: corresponding byte offset
6348    2: smaller UTF-8 offset
6349    3: corresponding byte offset
6350
6351    Unused cache pairs have the value 0, 0.
6352    Keeping the cache "backwards" means that the invariant of
6353    cache[0] >= cache[2] is maintained even with empty slots, which means that
6354    the code that uses it doesn't need to worry if only 1 entry has actually
6355    been set to non-zero.  It also makes the "position beyond the end of the
6356    cache" logic much simpler, as the first slot is always the one to start
6357    from.
6358 */
6359 static void
6360 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6361                            const STRLEN utf8, const STRLEN blen)
6362 {
6363     STRLEN *cache;
6364
6365     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6366
6367     if (SvREADONLY(sv))
6368         return;
6369
6370     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6371                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6372         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6373                            0);
6374         (*mgp)->mg_len = -1;
6375     }
6376     assert(*mgp);
6377
6378     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6379         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6380         (*mgp)->mg_ptr = (char *) cache;
6381     }
6382     assert(cache);
6383
6384     if (PL_utf8cache < 0 && SvPOKp(sv)) {
6385         /* SvPOKp() because it's possible that sv has string overloading, and
6386            therefore is a reference, hence SvPVX() is actually a pointer.
6387            This cures the (very real) symptoms of RT 69422, but I'm not actually
6388            sure whether we should even be caching the results of UTF-8
6389            operations on overloading, given that nothing stops overloading
6390            returning a different value every time it's called.  */
6391         const U8 *start = (const U8 *) SvPVX_const(sv);
6392         const STRLEN realutf8 = utf8_length(start, start + byte);
6393
6394         if (realutf8 != utf8) {
6395             /* Need to turn the assertions off otherwise we may recurse
6396                infinitely while printing error messages.  */
6397             SAVEI8(PL_utf8cache);
6398             PL_utf8cache = 0;
6399             Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6400                        " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6401         }
6402     }
6403
6404     /* Cache is held with the later position first, to simplify the code
6405        that deals with unbounded ends.  */
6406
6407     ASSERT_UTF8_CACHE(cache);
6408     if (cache[1] == 0) {
6409         /* Cache is totally empty  */
6410         cache[0] = utf8;
6411         cache[1] = byte;
6412     } else if (cache[3] == 0) {
6413         if (byte > cache[1]) {
6414             /* New one is larger, so goes first.  */
6415             cache[2] = cache[0];
6416             cache[3] = cache[1];
6417             cache[0] = utf8;
6418             cache[1] = byte;
6419         } else {
6420             cache[2] = utf8;
6421             cache[3] = byte;
6422         }
6423     } else {
6424 #define THREEWAY_SQUARE(a,b,c,d) \
6425             ((float)((d) - (c))) * ((float)((d) - (c))) \
6426             + ((float)((c) - (b))) * ((float)((c) - (b))) \
6427                + ((float)((b) - (a))) * ((float)((b) - (a)))
6428
6429         /* Cache has 2 slots in use, and we know three potential pairs.
6430            Keep the two that give the lowest RMS distance. Do the
6431            calcualation in bytes simply because we always know the byte
6432            length.  squareroot has the same ordering as the positive value,
6433            so don't bother with the actual square root.  */
6434         const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6435         if (byte > cache[1]) {
6436             /* New position is after the existing pair of pairs.  */
6437             const float keep_earlier
6438                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6439             const float keep_later
6440                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6441
6442             if (keep_later < keep_earlier) {
6443                 if (keep_later < existing) {
6444                     cache[2] = cache[0];
6445                     cache[3] = cache[1];
6446                     cache[0] = utf8;
6447                     cache[1] = byte;
6448                 }
6449             }
6450             else {
6451                 if (keep_earlier < existing) {
6452                     cache[0] = utf8;
6453                     cache[1] = byte;
6454                 }
6455             }
6456         }
6457         else if (byte > cache[3]) {
6458             /* New position is between the existing pair of pairs.  */
6459             const float keep_earlier
6460                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6461             const float keep_later
6462                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6463
6464             if (keep_later < keep_earlier) {
6465                 if (keep_later < existing) {
6466                     cache[2] = utf8;
6467                     cache[3] = byte;
6468                 }
6469             }
6470             else {
6471                 if (keep_earlier < existing) {
6472                     cache[0] = utf8;
6473                     cache[1] = byte;
6474                 }
6475             }
6476         }
6477         else {
6478             /* New position is before the existing pair of pairs.  */
6479             const float keep_earlier
6480                 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6481             const float keep_later
6482                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6483
6484             if (keep_later < keep_earlier) {
6485                 if (keep_later < existing) {
6486                     cache[2] = utf8;
6487                     cache[3] = byte;
6488                 }
6489             }
6490             else {
6491                 if (keep_earlier < existing) {
6492                     cache[0] = cache[2];
6493                     cache[1] = cache[3];
6494                     cache[2] = utf8;
6495                     cache[3] = byte;
6496                 }
6497             }
6498         }
6499     }
6500     ASSERT_UTF8_CACHE(cache);
6501 }
6502
6503 /* We already know all of the way, now we may be able to walk back.  The same
6504    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6505    backward is half the speed of walking forward. */
6506 static STRLEN
6507 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6508                     const U8 *end, STRLEN endu)
6509 {
6510     const STRLEN forw = target - s;
6511     STRLEN backw = end - target;
6512
6513     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6514
6515     if (forw < 2 * backw) {
6516         return utf8_length(s, target);
6517     }
6518
6519     while (end > target) {
6520         end--;
6521         while (UTF8_IS_CONTINUATION(*end)) {
6522             end--;
6523         }
6524         endu--;
6525     }
6526     return endu;
6527 }
6528
6529 /*
6530 =for apidoc sv_pos_b2u
6531
6532 Converts the value pointed to by offsetp from a count of bytes from the
6533 start of the string, to a count of the equivalent number of UTF-8 chars.
6534 Handles magic and type coercion.
6535
6536 =cut
6537 */
6538
6539 /*
6540  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6541  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6542  * byte offsets.
6543  *
6544  */
6545 void
6546 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6547 {
6548     const U8* s;
6549     const STRLEN byte = *offsetp;
6550     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
6551     STRLEN blen;
6552     MAGIC* mg = NULL;
6553     const U8* send;
6554     bool found = FALSE;
6555
6556     PERL_ARGS_ASSERT_SV_POS_B2U;
6557
6558     if (!sv)
6559         return;
6560
6561     s = (const U8*)SvPV_const(sv, blen);
6562
6563     if (blen < byte)
6564         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6565
6566     send = s + byte;
6567
6568     if (!SvREADONLY(sv)
6569         && PL_utf8cache
6570         && SvTYPE(sv) >= SVt_PVMG
6571         && (mg = mg_find(sv, PERL_MAGIC_utf8)))
6572     {
6573         if (mg->mg_ptr) {
6574             STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6575             if (cache[1] == byte) {
6576                 /* An exact match. */
6577                 *offsetp = cache[0];
6578                 return;
6579             }
6580             if (cache[3] == byte) {
6581                 /* An exact match. */
6582                 *offsetp = cache[2];
6583                 return;
6584             }
6585
6586             if (cache[1] < byte) {
6587                 /* We already know part of the way. */
6588                 if (mg->mg_len != -1) {
6589                     /* Actually, we know the end too.  */
6590                     len = cache[0]
6591                         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6592                                               s + blen, mg->mg_len - cache[0]);
6593                 } else {
6594                     len = cache[0] + utf8_length(s + cache[1], send);
6595                 }
6596             }
6597             else if (cache[3] < byte) {
6598                 /* We're between the two cached pairs, so we do the calculation
6599                    offset by the byte/utf-8 positions for the earlier pair,
6600                    then add the utf-8 characters from the string start to
6601                    there.  */
6602                 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6603                                           s + cache[1], cache[0] - cache[2])
6604                     + cache[2];
6605
6606             }
6607             else { /* cache[3] > byte */
6608                 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6609                                           cache[2]);
6610
6611             }
6612             ASSERT_UTF8_CACHE(cache);
6613             found = TRUE;
6614         } else if (mg->mg_len != -1) {
6615             len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6616             found = TRUE;
6617         }
6618     }
6619     if (!found || PL_utf8cache < 0) {
6620         const STRLEN real_len = utf8_length(s, send);
6621
6622         if (found && PL_utf8cache < 0) {
6623             if (len != real_len) {
6624                 /* Need to turn the assertions off otherwise we may recurse
6625                    infinitely while printing error messages.  */
6626                 SAVEI8(PL_utf8cache);
6627                 PL_utf8cache = 0;
6628                 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6629                            " real %"UVuf" for %"SVf,
6630                            (UV) len, (UV) real_len, SVfARG(sv));
6631             }
6632         }
6633         len = real_len;
6634     }
6635     *offsetp = len;
6636
6637     if (PL_utf8cache)
6638         utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6639 }
6640
6641 /*
6642 =for apidoc sv_eq
6643
6644 Returns a boolean indicating whether the strings in the two SVs are
6645 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6646 coerce its args to strings if necessary.
6647
6648 =cut
6649 */
6650
6651 I32
6652 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6653 {
6654     dVAR;
6655     const char *pv1;
6656     STRLEN cur1;
6657     const char *pv2;
6658     STRLEN cur2;
6659     I32  eq     = 0;
6660     char *tpv   = NULL;
6661     SV* svrecode = NULL;
6662
6663     if (!sv1) {
6664         pv1 = "";
6665         cur1 = 0;
6666     }
6667     else {
6668         /* if pv1 and pv2 are the same, second SvPV_const call may
6669          * invalidate pv1, so we may need to make a copy */
6670         if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6671             pv1 = SvPV_const(sv1, cur1);
6672             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6673         }
6674         pv1 = SvPV_const(sv1, cur1);
6675     }
6676
6677     if (!sv2){
6678         pv2 = "";
6679         cur2 = 0;
6680     }
6681     else
6682         pv2 = SvPV_const(sv2, cur2);
6683
6684     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6685         /* Differing utf8ness.
6686          * Do not UTF8size the comparands as a side-effect. */
6687          if (PL_encoding) {
6688               if (SvUTF8(sv1)) {
6689                    svrecode = newSVpvn(pv2, cur2);
6690                    sv_recode_to_utf8(svrecode, PL_encoding);
6691                    pv2 = SvPV_const(svrecode, cur2);
6692               }
6693               else {
6694                    svrecode = newSVpvn(pv1, cur1);
6695                    sv_recode_to_utf8(svrecode, PL_encoding);
6696                    pv1 = SvPV_const(svrecode, cur1);
6697               }
6698               /* Now both are in UTF-8. */
6699               if (cur1 != cur2) {
6700                    SvREFCNT_dec(svrecode);
6701                    return FALSE;
6702               }
6703          }
6704          else {
6705               bool is_utf8 = TRUE;
6706
6707               if (SvUTF8(sv1)) {
6708                    /* sv1 is the UTF-8 one,
6709                     * if is equal it must be downgrade-able */
6710                    char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6711                                                      &cur1, &is_utf8);
6712                    if (pv != pv1)
6713                         pv1 = tpv = pv;
6714               }
6715               else {
6716                    /* sv2 is the UTF-8 one,
6717                     * if is equal it must be downgrade-able */
6718                    char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6719                                                       &cur2, &is_utf8);
6720                    if (pv != pv2)
6721                         pv2 = tpv = pv;
6722               }
6723               if (is_utf8) {
6724                    /* Downgrade not possible - cannot be eq */
6725                    assert (tpv == 0);
6726                    return FALSE;
6727               }
6728          }
6729     }
6730
6731     if (cur1 == cur2)
6732         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6733
6734     SvREFCNT_dec(svrecode);
6735     if (tpv)
6736         Safefree(tpv);
6737
6738     return eq;
6739 }
6740
6741 /*
6742 =for apidoc sv_cmp
6743
6744 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
6745 string in C<sv1> is less than, equal to, or greater than the string in
6746 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6747 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
6748
6749 =cut
6750 */
6751
6752 I32
6753 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6754 {
6755     dVAR;
6756     STRLEN cur1, cur2;
6757     const char *pv1, *pv2;
6758     char *tpv = NULL;
6759     I32  cmp;
6760     SV *svrecode = NULL;
6761
6762     if (!sv1) {
6763         pv1 = "";
6764         cur1 = 0;
6765     }
6766     else
6767         pv1 = SvPV_const(sv1, cur1);
6768
6769     if (!sv2) {
6770         pv2 = "";
6771         cur2 = 0;
6772     }
6773     else
6774         pv2 = SvPV_const(sv2, cur2);
6775
6776     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6777         /* Differing utf8ness.
6778          * Do not UTF8size the comparands as a side-effect. */
6779         if (SvUTF8(sv1)) {
6780             if (PL_encoding) {
6781                  svrecode = newSVpvn(pv2, cur2);
6782                  sv_recode_to_utf8(svrecode, PL_encoding);
6783                  pv2 = SvPV_const(svrecode, cur2);
6784             }
6785             else {
6786                  pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6787             }
6788         }
6789         else {
6790             if (PL_encoding) {
6791                  svrecode = newSVpvn(pv1, cur1);
6792                  sv_recode_to_utf8(svrecode, PL_encoding);
6793                  pv1 = SvPV_const(svrecode, cur1);
6794             }
6795             else {
6796                  pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6797             }
6798         }
6799     }
6800
6801     if (!cur1) {
6802         cmp = cur2 ? -1 : 0;
6803     } else if (!cur2) {
6804         cmp = 1;
6805     } else {
6806         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6807
6808         if (retval) {
6809             cmp = retval < 0 ? -1 : 1;
6810         } else if (cur1 == cur2) {
6811             cmp = 0;
6812         } else {
6813             cmp = cur1 < cur2 ? -1 : 1;
6814         }
6815     }
6816
6817     SvREFCNT_dec(svrecode);
6818     if (tpv)
6819         Safefree(tpv);
6820
6821     return cmp;
6822 }
6823
6824 /*
6825 =for apidoc sv_cmp_locale
6826
6827 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6828 'use bytes' aware, handles get magic, and will coerce its args to strings
6829 if necessary.  See also C<sv_cmp>.
6830
6831 =cut
6832 */
6833
6834 I32
6835 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6836 {
6837     dVAR;
6838 #ifdef USE_LOCALE_COLLATE
6839
6840     char *pv1, *pv2;
6841     STRLEN len1, len2;
6842     I32 retval;
6843
6844     if (PL_collation_standard)
6845         goto raw_compare;
6846
6847     len1 = 0;
6848     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6849     len2 = 0;
6850     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6851
6852     if (!pv1 || !len1) {
6853         if (pv2 && len2)
6854             return -1;
6855         else
6856             goto raw_compare;
6857     }
6858     else {
6859         if (!pv2 || !len2)
6860             return 1;
6861     }
6862
6863     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6864
6865     if (retval)
6866         return retval < 0 ? -1 : 1;
6867
6868     /*
6869      * When the result of collation is equality, that doesn't mean
6870      * that there are no differences -- some locales exclude some
6871      * characters from consideration.  So to avoid false equalities,
6872      * we use the raw string as a tiebreaker.
6873      */
6874
6875   raw_compare:
6876     /*FALLTHROUGH*/
6877
6878 #endif /* USE_LOCALE_COLLATE */
6879
6880     return sv_cmp(sv1, sv2);
6881 }
6882
6883
6884 #ifdef USE_LOCALE_COLLATE
6885
6886 /*
6887 =for apidoc sv_collxfrm
6888
6889 Add Collate Transform magic to an SV if it doesn't already have it.
6890
6891 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6892 scalar data of the variable, but transformed to such a format that a normal
6893 memory comparison can be used to compare the data according to the locale
6894 settings.
6895
6896 =cut
6897 */
6898
6899 char *
6900 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6901 {
6902     dVAR;
6903     MAGIC *mg;
6904
6905     PERL_ARGS_ASSERT_SV_COLLXFRM;
6906
6907     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6908     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6909         const char *s;
6910         char *xf;
6911         STRLEN len, xlen;
6912
6913         if (mg)
6914             Safefree(mg->mg_ptr);
6915         s = SvPV_const(sv, len);
6916         if ((xf = mem_collxfrm(s, len, &xlen))) {
6917             if (! mg) {
6918 #ifdef PERL_OLD_COPY_ON_WRITE
6919                 if (SvIsCOW(sv))
6920                     sv_force_normal_flags(sv, 0);
6921 #endif
6922                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6923                                  0, 0);
6924                 assert(mg);
6925             }
6926             mg->mg_ptr = xf;
6927             mg->mg_len = xlen;
6928         }
6929         else {
6930             if (mg) {
6931                 mg->mg_ptr = NULL;
6932                 mg->mg_len = -1;
6933             }
6934         }
6935     }
6936     if (mg && mg->mg_ptr) {
6937         *nxp = mg->mg_len;
6938         return mg->mg_ptr + sizeof(PL_collation_ix);
6939     }
6940     else {
6941         *nxp = 0;
6942         return NULL;
6943     }
6944 }
6945
6946 #endif /* USE_LOCALE_COLLATE */
6947
6948 /*
6949 =for apidoc sv_gets
6950
6951 Get a line from the filehandle and store it into the SV, optionally
6952 appending to the currently-stored string.
6953
6954 =cut
6955 */
6956
6957 char *
6958 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6959 {
6960     dVAR;
6961     const char *rsptr;
6962     STRLEN rslen;
6963     register STDCHAR rslast;
6964     register STDCHAR *bp;
6965     register I32 cnt;
6966     I32 i = 0;
6967     I32 rspara = 0;
6968
6969     PERL_ARGS_ASSERT_SV_GETS;
6970
6971     if (SvTHINKFIRST(sv))
6972         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6973     /* XXX. If you make this PVIV, then copy on write can copy scalars read
6974        from <>.
6975        However, perlbench says it's slower, because the existing swipe code
6976        is faster than copy on write.
6977        Swings and roundabouts.  */
6978     SvUPGRADE(sv, SVt_PV);
6979
6980     SvSCREAM_off(sv);
6981
6982     if (append) {
6983         if (PerlIO_isutf8(fp)) {
6984             if (!SvUTF8(sv)) {
6985                 sv_utf8_upgrade_nomg(sv);
6986                 sv_pos_u2b(sv,&append,0);
6987             }
6988         } else if (SvUTF8(sv)) {
6989             SV * const tsv = newSV(0);
6990             sv_gets(tsv, fp, 0);
6991             sv_utf8_upgrade_nomg(tsv);
6992             SvCUR_set(sv,append);
6993             sv_catsv(sv,tsv);
6994             sv_free(tsv);
6995             goto return_string_or_null;
6996         }
6997     }
6998
6999     SvPOK_only(sv);
7000     if (PerlIO_isutf8(fp))
7001         SvUTF8_on(sv);
7002
7003     if (IN_PERL_COMPILETIME) {
7004         /* we always read code in line mode */
7005         rsptr = "\n";
7006         rslen = 1;
7007     }
7008     else if (RsSNARF(PL_rs)) {
7009         /* If it is a regular disk file use size from stat() as estimate
7010            of amount we are going to read -- may result in mallocing
7011            more memory than we really need if the layers below reduce
7012            the size we read (e.g. CRLF or a gzip layer).
7013          */
7014         Stat_t st;
7015         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
7016             const Off_t offset = PerlIO_tell(fp);
7017             if (offset != (Off_t) -1 && st.st_size + append > offset) {
7018                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7019             }
7020         }
7021         rsptr = NULL;
7022         rslen = 0;
7023     }
7024     else if (RsRECORD(PL_rs)) {
7025       I32 bytesread;
7026       char *buffer;
7027       U32 recsize;
7028 #ifdef VMS
7029       int fd;
7030 #endif
7031
7032       /* Grab the size of the record we're getting */
7033       recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7034       buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7035       /* Go yank in */
7036 #ifdef VMS
7037       /* VMS wants read instead of fread, because fread doesn't respect */
7038       /* RMS record boundaries. This is not necessarily a good thing to be */
7039       /* doing, but we've got no other real choice - except avoid stdio
7040          as implementation - perhaps write a :vms layer ?
7041        */
7042       fd = PerlIO_fileno(fp);
7043       if (fd == -1) { /* in-memory file from PerlIO::Scalar */
7044           bytesread = PerlIO_read(fp, buffer, recsize);
7045       }
7046       else {
7047           bytesread = PerlLIO_read(fd, buffer, recsize);
7048       }
7049 #else
7050       bytesread = PerlIO_read(fp, buffer, recsize);
7051 #endif
7052       if (bytesread < 0)
7053           bytesread = 0;
7054       SvCUR_set(sv, bytesread + append);
7055       buffer[bytesread] = '\0';
7056       goto return_string_or_null;
7057     }
7058     else if (RsPARA(PL_rs)) {
7059         rsptr = "\n\n";
7060         rslen = 2;
7061         rspara = 1;
7062     }
7063     else {
7064         /* Get $/ i.e. PL_rs into same encoding as stream wants */
7065         if (PerlIO_isutf8(fp)) {
7066             rsptr = SvPVutf8(PL_rs, rslen);
7067         }
7068         else {
7069             if (SvUTF8(PL_rs)) {
7070                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7071                     Perl_croak(aTHX_ "Wide character in $/");
7072                 }
7073             }
7074             rsptr = SvPV_const(PL_rs, rslen);
7075         }
7076     }
7077
7078     rslast = rslen ? rsptr[rslen - 1] : '\0';
7079
7080     if (rspara) {               /* have to do this both before and after */
7081         do {                    /* to make sure file boundaries work right */
7082             if (PerlIO_eof(fp))
7083                 return 0;
7084             i = PerlIO_getc(fp);
7085             if (i != '\n') {
7086                 if (i == -1)
7087                     return 0;
7088                 PerlIO_ungetc(fp,i);
7089                 break;
7090             }
7091         } while (i != EOF);
7092     }
7093
7094     /* See if we know enough about I/O mechanism to cheat it ! */
7095
7096     /* This used to be #ifdef test - it is made run-time test for ease
7097        of abstracting out stdio interface. One call should be cheap
7098        enough here - and may even be a macro allowing compile
7099        time optimization.
7100      */
7101
7102     if (PerlIO_fast_gets(fp)) {
7103
7104     /*
7105      * We're going to steal some values from the stdio struct
7106      * and put EVERYTHING in the innermost loop into registers.
7107      */
7108     register STDCHAR *ptr;
7109     STRLEN bpx;
7110     I32 shortbuffered;
7111
7112 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7113     /* An ungetc()d char is handled separately from the regular
7114      * buffer, so we getc() it back out and stuff it in the buffer.
7115      */
7116     i = PerlIO_getc(fp);
7117     if (i == EOF) return 0;
7118     *(--((*fp)->_ptr)) = (unsigned char) i;
7119     (*fp)->_cnt++;
7120 #endif
7121
7122     /* Here is some breathtakingly efficient cheating */
7123
7124     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
7125     /* make sure we have the room */
7126     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7127         /* Not room for all of it
7128            if we are looking for a separator and room for some
7129          */
7130         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7131             /* just process what we have room for */
7132             shortbuffered = cnt - SvLEN(sv) + append + 1;
7133             cnt -= shortbuffered;
7134         }
7135         else {
7136             shortbuffered = 0;
7137             /* remember that cnt can be negative */
7138             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7139         }
7140     }
7141     else
7142         shortbuffered = 0;
7143     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
7144     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7145     DEBUG_P(PerlIO_printf(Perl_debug_log,
7146         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7147     DEBUG_P(PerlIO_printf(Perl_debug_log,
7148         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7149                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7150                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7151     for (;;) {
7152       screamer:
7153         if (cnt > 0) {
7154             if (rslen) {
7155                 while (cnt > 0) {                    /* this     |  eat */
7156                     cnt--;
7157                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
7158                         goto thats_all_folks;        /* screams  |  sed :-) */
7159                 }
7160             }
7161             else {
7162                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
7163                 bp += cnt;                           /* screams  |  dust */
7164                 ptr += cnt;                          /* louder   |  sed :-) */
7165                 cnt = 0;
7166             }
7167         }
7168
7169         if (shortbuffered) {            /* oh well, must extend */
7170             cnt = shortbuffered;
7171             shortbuffered = 0;
7172             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7173             SvCUR_set(sv, bpx);
7174             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7175             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7176             continue;
7177         }
7178
7179         DEBUG_P(PerlIO_printf(Perl_debug_log,
7180                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7181                               PTR2UV(ptr),(long)cnt));
7182         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7183 #if 0
7184         DEBUG_P(PerlIO_printf(Perl_debug_log,
7185             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7186             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7187             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7188 #endif
7189         /* This used to call 'filbuf' in stdio form, but as that behaves like
7190            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7191            another abstraction.  */
7192         i   = PerlIO_getc(fp);          /* get more characters */
7193 #if 0
7194         DEBUG_P(PerlIO_printf(Perl_debug_log,
7195             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7196             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7197             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7198 #endif
7199         cnt = PerlIO_get_cnt(fp);
7200         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
7201         DEBUG_P(PerlIO_printf(Perl_debug_log,
7202             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7203
7204         if (i == EOF)                   /* all done for ever? */
7205             goto thats_really_all_folks;
7206
7207         bpx = bp - (STDCHAR*)SvPVX_const(sv);   /* box up before relocation */
7208         SvCUR_set(sv, bpx);
7209         SvGROW(sv, bpx + cnt + 2);
7210         bp = (STDCHAR*)SvPVX_const(sv) + bpx;   /* unbox after relocation */
7211
7212         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
7213
7214         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
7215             goto thats_all_folks;
7216     }
7217
7218 thats_all_folks:
7219     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7220           memNE((char*)bp - rslen, rsptr, rslen))
7221         goto screamer;                          /* go back to the fray */
7222 thats_really_all_folks:
7223     if (shortbuffered)
7224         cnt += shortbuffered;
7225         DEBUG_P(PerlIO_printf(Perl_debug_log,
7226             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7227     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
7228     DEBUG_P(PerlIO_printf(Perl_debug_log,
7229         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7230         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7231         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7232     *bp = '\0';
7233     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));      /* set length */
7234     DEBUG_P(PerlIO_printf(Perl_debug_log,
7235         "Screamer: done, len=%ld, string=|%.*s|\n",
7236         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7237     }
7238    else
7239     {
7240        /*The big, slow, and stupid way. */
7241 #ifdef USE_HEAP_INSTEAD_OF_STACK        /* Even slower way. */
7242         STDCHAR *buf = NULL;
7243         Newx(buf, 8192, STDCHAR);
7244         assert(buf);
7245 #else
7246         STDCHAR buf[8192];
7247 #endif
7248
7249 screamer2:
7250         if (rslen) {
7251             register const STDCHAR * const bpe = buf + sizeof(buf);
7252             bp = buf;
7253             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7254                 ; /* keep reading */
7255             cnt = bp - buf;
7256         }
7257         else {
7258             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7259             /* Accomodate broken VAXC compiler, which applies U8 cast to
7260              * both args of ?: operator, causing EOF to change into 255
7261              */
7262             if (cnt > 0)
7263                  i = (U8)buf[cnt - 1];
7264             else
7265                  i = EOF;
7266         }
7267
7268         if (cnt < 0)
7269             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
7270         if (append)
7271              sv_catpvn(sv, (char *) buf, cnt);
7272         else
7273              sv_setpvn(sv, (char *) buf, cnt);
7274
7275         if (i != EOF &&                 /* joy */
7276             (!rslen ||
7277              SvCUR(sv) < rslen ||
7278              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7279         {
7280             append = -1;
7281             /*
7282              * If we're reading from a TTY and we get a short read,
7283              * indicating that the user hit his EOF character, we need
7284              * to notice it now, because if we try to read from the TTY
7285              * again, the EOF condition will disappear.
7286              *
7287              * The comparison of cnt to sizeof(buf) is an optimization
7288              * that prevents unnecessary calls to feof().
7289              *
7290              * - jik 9/25/96
7291              */
7292             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7293                 goto screamer2;
7294         }
7295
7296 #ifdef USE_HEAP_INSTEAD_OF_STACK
7297         Safefree(buf);
7298 #endif
7299     }
7300
7301     if (rspara) {               /* have to do this both before and after */
7302         while (i != EOF) {      /* to make sure file boundaries work right */
7303             i = PerlIO_getc(fp);
7304             if (i != '\n') {
7305                 PerlIO_ungetc(fp,i);
7306                 break;
7307             }
7308         }
7309     }
7310
7311 return_string_or_null:
7312     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7313 }
7314
7315 /*
7316 =for apidoc sv_inc
7317
7318 Auto-increment of the value in the SV, doing string to numeric conversion
7319 if necessary. Handles 'get' magic and operator overloading.
7320
7321 =cut
7322 */
7323
7324 void
7325 Perl_sv_inc(pTHX_ register SV *const sv)
7326 {
7327     if (!sv)
7328         return;
7329     SvGETMAGIC(sv);
7330     sv_inc_nomg(sv);
7331 }
7332
7333 /*
7334 =for apidoc sv_inc_nomg
7335
7336 Auto-increment of the value in the SV, doing string to numeric conversion
7337 if necessary. Handles operator overloading. Skips handling 'get' magic.
7338
7339 =cut
7340 */
7341
7342 void
7343 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7344 {
7345     dVAR;
7346     register char *d;
7347     int flags;
7348
7349     if (!sv)
7350         return;
7351     if (SvTHINKFIRST(sv)) {
7352         if (SvIsCOW(sv))
7353             sv_force_normal_flags(sv, 0);
7354         if (SvREADONLY(sv)) {
7355             if (IN_PERL_RUNTIME)
7356                 Perl_croak(aTHX_ "%s", PL_no_modify);
7357         }
7358         if (SvROK(sv)) {
7359             IV i;
7360             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7361                 return;
7362             i = PTR2IV(SvRV(sv));
7363             sv_unref(sv);
7364             sv_setiv(sv, i);
7365         }
7366     }
7367     flags = SvFLAGS(sv);
7368     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7369         /* It's (privately or publicly) a float, but not tested as an
7370            integer, so test it to see. */
7371         (void) SvIV(sv);
7372         flags = SvFLAGS(sv);
7373     }
7374     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7375         /* It's publicly an integer, or privately an integer-not-float */
7376 #ifdef PERL_PRESERVE_IVUV
7377       oops_its_int:
7378 #endif
7379         if (SvIsUV(sv)) {
7380             if (SvUVX(sv) == UV_MAX)
7381                 sv_setnv(sv, UV_MAX_P1);
7382             else
7383                 (void)SvIOK_only_UV(sv);
7384                 SvUV_set(sv, SvUVX(sv) + 1);
7385         } else {
7386             if (SvIVX(sv) == IV_MAX)
7387                 sv_setuv(sv, (UV)IV_MAX + 1);
7388             else {
7389                 (void)SvIOK_only(sv);
7390                 SvIV_set(sv, SvIVX(sv) + 1);
7391             }
7392         }
7393         return;
7394     }
7395     if (flags & SVp_NOK) {
7396         const NV was = SvNVX(sv);
7397         if (NV_OVERFLOWS_INTEGERS_AT &&
7398             was >= NV_OVERFLOWS_INTEGERS_AT) {
7399             Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7400                            "Lost precision when incrementing %" NVff " by 1",
7401                            was);
7402         }
7403         (void)SvNOK_only(sv);
7404         SvNV_set(sv, was + 1.0);
7405         return;
7406     }
7407
7408     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7409         if ((flags & SVTYPEMASK) < SVt_PVIV)
7410             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7411         (void)SvIOK_only(sv);
7412         SvIV_set(sv, 1);
7413         return;
7414     }
7415     d = SvPVX(sv);
7416     while (isALPHA(*d)) d++;
7417     while (isDIGIT(*d)) d++;
7418     if (d < SvEND(sv)) {
7419 #ifdef PERL_PRESERVE_IVUV
7420         /* Got to punt this as an integer if needs be, but we don't issue
7421            warnings. Probably ought to make the sv_iv_please() that does
7422            the conversion if possible, and silently.  */
7423         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7424         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7425             /* Need to try really hard to see if it's an integer.
7426                9.22337203685478e+18 is an integer.
7427                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7428                so $a="9.22337203685478e+18"; $a+0; $a++
7429                needs to be the same as $a="9.22337203685478e+18"; $a++
7430                or we go insane. */
7431
7432             (void) sv_2iv(sv);
7433             if (SvIOK(sv))
7434                 goto oops_its_int;
7435
7436             /* sv_2iv *should* have made this an NV */
7437             if (flags & SVp_NOK) {
7438                 (void)SvNOK_only(sv);
7439                 SvNV_set(sv, SvNVX(sv) + 1.0);
7440                 return;
7441             }
7442             /* I don't think we can get here. Maybe I should assert this
7443                And if we do get here I suspect that sv_setnv will croak. NWC
7444                Fall through. */
7445 #if defined(USE_LONG_DOUBLE)
7446             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",
7447                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7448 #else
7449             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7450                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7451 #endif
7452         }
7453 #endif /* PERL_PRESERVE_IVUV */
7454         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7455         return;
7456     }
7457     d--;
7458     while (d >= SvPVX_const(sv)) {
7459         if (isDIGIT(*d)) {
7460             if (++*d <= '9')
7461                 return;
7462             *(d--) = '0';
7463         }
7464         else {
7465 #ifdef EBCDIC
7466             /* MKS: The original code here died if letters weren't consecutive.
7467              * at least it didn't have to worry about non-C locales.  The
7468              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7469              * arranged in order (although not consecutively) and that only
7470              * [A-Za-z] are accepted by isALPHA in the C locale.
7471              */
7472             if (*d != 'z' && *d != 'Z') {
7473                 do { ++*d; } while (!isALPHA(*d));
7474                 return;
7475             }
7476             *(d--) -= 'z' - 'a';
7477 #else
7478             ++*d;
7479             if (isALPHA(*d))
7480                 return;
7481             *(d--) -= 'z' - 'a' + 1;
7482 #endif
7483         }
7484     }
7485     /* oh,oh, the number grew */
7486     SvGROW(sv, SvCUR(sv) + 2);
7487     SvCUR_set(sv, SvCUR(sv) + 1);
7488     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7489         *d = d[-1];
7490     if (isDIGIT(d[1]))
7491         *d = '1';
7492     else
7493         *d = d[1];
7494 }
7495
7496 /*
7497 =for apidoc sv_dec
7498
7499 Auto-decrement of the value in the SV, doing string to numeric conversion
7500 if necessary. Handles 'get' magic and operator overloading.
7501
7502 =cut
7503 */
7504
7505 void
7506 Perl_sv_dec(pTHX_ register SV *const sv)
7507 {
7508     dVAR;
7509     if (!sv)
7510         return;
7511     SvGETMAGIC(sv);
7512     sv_dec_nomg(sv);
7513 }
7514
7515 /*
7516 =for apidoc sv_dec_nomg
7517
7518 Auto-decrement of the value in the SV, doing string to numeric conversion
7519 if necessary. Handles operator overloading. Skips handling 'get' magic.
7520
7521 =cut
7522 */
7523
7524 void
7525 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
7526 {
7527     dVAR;
7528     int flags;
7529
7530     if (!sv)
7531         return;
7532     if (SvTHINKFIRST(sv)) {
7533         if (SvIsCOW(sv))
7534             sv_force_normal_flags(sv, 0);
7535         if (SvREADONLY(sv)) {
7536             if (IN_PERL_RUNTIME)
7537                 Perl_croak(aTHX_ "%s", PL_no_modify);
7538         }
7539         if (SvROK(sv)) {
7540             IV i;
7541             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7542                 return;
7543             i = PTR2IV(SvRV(sv));
7544             sv_unref(sv);
7545             sv_setiv(sv, i);
7546         }
7547     }
7548     /* Unlike sv_inc we don't have to worry about string-never-numbers
7549        and keeping them magic. But we mustn't warn on punting */
7550     flags = SvFLAGS(sv);
7551     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7552         /* It's publicly an integer, or privately an integer-not-float */
7553 #ifdef PERL_PRESERVE_IVUV
7554       oops_its_int:
7555 #endif
7556         if (SvIsUV(sv)) {
7557             if (SvUVX(sv) == 0) {
7558                 (void)SvIOK_only(sv);
7559                 SvIV_set(sv, -1);
7560             }
7561             else {
7562                 (void)SvIOK_only_UV(sv);
7563                 SvUV_set(sv, SvUVX(sv) - 1);
7564             }
7565         } else {
7566             if (SvIVX(sv) == IV_MIN) {
7567                 sv_setnv(sv, (NV)IV_MIN);
7568                 goto oops_its_num;
7569             }
7570             else {
7571                 (void)SvIOK_only(sv);
7572                 SvIV_set(sv, SvIVX(sv) - 1);
7573             }
7574         }
7575         return;
7576     }
7577     if (flags & SVp_NOK) {
7578     oops_its_num:
7579         {
7580             const NV was = SvNVX(sv);
7581             if (NV_OVERFLOWS_INTEGERS_AT &&
7582                 was <= -NV_OVERFLOWS_INTEGERS_AT) {
7583                 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7584                                "Lost precision when decrementing %" NVff " by 1",
7585                                was);
7586             }
7587             (void)SvNOK_only(sv);
7588             SvNV_set(sv, was - 1.0);
7589             return;
7590         }
7591     }
7592     if (!(flags & SVp_POK)) {
7593         if ((flags & SVTYPEMASK) < SVt_PVIV)
7594             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7595         SvIV_set(sv, -1);
7596         (void)SvIOK_only(sv);
7597         return;
7598     }
7599 #ifdef PERL_PRESERVE_IVUV
7600     {
7601         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7602         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7603             /* Need to try really hard to see if it's an integer.
7604                9.22337203685478e+18 is an integer.
7605                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7606                so $a="9.22337203685478e+18"; $a+0; $a--
7607                needs to be the same as $a="9.22337203685478e+18"; $a--
7608                or we go insane. */
7609
7610             (void) sv_2iv(sv);
7611             if (SvIOK(sv))
7612                 goto oops_its_int;
7613
7614             /* sv_2iv *should* have made this an NV */
7615             if (flags & SVp_NOK) {
7616                 (void)SvNOK_only(sv);
7617                 SvNV_set(sv, SvNVX(sv) - 1.0);
7618                 return;
7619             }
7620             /* I don't think we can get here. Maybe I should assert this
7621                And if we do get here I suspect that sv_setnv will croak. NWC
7622                Fall through. */
7623 #if defined(USE_LONG_DOUBLE)
7624             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",
7625                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7626 #else
7627             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7628                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7629 #endif
7630         }
7631     }
7632 #endif /* PERL_PRESERVE_IVUV */
7633     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);   /* punt */
7634 }
7635
7636 /* this define is used to eliminate a chunk of duplicated but shared logic
7637  * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
7638  * used anywhere but here - yves
7639  */
7640 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
7641     STMT_START {      \
7642         EXTEND_MORTAL(1); \
7643         PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
7644     } STMT_END
7645
7646 /*
7647 =for apidoc sv_mortalcopy
7648
7649 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7650 The new SV is marked as mortal. It will be destroyed "soon", either by an
7651 explicit call to FREETMPS, or by an implicit call at places such as
7652 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
7653
7654 =cut
7655 */
7656
7657 /* Make a string that will exist for the duration of the expression
7658  * evaluation.  Actually, it may have to last longer than that, but
7659  * hopefully we won't free it until it has been assigned to a
7660  * permanent location. */
7661
7662 SV *
7663 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7664 {
7665     dVAR;
7666     register SV *sv;
7667
7668     new_SV(sv);
7669     sv_setsv(sv,oldstr);
7670     PUSH_EXTEND_MORTAL__SV_C(sv);
7671     SvTEMP_on(sv);
7672     return sv;
7673 }
7674
7675 /*
7676 =for apidoc sv_newmortal
7677
7678 Creates a new null SV which is mortal.  The reference count of the SV is
7679 set to 1. It will be destroyed "soon", either by an explicit call to
7680 FREETMPS, or by an implicit call at places such as statement boundaries.
7681 See also C<sv_mortalcopy> and C<sv_2mortal>.
7682
7683 =cut
7684 */
7685
7686 SV *
7687 Perl_sv_newmortal(pTHX)
7688 {
7689     dVAR;
7690     register SV *sv;
7691
7692     new_SV(sv);
7693     SvFLAGS(sv) = SVs_TEMP;
7694     PUSH_EXTEND_MORTAL__SV_C(sv);
7695     return sv;
7696 }
7697
7698
7699 /*
7700 =for apidoc newSVpvn_flags
7701
7702 Creates a new SV and copies a string into it.  The reference count for the
7703 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7704 string.  You are responsible for ensuring that the source string is at least
7705 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7706 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7707 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7708 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
7709 C<SVf_UTF8> flag will be set on the new SV.
7710 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7711
7712     #define newSVpvn_utf8(s, len, u)                    \
7713         newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7714
7715 =cut
7716 */
7717
7718 SV *
7719 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7720 {
7721     dVAR;
7722     register SV *sv;
7723
7724     /* All the flags we don't support must be zero.
7725        And we're new code so I'm going to assert this from the start.  */
7726     assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7727     new_SV(sv);
7728     sv_setpvn(sv,s,len);
7729
7730     /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
7731      * and do what it does outselves here.
7732      * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
7733      * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
7734      * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
7735      * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
7736      */
7737
7738     SvFLAGS(sv) |= flags;
7739
7740     if(flags & SVs_TEMP){
7741         PUSH_EXTEND_MORTAL__SV_C(sv);
7742     }
7743
7744     return sv;
7745 }
7746
7747 /*
7748 =for apidoc sv_2mortal
7749
7750 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
7751 by an explicit call to FREETMPS, or by an implicit call at places such as
7752 statement boundaries.  SvTEMP() is turned on which means that the SV's
7753 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7754 and C<sv_mortalcopy>.
7755
7756 =cut
7757 */
7758
7759 SV *
7760 Perl_sv_2mortal(pTHX_ register SV *const sv)
7761 {
7762     dVAR;
7763     if (!sv)
7764         return NULL;
7765     if (SvREADONLY(sv) && SvIMMORTAL(sv))
7766         return sv;
7767     PUSH_EXTEND_MORTAL__SV_C(sv);
7768     SvTEMP_on(sv);
7769     return sv;
7770 }
7771
7772 /*
7773 =for apidoc newSVpv
7774
7775 Creates a new SV and copies a string into it.  The reference count for the
7776 SV is set to 1.  If C<len> is zero, Perl will compute the length using
7777 strlen().  For efficiency, consider using C<newSVpvn> instead.
7778
7779 =cut
7780 */
7781
7782 SV *
7783 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7784 {
7785     dVAR;
7786     register SV *sv;
7787
7788     new_SV(sv);
7789     sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7790     return sv;
7791 }
7792
7793 /*
7794 =for apidoc newSVpvn
7795
7796 Creates a new SV and copies a string into it.  The reference count for the
7797 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7798 string.  You are responsible for ensuring that the source string is at least
7799 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7800
7801 =cut
7802 */
7803
7804 SV *
7805 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7806 {
7807     dVAR;
7808     register SV *sv;
7809
7810     new_SV(sv);
7811     sv_setpvn(sv,s,len);
7812     return sv;
7813 }
7814
7815 /*
7816 =for apidoc newSVhek
7817
7818 Creates a new SV from the hash key structure.  It will generate scalars that
7819 point to the shared string table where possible. Returns a new (undefined)
7820 SV if the hek is NULL.
7821
7822 =cut
7823 */
7824
7825 SV *
7826 Perl_newSVhek(pTHX_ const HEK *const hek)
7827 {
7828     dVAR;
7829     if (!hek) {
7830         SV *sv;
7831
7832         new_SV(sv);
7833         return sv;
7834     }
7835
7836     if (HEK_LEN(hek) == HEf_SVKEY) {
7837         return newSVsv(*(SV**)HEK_KEY(hek));
7838     } else {
7839         const int flags = HEK_FLAGS(hek);
7840         if (flags & HVhek_WASUTF8) {
7841             /* Trouble :-)
7842                Andreas would like keys he put in as utf8 to come back as utf8
7843             */
7844             STRLEN utf8_len = HEK_LEN(hek);
7845             const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7846             SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7847
7848             SvUTF8_on (sv);
7849             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7850             return sv;
7851         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7852             /* We don't have a pointer to the hv, so we have to replicate the
7853                flag into every HEK. This hv is using custom a hasing
7854                algorithm. Hence we can't return a shared string scalar, as
7855                that would contain the (wrong) hash value, and might get passed
7856                into an hv routine with a regular hash.
7857                Similarly, a hash that isn't using shared hash keys has to have
7858                the flag in every key so that we know not to try to call
7859                share_hek_kek on it.  */
7860
7861             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7862             if (HEK_UTF8(hek))
7863                 SvUTF8_on (sv);
7864             return sv;
7865         }
7866         /* This will be overwhelminly the most common case.  */
7867         {
7868             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7869                more efficient than sharepvn().  */
7870             SV *sv;
7871
7872             new_SV(sv);
7873             sv_upgrade(sv, SVt_PV);
7874             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7875             SvCUR_set(sv, HEK_LEN(hek));
7876             SvLEN_set(sv, 0);
7877             SvREADONLY_on(sv);
7878             SvFAKE_on(sv);
7879             SvPOK_on(sv);
7880             if (HEK_UTF8(hek))
7881                 SvUTF8_on(sv);
7882             return sv;
7883         }
7884     }
7885 }
7886
7887 /*
7888 =for apidoc newSVpvn_share
7889
7890 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7891 table. If the string does not already exist in the table, it is created
7892 first.  Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7893 value is used; otherwise the hash is computed. The string's hash can be later
7894 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7895 that as the string table is used for shared hash keys these strings will have
7896 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7897
7898 =cut
7899 */
7900
7901 SV *
7902 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7903 {
7904     dVAR;
7905     register SV *sv;
7906     bool is_utf8 = FALSE;
7907     const char *const orig_src = src;
7908
7909     if (len < 0) {
7910         STRLEN tmplen = -len;
7911         is_utf8 = TRUE;
7912         /* See the note in hv.c:hv_fetch() --jhi */
7913         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7914         len = tmplen;
7915     }
7916     if (!hash)
7917         PERL_HASH(hash, src, len);
7918     new_SV(sv);
7919     /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7920        changes here, update it there too.  */
7921     sv_upgrade(sv, SVt_PV);
7922     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7923     SvCUR_set(sv, len);
7924     SvLEN_set(sv, 0);
7925     SvREADONLY_on(sv);
7926     SvFAKE_on(sv);
7927     SvPOK_on(sv);
7928     if (is_utf8)
7929         SvUTF8_on(sv);
7930     if (src != orig_src)
7931         Safefree(src);
7932     return sv;
7933 }
7934
7935
7936 #if defined(PERL_IMPLICIT_CONTEXT)
7937
7938 /* pTHX_ magic can't cope with varargs, so this is a no-context
7939  * version of the main function, (which may itself be aliased to us).
7940  * Don't access this version directly.
7941  */
7942
7943 SV *
7944 Perl_newSVpvf_nocontext(const char *const pat, ...)
7945 {
7946     dTHX;
7947     register SV *sv;
7948     va_list args;
7949
7950     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7951
7952     va_start(args, pat);
7953     sv = vnewSVpvf(pat, &args);
7954     va_end(args);
7955     return sv;
7956 }
7957 #endif
7958
7959 /*
7960 =for apidoc newSVpvf
7961
7962 Creates a new SV and initializes it with the string formatted like
7963 C<sprintf>.
7964
7965 =cut
7966 */
7967
7968 SV *
7969 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7970 {
7971     register SV *sv;
7972     va_list args;
7973
7974     PERL_ARGS_ASSERT_NEWSVPVF;
7975
7976     va_start(args, pat);
7977     sv = vnewSVpvf(pat, &args);
7978     va_end(args);
7979     return sv;
7980 }
7981
7982 /* backend for newSVpvf() and newSVpvf_nocontext() */
7983
7984 SV *
7985 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7986 {
7987     dVAR;
7988     register SV *sv;
7989
7990     PERL_ARGS_ASSERT_VNEWSVPVF;
7991
7992     new_SV(sv);
7993     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7994     return sv;
7995 }
7996
7997 /*
7998 =for apidoc newSVnv
7999
8000 Creates a new SV and copies a floating point value into it.
8001 The reference count for the SV is set to 1.
8002
8003 =cut
8004 */
8005
8006 SV *
8007 Perl_newSVnv(pTHX_ const NV n)
8008 {
8009     dVAR;
8010     register SV *sv;
8011
8012     new_SV(sv);
8013     sv_setnv(sv,n);
8014     return sv;
8015 }
8016
8017 /*
8018 =for apidoc newSViv
8019
8020 Creates a new SV and copies an integer into it.  The reference count for the
8021 SV is set to 1.
8022
8023 =cut
8024 */
8025
8026 SV *
8027 Perl_newSViv(pTHX_ const IV i)
8028 {
8029     dVAR;
8030     register SV *sv;
8031
8032     new_SV(sv);
8033     sv_setiv(sv,i);
8034     return sv;
8035 }
8036
8037 /*
8038 =for apidoc newSVuv
8039
8040 Creates a new SV and copies an unsigned integer into it.
8041 The reference count for the SV is set to 1.
8042
8043 =cut
8044 */
8045
8046 SV *
8047 Perl_newSVuv(pTHX_ const UV u)
8048 {
8049     dVAR;
8050     register SV *sv;
8051
8052     new_SV(sv);
8053     sv_setuv(sv,u);
8054     return sv;
8055 }
8056
8057 /*
8058 =for apidoc newSV_type
8059
8060 Creates a new SV, of the type specified.  The reference count for the new SV
8061 is set to 1.
8062
8063 =cut
8064 */
8065
8066 SV *
8067 Perl_newSV_type(pTHX_ const svtype type)
8068 {
8069     register SV *sv;
8070
8071     new_SV(sv);
8072     sv_upgrade(sv, type);
8073     return sv;
8074 }
8075
8076 /*
8077 =for apidoc newRV_noinc
8078
8079 Creates an RV wrapper for an SV.  The reference count for the original
8080 SV is B<not> incremented.
8081
8082 =cut
8083 */
8084
8085 SV *
8086 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8087 {
8088     dVAR;
8089     register SV *sv = newSV_type(SVt_IV);
8090
8091     PERL_ARGS_ASSERT_NEWRV_NOINC;
8092
8093     SvTEMP_off(tmpRef);
8094     SvRV_set(sv, tmpRef);
8095     SvROK_on(sv);
8096     return sv;
8097 }
8098
8099 /* newRV_inc is the official function name to use now.
8100  * newRV_inc is in fact #defined to newRV in sv.h
8101  */
8102
8103 SV *
8104 Perl_newRV(pTHX_ SV *const sv)
8105 {
8106     dVAR;
8107
8108     PERL_ARGS_ASSERT_NEWRV;
8109
8110     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8111 }
8112
8113 /*
8114 =for apidoc newSVsv
8115
8116 Creates a new SV which is an exact duplicate of the original SV.
8117 (Uses C<sv_setsv>).
8118
8119 =cut
8120 */
8121
8122 SV *
8123 Perl_newSVsv(pTHX_ register SV *const old)
8124 {
8125     dVAR;
8126     register SV *sv;
8127
8128     if (!old)
8129         return NULL;
8130     if (SvTYPE(old) == SVTYPEMASK) {
8131         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8132         return NULL;
8133     }
8134     new_SV(sv);
8135     /* SV_GMAGIC is the default for sv_setv()
8136        SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8137        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
8138     sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8139     return sv;
8140 }
8141
8142 /*
8143 =for apidoc sv_reset
8144
8145 Underlying implementation for the C<reset> Perl function.
8146 Note that the perl-level function is vaguely deprecated.
8147
8148 =cut
8149 */
8150
8151 void
8152 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8153 {
8154     dVAR;
8155     char todo[PERL_UCHAR_MAX+1];
8156
8157     PERL_ARGS_ASSERT_SV_RESET;
8158
8159     if (!stash)
8160         return;
8161
8162     if (!*s) {          /* reset ?? searches */
8163         MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8164         if (mg) {
8165             const U32 count = mg->mg_len / sizeof(PMOP**);
8166             PMOP **pmp = (PMOP**) mg->mg_ptr;
8167             PMOP *const *const end = pmp + count;
8168
8169             while (pmp < end) {
8170 #ifdef USE_ITHREADS
8171                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8172 #else
8173                 (*pmp)->op_pmflags &= ~PMf_USED;
8174 #endif
8175                 ++pmp;
8176             }
8177         }
8178         return;
8179     }
8180
8181     /* reset variables */
8182
8183     if (!HvARRAY(stash))
8184         return;
8185
8186     Zero(todo, 256, char);
8187     while (*s) {
8188         I32 max;
8189         I32 i = (unsigned char)*s;
8190         if (s[1] == '-') {
8191             s += 2;
8192         }
8193         max = (unsigned char)*s++;
8194         for ( ; i <= max; i++) {
8195             todo[i] = 1;
8196         }
8197         for (i = 0; i <= (I32) HvMAX(stash); i++) {
8198             HE *entry;
8199             for (entry = HvARRAY(stash)[i];
8200                  entry;
8201                  entry = HeNEXT(entry))
8202             {
8203                 register GV *gv;
8204                 register SV *sv;
8205
8206                 if (!todo[(U8)*HeKEY(entry)])
8207                     continue;
8208                 gv = MUTABLE_GV(HeVAL(entry));
8209                 sv = GvSV(gv);
8210                 if (sv) {
8211                     if (SvTHINKFIRST(sv)) {
8212                         if (!SvREADONLY(sv) && SvROK(sv))
8213                             sv_unref(sv);
8214                         /* XXX Is this continue a bug? Why should THINKFIRST
8215                            exempt us from resetting arrays and hashes?  */
8216                         continue;
8217                     }
8218                     SvOK_off(sv);
8219                     if (SvTYPE(sv) >= SVt_PV) {
8220                         SvCUR_set(sv, 0);
8221                         if (SvPVX_const(sv) != NULL)
8222                             *SvPVX(sv) = '\0';
8223                         SvTAINT(sv);
8224                     }
8225                 }
8226                 if (GvAV(gv)) {
8227                     av_clear(GvAV(gv));
8228                 }
8229                 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8230 #if defined(VMS)
8231                     Perl_die(aTHX_ "Can't reset %%ENV on this system");
8232 #else /* ! VMS */
8233                     hv_clear(GvHV(gv));
8234 #  if defined(USE_ENVIRON_ARRAY)
8235                     if (gv == PL_envgv)
8236                         my_clearenv();
8237 #  endif /* USE_ENVIRON_ARRAY */
8238 #endif /* VMS */
8239                 }
8240             }
8241         }
8242     }
8243 }
8244
8245 /*
8246 =for apidoc sv_2io
8247
8248 Using various gambits, try to get an IO from an SV: the IO slot if its a
8249 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8250 named after the PV if we're a string.
8251
8252 =cut
8253 */
8254
8255 IO*
8256 Perl_sv_2io(pTHX_ SV *const sv)
8257 {
8258     IO* io;
8259     GV* gv;
8260
8261     PERL_ARGS_ASSERT_SV_2IO;
8262
8263     switch (SvTYPE(sv)) {
8264     case SVt_PVIO:
8265         io = MUTABLE_IO(sv);
8266         break;
8267     case SVt_PVGV:
8268         if (isGV_with_GP(sv)) {
8269             gv = MUTABLE_GV(sv);
8270             io = GvIO(gv);
8271             if (!io)
8272                 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8273             break;
8274         }
8275         /* FALL THROUGH */
8276     default:
8277         if (!SvOK(sv))
8278             Perl_croak(aTHX_ PL_no_usym, "filehandle");
8279         if (SvROK(sv))
8280             return sv_2io(SvRV(sv));
8281         gv = gv_fetchsv(sv, 0, SVt_PVIO);
8282         if (gv)
8283             io = GvIO(gv);
8284         else
8285             io = 0;
8286         if (!io)
8287             Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8288         break;
8289     }
8290     return io;
8291 }
8292
8293 /*
8294 =for apidoc sv_2cv
8295
8296 Using various gambits, try to get a CV from an SV; in addition, try if
8297 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8298 The flags in C<lref> are passed to gv_fetchsv.
8299
8300 =cut
8301 */
8302
8303 CV *
8304 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8305 {
8306     dVAR;
8307     GV *gv = NULL;
8308     CV *cv = NULL;
8309
8310     PERL_ARGS_ASSERT_SV_2CV;
8311
8312     if (!sv) {
8313         *st = NULL;
8314         *gvp = NULL;
8315         return NULL;
8316     }
8317     switch (SvTYPE(sv)) {
8318     case SVt_PVCV:
8319         *st = CvSTASH(sv);
8320         *gvp = NULL;
8321         return MUTABLE_CV(sv);
8322     case SVt_PVHV:
8323     case SVt_PVAV:
8324         *st = NULL;
8325         *gvp = NULL;
8326         return NULL;
8327     case SVt_PVGV:
8328         if (isGV_with_GP(sv)) {
8329             gv = MUTABLE_GV(sv);
8330             *gvp = gv;
8331             *st = GvESTASH(gv);
8332             goto fix_gv;
8333         }
8334         /* FALL THROUGH */
8335
8336     default:
8337         if (SvROK(sv)) {
8338             SV * const *sp = &sv;       /* Used in tryAMAGICunDEREF macro. */
8339             SvGETMAGIC(sv);
8340             tryAMAGICunDEREF(to_cv);
8341
8342             sv = SvRV(sv);
8343             if (SvTYPE(sv) == SVt_PVCV) {
8344                 cv = MUTABLE_CV(sv);
8345                 *gvp = NULL;
8346                 *st = CvSTASH(cv);
8347                 return cv;
8348             }
8349             else if(isGV_with_GP(sv))
8350                 gv = MUTABLE_GV(sv);
8351             else
8352                 Perl_croak(aTHX_ "Not a subroutine reference");
8353         }
8354         else if (isGV_with_GP(sv)) {
8355             SvGETMAGIC(sv);
8356             gv = MUTABLE_GV(sv);
8357         }
8358         else
8359             gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8360         *gvp = gv;
8361         if (!gv) {
8362             *st = NULL;
8363             return NULL;
8364         }
8365         /* Some flags to gv_fetchsv mean don't really create the GV  */
8366         if (!isGV_with_GP(gv)) {
8367             *st = NULL;
8368             return NULL;
8369         }
8370         *st = GvESTASH(gv);
8371     fix_gv:
8372         if (lref && !GvCVu(gv)) {
8373             SV *tmpsv;
8374             ENTER;
8375             tmpsv = newSV(0);
8376             gv_efullname3(tmpsv, gv, NULL);
8377             /* XXX this is probably not what they think they're getting.
8378              * It has the same effect as "sub name;", i.e. just a forward
8379              * declaration! */
8380             newSUB(start_subparse(FALSE, 0),
8381                    newSVOP(OP_CONST, 0, tmpsv),
8382                    NULL, NULL);
8383             LEAVE;
8384             if (!GvCVu(gv))
8385                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8386                            SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8387         }
8388         return GvCVu(gv);
8389     }
8390 }
8391
8392 /*
8393 =for apidoc sv_true
8394
8395 Returns true if the SV has a true value by Perl's rules.
8396 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8397 instead use an in-line version.
8398
8399 =cut
8400 */
8401
8402 I32
8403 Perl_sv_true(pTHX_ register SV *const sv)
8404 {
8405     if (!sv)
8406         return 0;
8407     if (SvPOK(sv)) {
8408         register const XPV* const tXpv = (XPV*)SvANY(sv);
8409         if (tXpv &&
8410                 (tXpv->xpv_cur > 1 ||
8411                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8412             return 1;
8413         else
8414             return 0;
8415     }
8416     else {
8417         if (SvIOK(sv))
8418             return SvIVX(sv) != 0;
8419         else {
8420             if (SvNOK(sv))
8421                 return SvNVX(sv) != 0.0;
8422             else
8423                 return sv_2bool(sv);
8424         }
8425     }
8426 }
8427
8428 /*
8429 =for apidoc sv_pvn_force
8430
8431 Get a sensible string out of the SV somehow.
8432 A private implementation of the C<SvPV_force> macro for compilers which
8433 can't cope with complex macro expressions. Always use the macro instead.
8434
8435 =for apidoc sv_pvn_force_flags
8436
8437 Get a sensible string out of the SV somehow.
8438 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8439 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8440 implemented in terms of this function.
8441 You normally want to use the various wrapper macros instead: see
8442 C<SvPV_force> and C<SvPV_force_nomg>
8443
8444 =cut
8445 */
8446
8447 char *
8448 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8449 {
8450     dVAR;
8451
8452     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8453
8454     if (SvTHINKFIRST(sv) && !SvROK(sv))
8455         sv_force_normal_flags(sv, 0);
8456
8457     if (SvPOK(sv)) {
8458         if (lp)
8459             *lp = SvCUR(sv);
8460     }
8461     else {
8462         char *s;
8463         STRLEN len;
8464
8465         if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8466             const char * const ref = sv_reftype(sv,0);
8467             if (PL_op)
8468                 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8469                            ref, OP_DESC(PL_op));
8470             else
8471                 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8472         }
8473         if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8474             || isGV_with_GP(sv))
8475             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8476                 OP_DESC(PL_op));
8477         s = sv_2pv_flags(sv, &len, flags);
8478         if (lp)
8479             *lp = len;
8480
8481         if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
8482             if (SvROK(sv))
8483                 sv_unref(sv);
8484             SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
8485             SvGROW(sv, len + 1);
8486             Move(s,SvPVX(sv),len,char);
8487             SvCUR_set(sv, len);
8488             SvPVX(sv)[len] = '\0';
8489         }
8490         if (!SvPOK(sv)) {
8491             SvPOK_on(sv);               /* validate pointer */
8492             SvTAINT(sv);
8493             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8494                                   PTR2UV(sv),SvPVX_const(sv)));
8495         }
8496     }
8497     return SvPVX_mutable(sv);
8498 }
8499
8500 /*
8501 =for apidoc sv_pvbyten_force
8502
8503 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8504
8505 =cut
8506 */
8507
8508 char *
8509 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8510 {
8511     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8512
8513     sv_pvn_force(sv,lp);
8514     sv_utf8_downgrade(sv,0);
8515     *lp = SvCUR(sv);
8516     return SvPVX(sv);
8517 }
8518
8519 /*
8520 =for apidoc sv_pvutf8n_force
8521
8522 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8523
8524 =cut
8525 */
8526
8527 char *
8528 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8529 {
8530     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8531
8532     sv_pvn_force(sv,lp);
8533     sv_utf8_upgrade(sv);
8534     *lp = SvCUR(sv);
8535     return SvPVX(sv);
8536 }
8537
8538 /*
8539 =for apidoc sv_reftype
8540
8541 Returns a string describing what the SV is a reference to.
8542
8543 =cut
8544 */
8545
8546 const char *
8547 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8548 {
8549     PERL_ARGS_ASSERT_SV_REFTYPE;
8550
8551     /* The fact that I don't need to downcast to char * everywhere, only in ?:
8552        inside return suggests a const propagation bug in g++.  */
8553     if (ob && SvOBJECT(sv)) {
8554         char * const name = HvNAME_get(SvSTASH(sv));
8555         return name ? name : (char *) "__ANON__";
8556     }
8557     else {
8558         switch (SvTYPE(sv)) {
8559         case SVt_NULL:
8560         case SVt_IV:
8561         case SVt_NV:
8562         case SVt_PV:
8563         case SVt_PVIV:
8564         case SVt_PVNV:
8565         case SVt_PVMG:
8566                                 if (SvVOK(sv))
8567                                     return "VSTRING";
8568                                 if (SvROK(sv))
8569                                     return "REF";
8570                                 else
8571                                     return "SCALAR";
8572
8573         case SVt_PVLV:          return (char *)  (SvROK(sv) ? "REF"
8574                                 /* tied lvalues should appear to be
8575                                  * scalars for backwards compatitbility */
8576                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8577                                     ? "SCALAR" : "LVALUE");
8578         case SVt_PVAV:          return "ARRAY";
8579         case SVt_PVHV:          return "HASH";
8580         case SVt_PVCV:          return "CODE";
8581         case SVt_PVGV:          return (char *) (isGV_with_GP(sv)
8582                                     ? "GLOB" : "SCALAR");
8583         case SVt_PVFM:          return "FORMAT";
8584         case SVt_PVIO:          return "IO";
8585         case SVt_BIND:          return "BIND";
8586         case SVt_REGEXP:        return "REGEXP";
8587         default:                return "UNKNOWN";
8588         }
8589     }
8590 }
8591
8592 /*
8593 =for apidoc sv_isobject
8594
8595 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8596 object.  If the SV is not an RV, or if the object is not blessed, then this
8597 will return false.
8598
8599 =cut
8600 */
8601
8602 int
8603 Perl_sv_isobject(pTHX_ SV *sv)
8604 {
8605     if (!sv)
8606         return 0;
8607     SvGETMAGIC(sv);
8608     if (!SvROK(sv))
8609         return 0;
8610     sv = SvRV(sv);
8611     if (!SvOBJECT(sv))
8612         return 0;
8613     return 1;
8614 }
8615
8616 /*
8617 =for apidoc sv_isa
8618
8619 Returns a boolean indicating whether the SV is blessed into the specified
8620 class.  This does not check for subtypes; use C<sv_derived_from> to verify
8621 an inheritance relationship.
8622
8623 =cut
8624 */
8625
8626 int
8627 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8628 {
8629     const char *hvname;
8630
8631     PERL_ARGS_ASSERT_SV_ISA;
8632
8633     if (!sv)
8634         return 0;
8635     SvGETMAGIC(sv);
8636     if (!SvROK(sv))
8637         return 0;
8638     sv = SvRV(sv);
8639     if (!SvOBJECT(sv))
8640         return 0;
8641     hvname = HvNAME_get(SvSTASH(sv));
8642     if (!hvname)
8643         return 0;
8644
8645     return strEQ(hvname, name);
8646 }
8647
8648 /*
8649 =for apidoc newSVrv
8650
8651 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
8652 it will be upgraded to one.  If C<classname> is non-null then the new SV will
8653 be blessed in the specified package.  The new SV is returned and its
8654 reference count is 1.
8655
8656 =cut
8657 */
8658
8659 SV*
8660 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8661 {
8662     dVAR;
8663     SV *sv;
8664
8665     PERL_ARGS_ASSERT_NEWSVRV;
8666
8667     new_SV(sv);
8668
8669     SV_CHECK_THINKFIRST_COW_DROP(rv);
8670     (void)SvAMAGIC_off(rv);
8671
8672     if (SvTYPE(rv) >= SVt_PVMG) {
8673         const U32 refcnt = SvREFCNT(rv);
8674         SvREFCNT(rv) = 0;
8675         sv_clear(rv);
8676         SvFLAGS(rv) = 0;
8677         SvREFCNT(rv) = refcnt;
8678
8679         sv_upgrade(rv, SVt_IV);
8680     } else if (SvROK(rv)) {
8681         SvREFCNT_dec(SvRV(rv));
8682     } else {
8683         prepare_SV_for_RV(rv);
8684     }
8685
8686     SvOK_off(rv);
8687     SvRV_set(rv, sv);
8688     SvROK_on(rv);
8689
8690     if (classname) {
8691         HV* const stash = gv_stashpv(classname, GV_ADD);
8692         (void)sv_bless(rv, stash);
8693     }
8694     return sv;
8695 }
8696
8697 /*
8698 =for apidoc sv_setref_pv
8699
8700 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
8701 argument will be upgraded to an RV.  That RV will be modified to point to
8702 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8703 into the SV.  The C<classname> argument indicates the package for the
8704 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8705 will have a reference count of 1, and the RV will be returned.
8706
8707 Do not use with other Perl types such as HV, AV, SV, CV, because those
8708 objects will become corrupted by the pointer copy process.
8709
8710 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8711
8712 =cut
8713 */
8714
8715 SV*
8716 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8717 {
8718     dVAR;
8719
8720     PERL_ARGS_ASSERT_SV_SETREF_PV;
8721
8722     if (!pv) {
8723         sv_setsv(rv, &PL_sv_undef);
8724         SvSETMAGIC(rv);
8725     }
8726     else
8727         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8728     return rv;
8729 }
8730
8731 /*
8732 =for apidoc sv_setref_iv
8733
8734 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
8735 argument will be upgraded to an RV.  That RV will be modified to point to
8736 the new SV.  The C<classname> argument indicates the package for the
8737 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8738 will have a reference count of 1, and the RV will be returned.
8739
8740 =cut
8741 */
8742
8743 SV*
8744 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8745 {
8746     PERL_ARGS_ASSERT_SV_SETREF_IV;
8747
8748     sv_setiv(newSVrv(rv,classname), iv);
8749     return rv;
8750 }
8751
8752 /*
8753 =for apidoc sv_setref_uv
8754
8755 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
8756 argument will be upgraded to an RV.  That RV will be modified to point to
8757 the new SV.  The C<classname> argument indicates the package for the
8758 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8759 will have a reference count of 1, and the RV will be returned.
8760
8761 =cut
8762 */
8763
8764 SV*
8765 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8766 {
8767     PERL_ARGS_ASSERT_SV_SETREF_UV;
8768
8769     sv_setuv(newSVrv(rv,classname), uv);
8770     return rv;
8771 }
8772
8773 /*
8774 =for apidoc sv_setref_nv
8775
8776 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
8777 argument will be upgraded to an RV.  That RV will be modified to point to
8778 the new SV.  The C<classname> argument indicates the package for the
8779 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8780 will have a reference count of 1, and the RV will be returned.
8781
8782 =cut
8783 */
8784
8785 SV*
8786 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8787 {
8788     PERL_ARGS_ASSERT_SV_SETREF_NV;
8789
8790     sv_setnv(newSVrv(rv,classname), nv);
8791     return rv;
8792 }
8793
8794 /*
8795 =for apidoc sv_setref_pvn
8796
8797 Copies a string into a new SV, optionally blessing the SV.  The length of the
8798 string must be specified with C<n>.  The C<rv> argument will be upgraded to
8799 an RV.  That RV will be modified to point to the new SV.  The C<classname>
8800 argument indicates the package for the blessing.  Set C<classname> to
8801 C<NULL> to avoid the blessing.  The new SV will have a reference count
8802 of 1, and the RV will be returned.
8803
8804 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8805
8806 =cut
8807 */
8808
8809 SV*
8810 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8811                    const char *const pv, const STRLEN n)
8812 {
8813     PERL_ARGS_ASSERT_SV_SETREF_PVN;
8814
8815     sv_setpvn(newSVrv(rv,classname), pv, n);
8816     return rv;
8817 }
8818
8819 /*
8820 =for apidoc sv_bless
8821
8822 Blesses an SV into a specified package.  The SV must be an RV.  The package
8823 must be designated by its stash (see C<gv_stashpv()>).  The reference count
8824 of the SV is unaffected.
8825
8826 =cut
8827 */
8828
8829 SV*
8830 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8831 {
8832     dVAR;
8833     SV *tmpRef;
8834
8835     PERL_ARGS_ASSERT_SV_BLESS;
8836
8837     if (!SvROK(sv))
8838         Perl_croak(aTHX_ "Can't bless non-reference value");
8839     tmpRef = SvRV(sv);
8840     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8841         if (SvIsCOW(tmpRef))
8842             sv_force_normal_flags(tmpRef, 0);
8843         if (SvREADONLY(tmpRef))
8844             Perl_croak(aTHX_ "%s", PL_no_modify);
8845         if (SvOBJECT(tmpRef)) {
8846             if (SvTYPE(tmpRef) != SVt_PVIO)
8847                 --PL_sv_objcount;
8848             SvREFCNT_dec(SvSTASH(tmpRef));
8849         }
8850     }
8851     SvOBJECT_on(tmpRef);
8852     if (SvTYPE(tmpRef) != SVt_PVIO)
8853         ++PL_sv_objcount;
8854     SvUPGRADE(tmpRef, SVt_PVMG);
8855     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8856
8857     if (Gv_AMG(stash))
8858         SvAMAGIC_on(sv);
8859     else
8860         (void)SvAMAGIC_off(sv);
8861
8862     if(SvSMAGICAL(tmpRef))
8863         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8864             mg_set(tmpRef);
8865
8866
8867
8868     return sv;
8869 }
8870
8871 /* Downgrades a PVGV to a PVMG.
8872  */
8873
8874 STATIC void
8875 S_sv_unglob(pTHX_ SV *const sv)
8876 {
8877     dVAR;
8878     void *xpvmg;
8879     HV *stash;
8880     SV * const temp = sv_newmortal();
8881
8882     PERL_ARGS_ASSERT_SV_UNGLOB;
8883
8884     assert(SvTYPE(sv) == SVt_PVGV);
8885     SvFAKE_off(sv);
8886     gv_efullname3(temp, MUTABLE_GV(sv), "*");
8887
8888     if (GvGP(sv)) {
8889         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
8890            && HvNAME_get(stash))
8891             mro_method_changed_in(stash);
8892         gp_free(MUTABLE_GV(sv));
8893     }
8894     if (GvSTASH(sv)) {
8895         sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
8896         GvSTASH(sv) = NULL;
8897     }
8898     GvMULTI_off(sv);
8899     if (GvNAME_HEK(sv)) {
8900         unshare_hek(GvNAME_HEK(sv));
8901     }
8902     isGV_with_GP_off(sv);
8903
8904     /* need to keep SvANY(sv) in the right arena */
8905     xpvmg = new_XPVMG();
8906     StructCopy(SvANY(sv), xpvmg, XPVMG);
8907     del_XPVGV(SvANY(sv));
8908     SvANY(sv) = xpvmg;
8909
8910     SvFLAGS(sv) &= ~SVTYPEMASK;
8911     SvFLAGS(sv) |= SVt_PVMG;
8912
8913     /* Intentionally not calling any local SET magic, as this isn't so much a
8914        set operation as merely an internal storage change.  */
8915     sv_setsv_flags(sv, temp, 0);
8916 }
8917
8918 /*
8919 =for apidoc sv_unref_flags
8920
8921 Unsets the RV status of the SV, and decrements the reference count of
8922 whatever was being referenced by the RV.  This can almost be thought of
8923 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
8924 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8925 (otherwise the decrementing is conditional on the reference count being
8926 different from one or the reference being a readonly SV).
8927 See C<SvROK_off>.
8928
8929 =cut
8930 */
8931
8932 void
8933 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8934 {
8935     SV* const target = SvRV(ref);
8936
8937     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8938
8939     if (SvWEAKREF(ref)) {
8940         sv_del_backref(target, ref);
8941         SvWEAKREF_off(ref);
8942         SvRV_set(ref, NULL);
8943         return;
8944     }
8945     SvRV_set(ref, NULL);
8946     SvROK_off(ref);
8947     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8948        assigned to as BEGIN {$a = \"Foo"} will fail.  */
8949     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8950         SvREFCNT_dec(target);
8951     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8952         sv_2mortal(target);     /* Schedule for freeing later */
8953 }
8954
8955 /*
8956 =for apidoc sv_untaint
8957
8958 Untaint an SV. Use C<SvTAINTED_off> instead.
8959 =cut
8960 */
8961
8962 void
8963 Perl_sv_untaint(pTHX_ SV *const sv)
8964 {
8965     PERL_ARGS_ASSERT_SV_UNTAINT;
8966
8967     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8968         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8969         if (mg)
8970             mg->mg_len &= ~1;
8971     }
8972 }
8973
8974 /*
8975 =for apidoc sv_tainted
8976
8977 Test an SV for taintedness. Use C<SvTAINTED> instead.
8978 =cut
8979 */
8980
8981 bool
8982 Perl_sv_tainted(pTHX_ SV *const sv)
8983 {
8984     PERL_ARGS_ASSERT_SV_TAINTED;
8985
8986     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8987         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8988         if (mg && (mg->mg_len & 1) )
8989             return TRUE;
8990     }
8991     return FALSE;
8992 }
8993
8994 /*
8995 =for apidoc sv_setpviv
8996
8997 Copies an integer into the given SV, also updating its string value.
8998 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
8999
9000 =cut
9001 */
9002
9003 void
9004 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9005 {
9006     char buf[TYPE_CHARS(UV)];
9007     char *ebuf;
9008     char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9009
9010     PERL_ARGS_ASSERT_SV_SETPVIV;
9011
9012     sv_setpvn(sv, ptr, ebuf - ptr);
9013 }
9014
9015 /*
9016 =for apidoc sv_setpviv_mg
9017
9018 Like C<sv_setpviv>, but also handles 'set' magic.
9019
9020 =cut
9021 */
9022
9023 void
9024 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9025 {
9026     PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9027
9028     sv_setpviv(sv, iv);
9029     SvSETMAGIC(sv);
9030 }
9031
9032 #if defined(PERL_IMPLICIT_CONTEXT)
9033
9034 /* pTHX_ magic can't cope with varargs, so this is a no-context
9035  * version of the main function, (which may itself be aliased to us).
9036  * Don't access this version directly.
9037  */
9038
9039 void
9040 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9041 {
9042     dTHX;
9043     va_list args;
9044
9045     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9046
9047     va_start(args, pat);
9048     sv_vsetpvf(sv, pat, &args);
9049     va_end(args);
9050 }
9051
9052 /* pTHX_ magic can't cope with varargs, so this is a no-context
9053  * version of the main function, (which may itself be aliased to us).
9054  * Don't access this version directly.
9055  */
9056
9057 void
9058 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9059 {
9060     dTHX;
9061     va_list args;
9062
9063     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9064
9065     va_start(args, pat);
9066     sv_vsetpvf_mg(sv, pat, &args);
9067     va_end(args);
9068 }
9069 #endif
9070
9071 /*
9072 =for apidoc sv_setpvf
9073
9074 Works like C<sv_catpvf> but copies the text into the SV instead of
9075 appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
9076
9077 =cut
9078 */
9079
9080 void
9081 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9082 {
9083     va_list args;
9084
9085     PERL_ARGS_ASSERT_SV_SETPVF;
9086
9087     va_start(args, pat);
9088     sv_vsetpvf(sv, pat, &args);
9089     va_end(args);
9090 }
9091
9092 /*
9093 =for apidoc sv_vsetpvf
9094
9095 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9096 appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
9097
9098 Usually used via its frontend C<sv_setpvf>.
9099
9100 =cut
9101 */
9102
9103 void
9104 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9105 {
9106     PERL_ARGS_ASSERT_SV_VSETPVF;
9107
9108     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9109 }
9110
9111 /*
9112 =for apidoc sv_setpvf_mg
9113
9114 Like C<sv_setpvf>, but also handles 'set' magic.
9115
9116 =cut
9117 */
9118
9119 void
9120 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9121 {
9122     va_list args;
9123
9124     PERL_ARGS_ASSERT_SV_SETPVF_MG;
9125
9126     va_start(args, pat);
9127     sv_vsetpvf_mg(sv, pat, &args);
9128     va_end(args);
9129 }
9130
9131 /*
9132 =for apidoc sv_vsetpvf_mg
9133
9134 Like C<sv_vsetpvf>, but also handles 'set' magic.
9135
9136 Usually used via its frontend C<sv_setpvf_mg>.
9137
9138 =cut
9139 */
9140
9141 void
9142 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9143 {
9144     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9145
9146     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9147     SvSETMAGIC(sv);
9148 }
9149
9150 #if defined(PERL_IMPLICIT_CONTEXT)
9151
9152 /* pTHX_ magic can't cope with varargs, so this is a no-context
9153  * version of the main function, (which may itself be aliased to us).
9154  * Don't access this version directly.
9155  */
9156
9157 void
9158 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9159 {
9160     dTHX;
9161     va_list args;
9162
9163     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9164
9165     va_start(args, pat);
9166     sv_vcatpvf(sv, pat, &args);
9167     va_end(args);
9168 }
9169
9170 /* pTHX_ magic can't cope with varargs, so this is a no-context
9171  * version of the main function, (which may itself be aliased to us).
9172  * Don't access this version directly.
9173  */
9174
9175 void
9176 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9177 {
9178     dTHX;
9179     va_list args;
9180
9181     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9182
9183     va_start(args, pat);
9184     sv_vcatpvf_mg(sv, pat, &args);
9185     va_end(args);
9186 }
9187 #endif
9188
9189 /*
9190 =for apidoc sv_catpvf
9191
9192 Processes its arguments like C<sprintf> and appends the formatted
9193 output to an SV.  If the appended data contains "wide" characters
9194 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9195 and characters >255 formatted with %c), the original SV might get
9196 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
9197 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9198 valid UTF-8; if the original SV was bytes, the pattern should be too.
9199
9200 =cut */
9201
9202 void
9203 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9204 {
9205     va_list args;
9206
9207     PERL_ARGS_ASSERT_SV_CATPVF;
9208
9209     va_start(args, pat);
9210     sv_vcatpvf(sv, pat, &args);
9211     va_end(args);
9212 }
9213
9214 /*
9215 =for apidoc sv_vcatpvf
9216
9217 Processes its arguments like C<vsprintf> and appends the formatted output
9218 to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
9219
9220 Usually used via its frontend C<sv_catpvf>.
9221
9222 =cut
9223 */
9224
9225 void
9226 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9227 {
9228     PERL_ARGS_ASSERT_SV_VCATPVF;
9229
9230     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9231 }
9232
9233 /*
9234 =for apidoc sv_catpvf_mg
9235
9236 Like C<sv_catpvf>, but also handles 'set' magic.
9237
9238 =cut
9239 */
9240
9241 void
9242 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9243 {
9244     va_list args;
9245
9246     PERL_ARGS_ASSERT_SV_CATPVF_MG;
9247
9248     va_start(args, pat);
9249     sv_vcatpvf_mg(sv, pat, &args);
9250     va_end(args);
9251 }
9252
9253 /*
9254 =for apidoc sv_vcatpvf_mg
9255
9256 Like C<sv_vcatpvf>, but also handles 'set' magic.
9257
9258 Usually used via its frontend C<sv_catpvf_mg>.
9259
9260 =cut
9261 */
9262
9263 void
9264 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9265 {
9266     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9267
9268     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9269     SvSETMAGIC(sv);
9270 }
9271
9272 /*
9273 =for apidoc sv_vsetpvfn
9274
9275 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9276 appending it.
9277
9278 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9279
9280 =cut
9281 */
9282
9283 void
9284 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9285                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9286 {
9287     PERL_ARGS_ASSERT_SV_VSETPVFN;
9288
9289     sv_setpvs(sv, "");
9290     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9291 }
9292
9293
9294 /*
9295  * Warn of missing argument to sprintf, and then return a defined value
9296  * to avoid inappropriate "use of uninit" warnings [perl #71000].
9297  */
9298 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9299 STATIC SV*
9300 S_vcatpvfn_missing_argument(pTHX) {
9301     if (ckWARN(WARN_MISSING)) {
9302         Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9303                 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9304     }
9305     return &PL_sv_no;
9306 }
9307
9308
9309 STATIC I32
9310 S_expect_number(pTHX_ char **const pattern)
9311 {
9312     dVAR;
9313     I32 var = 0;
9314
9315     PERL_ARGS_ASSERT_EXPECT_NUMBER;
9316
9317     switch (**pattern) {
9318     case '1': case '2': case '3':
9319     case '4': case '5': case '6':
9320     case '7': case '8': case '9':
9321         var = *(*pattern)++ - '0';
9322         while (isDIGIT(**pattern)) {
9323             const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9324             if (tmp < var)
9325                 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9326             var = tmp;
9327         }
9328     }
9329     return var;
9330 }
9331
9332 STATIC char *
9333 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9334 {
9335     const int neg = nv < 0;
9336     UV uv;
9337
9338     PERL_ARGS_ASSERT_F0CONVERT;
9339
9340     if (neg)
9341         nv = -nv;
9342     if (nv < UV_MAX) {
9343         char *p = endbuf;
9344         nv += 0.5;
9345         uv = (UV)nv;
9346         if (uv & 1 && uv == nv)
9347             uv--;                       /* Round to even */
9348         do {
9349             const unsigned dig = uv % 10;
9350             *--p = '0' + dig;
9351         } while (uv /= 10);
9352         if (neg)
9353             *--p = '-';
9354         *len = endbuf - p;
9355         return p;
9356     }
9357     return NULL;
9358 }
9359
9360
9361 /*
9362 =for apidoc sv_vcatpvfn
9363
9364 Processes its arguments like C<vsprintf> and appends the formatted output
9365 to an SV.  Uses an array of SVs if the C style variable argument list is
9366 missing (NULL).  When running with taint checks enabled, indicates via
9367 C<maybe_tainted> if results are untrustworthy (often due to the use of
9368 locales).
9369
9370 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9371
9372 =cut
9373 */
9374
9375
9376 #define VECTORIZE_ARGS  vecsv = va_arg(*args, SV*);\
9377                         vecstr = (U8*)SvPV_const(vecsv,veclen);\
9378                         vec_utf8 = DO_UTF8(vecsv);
9379
9380 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9381
9382 void
9383 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9384                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9385 {
9386     dVAR;
9387     char *p;
9388     char *q;
9389     const char *patend;
9390     STRLEN origlen;
9391     I32 svix = 0;
9392     static const char nullstr[] = "(null)";
9393     SV *argsv = NULL;
9394     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
9395     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9396     SV *nsv = NULL;
9397     /* Times 4: a decimal digit takes more than 3 binary digits.
9398      * NV_DIG: mantissa takes than many decimal digits.
9399      * Plus 32: Playing safe. */
9400     char ebuf[IV_DIG * 4 + NV_DIG + 32];
9401     /* large enough for "%#.#f" --chip */
9402     /* what about long double NVs? --jhi */
9403
9404     PERL_ARGS_ASSERT_SV_VCATPVFN;
9405     PERL_UNUSED_ARG(maybe_tainted);
9406
9407     /* no matter what, this is a string now */
9408     (void)SvPV_force(sv, origlen);
9409
9410     /* special-case "", "%s", and "%-p" (SVf - see below) */
9411     if (patlen == 0)
9412         return;
9413     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9414         if (args) {
9415             const char * const s = va_arg(*args, char*);
9416             sv_catpv(sv, s ? s : nullstr);
9417         }
9418         else if (svix < svmax) {
9419             sv_catsv(sv, *svargs);
9420         }
9421         else
9422             S_vcatpvfn_missing_argument(aTHX);
9423         return;
9424     }
9425     if (args && patlen == 3 && pat[0] == '%' &&
9426                 pat[1] == '-' && pat[2] == 'p') {
9427         argsv = MUTABLE_SV(va_arg(*args, void*));
9428         sv_catsv(sv, argsv);
9429         return;
9430     }
9431
9432 #ifndef USE_LONG_DOUBLE
9433     /* special-case "%.<number>[gf]" */
9434     if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9435          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9436         unsigned digits = 0;
9437         const char *pp;
9438
9439         pp = pat + 2;
9440         while (*pp >= '0' && *pp <= '9')
9441             digits = 10 * digits + (*pp++ - '0');
9442         if (pp - pat == (int)patlen - 1 && svix < svmax) {
9443             const NV nv = SvNV(*svargs);
9444             if (*pp == 'g') {
9445                 /* Add check for digits != 0 because it seems that some
9446                    gconverts are buggy in this case, and we don't yet have
9447                    a Configure test for this.  */
9448                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9449                      /* 0, point, slack */
9450                     Gconvert(nv, (int)digits, 0, ebuf);
9451                     sv_catpv(sv, ebuf);
9452                     if (*ebuf)  /* May return an empty string for digits==0 */
9453                         return;
9454                 }
9455             } else if (!digits) {
9456                 STRLEN l;
9457
9458                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9459                     sv_catpvn(sv, p, l);
9460                     return;
9461                 }
9462             }
9463         }
9464     }
9465 #endif /* !USE_LONG_DOUBLE */
9466
9467     if (!args && svix < svmax && DO_UTF8(*svargs))
9468         has_utf8 = TRUE;
9469
9470     patend = (char*)pat + patlen;
9471     for (p = (char*)pat; p < patend; p = q) {
9472         bool alt = FALSE;
9473         bool left = FALSE;
9474         bool vectorize = FALSE;
9475         bool vectorarg = FALSE;
9476         bool vec_utf8 = FALSE;
9477         char fill = ' ';
9478         char plus = 0;
9479         char intsize = 0;
9480         STRLEN width = 0;
9481         STRLEN zeros = 0;
9482         bool has_precis = FALSE;
9483         STRLEN precis = 0;
9484         const I32 osvix = svix;
9485         bool is_utf8 = FALSE;  /* is this item utf8?   */
9486 #ifdef HAS_LDBL_SPRINTF_BUG
9487         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9488            with sfio - Allen <allens@cpan.org> */
9489         bool fix_ldbl_sprintf_bug = FALSE;
9490 #endif
9491
9492         char esignbuf[4];
9493         U8 utf8buf[UTF8_MAXBYTES+1];
9494         STRLEN esignlen = 0;
9495
9496         const char *eptr = NULL;
9497         const char *fmtstart;
9498         STRLEN elen = 0;
9499         SV *vecsv = NULL;
9500         const U8 *vecstr = NULL;
9501         STRLEN veclen = 0;
9502         char c = 0;
9503         int i;
9504         unsigned base = 0;
9505         IV iv = 0;
9506         UV uv = 0;
9507         /* we need a long double target in case HAS_LONG_DOUBLE but
9508            not USE_LONG_DOUBLE
9509         */
9510 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9511         long double nv;
9512 #else
9513         NV nv;
9514 #endif
9515         STRLEN have;
9516         STRLEN need;
9517         STRLEN gap;
9518         const char *dotstr = ".";
9519         STRLEN dotstrlen = 1;
9520         I32 efix = 0; /* explicit format parameter index */
9521         I32 ewix = 0; /* explicit width index */
9522         I32 epix = 0; /* explicit precision index */
9523         I32 evix = 0; /* explicit vector index */
9524         bool asterisk = FALSE;
9525
9526         /* echo everything up to the next format specification */
9527         for (q = p; q < patend && *q != '%'; ++q) ;
9528         if (q > p) {
9529             if (has_utf8 && !pat_utf8)
9530                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9531             else
9532                 sv_catpvn(sv, p, q - p);
9533             p = q;
9534         }
9535         if (q++ >= patend)
9536             break;
9537
9538         fmtstart = q;
9539
9540 /*
9541     We allow format specification elements in this order:
9542         \d+\$              explicit format parameter index
9543         [-+ 0#]+           flags
9544         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
9545         0                  flag (as above): repeated to allow "v02"
9546         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
9547         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9548         [hlqLV]            size
9549     [%bcdefginopsuxDFOUX] format (mandatory)
9550 */
9551
9552         if (args) {
9553 /*
9554         As of perl5.9.3, printf format checking is on by default.
9555         Internally, perl uses %p formats to provide an escape to
9556         some extended formatting.  This block deals with those
9557         extensions: if it does not match, (char*)q is reset and
9558         the normal format processing code is used.
9559
9560         Currently defined extensions are:
9561                 %p              include pointer address (standard)
9562                 %-p     (SVf)   include an SV (previously %_)
9563                 %-<num>p        include an SV with precision <num>
9564                 %<num>p         reserved for future extensions
9565
9566         Robin Barker 2005-07-14
9567
9568                 %1p     (VDf)   removed.  RMB 2007-10-19
9569 */
9570             char* r = q;
9571             bool sv = FALSE;
9572             STRLEN n = 0;
9573             if (*q == '-')
9574                 sv = *q++;
9575             n = expect_number(&q);
9576             if (*q++ == 'p') {
9577                 if (sv) {                       /* SVf */
9578                     if (n) {
9579                         precis = n;
9580                         has_precis = TRUE;
9581                     }
9582                     argsv = MUTABLE_SV(va_arg(*args, void*));
9583                     eptr = SvPV_const(argsv, elen);
9584                     if (DO_UTF8(argsv))
9585                         is_utf8 = TRUE;
9586                     goto string;
9587                 }
9588                 else if (n) {
9589                     Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
9590                                      "internal %%<num>p might conflict with future printf extensions");
9591                 }
9592             }
9593             q = r;
9594         }
9595
9596         if ( (width = expect_number(&q)) ) {
9597             if (*q == '$') {
9598                 ++q;
9599                 efix = width;
9600             } else {
9601                 goto gotwidth;
9602             }
9603         }
9604
9605         /* FLAGS */
9606
9607         while (*q) {
9608             switch (*q) {
9609             case ' ':
9610             case '+':
9611                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9612                     q++;
9613                 else
9614                     plus = *q++;
9615                 continue;
9616
9617             case '-':
9618                 left = TRUE;
9619                 q++;
9620                 continue;
9621
9622             case '0':
9623                 fill = *q++;
9624                 continue;
9625
9626             case '#':
9627                 alt = TRUE;
9628                 q++;
9629                 continue;
9630
9631             default:
9632                 break;
9633             }
9634             break;
9635         }
9636
9637       tryasterisk:
9638         if (*q == '*') {
9639             q++;
9640             if ( (ewix = expect_number(&q)) )
9641                 if (*q++ != '$')
9642                     goto unknown;
9643             asterisk = TRUE;
9644         }
9645         if (*q == 'v') {
9646             q++;
9647             if (vectorize)
9648                 goto unknown;
9649             if ((vectorarg = asterisk)) {
9650                 evix = ewix;
9651                 ewix = 0;
9652                 asterisk = FALSE;
9653             }
9654             vectorize = TRUE;
9655             goto tryasterisk;
9656         }
9657
9658         if (!asterisk)
9659         {
9660             if( *q == '0' )
9661                 fill = *q++;
9662             width = expect_number(&q);
9663         }
9664
9665         if (vectorize) {
9666             if (vectorarg) {
9667                 if (args)
9668                     vecsv = va_arg(*args, SV*);
9669                 else if (evix) {
9670                     vecsv = (evix > 0 && evix <= svmax)
9671                         ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
9672                 } else {
9673                     vecsv = svix < svmax
9674                         ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9675                 }
9676                 dotstr = SvPV_const(vecsv, dotstrlen);
9677                 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9678                    bad with tied or overloaded values that return UTF8.  */
9679                 if (DO_UTF8(vecsv))
9680                     is_utf8 = TRUE;
9681                 else if (has_utf8) {
9682                     vecsv = sv_mortalcopy(vecsv);
9683                     sv_utf8_upgrade(vecsv);
9684                     dotstr = SvPV_const(vecsv, dotstrlen);
9685                     is_utf8 = TRUE;
9686                 }
9687             }
9688             if (args) {
9689                 VECTORIZE_ARGS
9690             }
9691             else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9692                 vecsv = svargs[efix ? efix-1 : svix++];
9693                 vecstr = (U8*)SvPV_const(vecsv,veclen);
9694                 vec_utf8 = DO_UTF8(vecsv);
9695
9696                 /* if this is a version object, we need to convert
9697                  * back into v-string notation and then let the
9698                  * vectorize happen normally
9699                  */
9700                 if (sv_derived_from(vecsv, "version")) {
9701                     char *version = savesvpv(vecsv);
9702                     if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9703                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9704                         "vector argument not supported with alpha versions");
9705                         goto unknown;
9706                     }
9707                     vecsv = sv_newmortal();
9708                     scan_vstring(version, version + veclen, vecsv);
9709                     vecstr = (U8*)SvPV_const(vecsv, veclen);
9710                     vec_utf8 = DO_UTF8(vecsv);
9711                     Safefree(version);
9712                 }
9713             }
9714             else {
9715                 vecstr = (U8*)"";
9716                 veclen = 0;
9717             }
9718         }
9719
9720         if (asterisk) {
9721             if (args)
9722                 i = va_arg(*args, int);
9723             else
9724                 i = (ewix ? ewix <= svmax : svix < svmax) ?
9725                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9726             left |= (i < 0);
9727             width = (i < 0) ? -i : i;
9728         }
9729       gotwidth:
9730
9731         /* PRECISION */
9732
9733         if (*q == '.') {
9734             q++;
9735             if (*q == '*') {
9736                 q++;
9737                 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9738                     goto unknown;
9739                 /* XXX: todo, support specified precision parameter */
9740                 if (epix)
9741                     goto unknown;
9742                 if (args)
9743                     i = va_arg(*args, int);
9744                 else
9745                     i = (ewix ? ewix <= svmax : svix < svmax)
9746                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9747                 precis = i;
9748                 has_precis = !(i < 0);
9749             }
9750             else {
9751                 precis = 0;
9752                 while (isDIGIT(*q))
9753                     precis = precis * 10 + (*q++ - '0');
9754                 has_precis = TRUE;
9755             }
9756         }
9757
9758         /* SIZE */
9759
9760         switch (*q) {
9761 #ifdef WIN32
9762         case 'I':                       /* Ix, I32x, and I64x */
9763 #  ifdef WIN64
9764             if (q[1] == '6' && q[2] == '4') {
9765                 q += 3;
9766                 intsize = 'q';
9767                 break;
9768             }
9769 #  endif
9770             if (q[1] == '3' && q[2] == '2') {
9771                 q += 3;
9772                 break;
9773             }
9774 #  ifdef WIN64
9775             intsize = 'q';
9776 #  endif
9777             q++;
9778             break;
9779 #endif
9780 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9781         case 'L':                       /* Ld */
9782             /*FALLTHROUGH*/
9783 #ifdef HAS_QUAD
9784         case 'q':                       /* qd */
9785 #endif
9786             intsize = 'q';
9787             q++;
9788             break;
9789 #endif
9790         case 'l':
9791 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9792             if (*(q + 1) == 'l') {      /* lld, llf */
9793                 intsize = 'q';
9794                 q += 2;
9795                 break;
9796              }
9797 #endif
9798             /*FALLTHROUGH*/
9799         case 'h':
9800             /*FALLTHROUGH*/
9801         case 'V':
9802             intsize = *q++;
9803             break;
9804         }
9805
9806         /* CONVERSION */
9807
9808         if (*q == '%') {
9809             eptr = q++;
9810             elen = 1;
9811             if (vectorize) {
9812                 c = '%';
9813                 goto unknown;
9814             }
9815             goto string;
9816         }
9817
9818         if (!vectorize && !args) {
9819             if (efix) {
9820                 const I32 i = efix-1;
9821                 argsv = (i >= 0 && i < svmax)
9822                     ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
9823             } else {
9824                 argsv = (svix >= 0 && svix < svmax)
9825                     ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9826             }
9827         }
9828
9829         switch (c = *q++) {
9830
9831             /* STRINGS */
9832
9833         case 'c':
9834             if (vectorize)
9835                 goto unknown;
9836             uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9837             if ((uv > 255 ||
9838                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9839                 && !IN_BYTES) {
9840                 eptr = (char*)utf8buf;
9841                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9842                 is_utf8 = TRUE;
9843             }
9844             else {
9845                 c = (char)uv;
9846                 eptr = &c;
9847                 elen = 1;
9848             }
9849             goto string;
9850
9851         case 's':
9852             if (vectorize)
9853                 goto unknown;
9854             if (args) {
9855                 eptr = va_arg(*args, char*);
9856                 if (eptr)
9857                     elen = strlen(eptr);
9858                 else {
9859                     eptr = (char *)nullstr;
9860                     elen = sizeof nullstr - 1;
9861                 }
9862             }
9863             else {
9864                 eptr = SvPV_const(argsv, elen);
9865                 if (DO_UTF8(argsv)) {
9866                     STRLEN old_precis = precis;
9867                     if (has_precis && precis < elen) {
9868                         STRLEN ulen = sv_len_utf8(argsv);
9869                         I32 p = precis > ulen ? ulen : precis;
9870                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9871                         precis = p;
9872                     }
9873                     if (width) { /* fudge width (can't fudge elen) */
9874                         if (has_precis && precis < elen)
9875                             width += precis - old_precis;
9876                         else
9877                             width += elen - sv_len_utf8(argsv);
9878                     }
9879                     is_utf8 = TRUE;
9880                 }
9881             }
9882
9883         string:
9884             if (has_precis && precis < elen)
9885                 elen = precis;
9886             break;
9887
9888             /* INTEGERS */
9889
9890         case 'p':
9891             if (alt || vectorize)
9892                 goto unknown;
9893             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9894             base = 16;
9895             goto integer;
9896
9897         case 'D':
9898 #ifdef IV_IS_QUAD
9899             intsize = 'q';
9900 #else
9901             intsize = 'l';
9902 #endif
9903             /*FALLTHROUGH*/
9904         case 'd':
9905         case 'i':
9906 #if vdNUMBER
9907         format_vd:
9908 #endif
9909             if (vectorize) {
9910                 STRLEN ulen;
9911                 if (!veclen)
9912                     continue;
9913                 if (vec_utf8)
9914                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9915                                         UTF8_ALLOW_ANYUV);
9916                 else {
9917                     uv = *vecstr;
9918                     ulen = 1;
9919                 }
9920                 vecstr += ulen;
9921                 veclen -= ulen;
9922                 if (plus)
9923                      esignbuf[esignlen++] = plus;
9924             }
9925             else if (args) {
9926                 switch (intsize) {
9927                 case 'h':       iv = (short)va_arg(*args, int); break;
9928                 case 'l':       iv = va_arg(*args, long); break;
9929                 case 'V':       iv = va_arg(*args, IV); break;
9930                 default:        iv = va_arg(*args, int); break;
9931                 case 'q':
9932 #ifdef HAS_QUAD
9933                                 iv = va_arg(*args, Quad_t); break;
9934 #else
9935                                 goto unknown;
9936 #endif
9937                 }
9938             }
9939             else {
9940                 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9941                 switch (intsize) {
9942                 case 'h':       iv = (short)tiv; break;
9943                 case 'l':       iv = (long)tiv; break;
9944                 case 'V':
9945                 default:        iv = tiv; break;
9946                 case 'q':
9947 #ifdef HAS_QUAD
9948                                 iv = (Quad_t)tiv; break;
9949 #else
9950                                 goto unknown;
9951 #endif
9952                 }
9953             }
9954             if ( !vectorize )   /* we already set uv above */
9955             {
9956                 if (iv >= 0) {
9957                     uv = iv;
9958                     if (plus)
9959                         esignbuf[esignlen++] = plus;
9960                 }
9961                 else {
9962                     uv = -iv;
9963                     esignbuf[esignlen++] = '-';
9964                 }
9965             }
9966             base = 10;
9967             goto integer;
9968
9969         case 'U':
9970 #ifdef IV_IS_QUAD
9971             intsize = 'q';
9972 #else
9973             intsize = 'l';
9974 #endif
9975             /*FALLTHROUGH*/
9976         case 'u':
9977             base = 10;
9978             goto uns_integer;
9979
9980         case 'B':
9981         case 'b':
9982             base = 2;
9983             goto uns_integer;
9984
9985         case 'O':
9986 #ifdef IV_IS_QUAD
9987             intsize = 'q';
9988 #else
9989             intsize = 'l';
9990 #endif
9991             /*FALLTHROUGH*/
9992         case 'o':
9993             base = 8;
9994             goto uns_integer;
9995
9996         case 'X':
9997         case 'x':
9998             base = 16;
9999
10000         uns_integer:
10001             if (vectorize) {
10002                 STRLEN ulen;
10003         vector:
10004                 if (!veclen)
10005                     continue;
10006                 if (vec_utf8)
10007                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10008                                         UTF8_ALLOW_ANYUV);
10009                 else {
10010                     uv = *vecstr;
10011                     ulen = 1;
10012                 }
10013                 vecstr += ulen;
10014                 veclen -= ulen;
10015             }
10016             else if (args) {
10017                 switch (intsize) {
10018                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
10019                 case 'l':  uv = va_arg(*args, unsigned long); break;
10020                 case 'V':  uv = va_arg(*args, UV); break;
10021                 default:   uv = va_arg(*args, unsigned); break;
10022                 case 'q':
10023 #ifdef HAS_QUAD
10024                            uv = va_arg(*args, Uquad_t); break;
10025 #else
10026                            goto unknown;
10027 #endif
10028                 }
10029             }
10030             else {
10031                 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10032                 switch (intsize) {
10033                 case 'h':       uv = (unsigned short)tuv; break;
10034                 case 'l':       uv = (unsigned long)tuv; break;
10035                 case 'V':
10036                 default:        uv = tuv; break;
10037                 case 'q':
10038 #ifdef HAS_QUAD
10039                                 uv = (Uquad_t)tuv; break;
10040 #else
10041                                 goto unknown;
10042 #endif
10043                 }
10044             }
10045
10046         integer:
10047             {
10048                 char *ptr = ebuf + sizeof ebuf;
10049                 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10050                 zeros = 0;
10051
10052                 switch (base) {
10053                     unsigned dig;
10054                 case 16:
10055                     p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10056                     do {
10057                         dig = uv & 15;
10058                         *--ptr = p[dig];
10059                     } while (uv >>= 4);
10060                     if (tempalt) {
10061                         esignbuf[esignlen++] = '0';
10062                         esignbuf[esignlen++] = c;  /* 'x' or 'X' */
10063                     }
10064                     break;
10065                 case 8:
10066                     do {
10067                         dig = uv & 7;
10068                         *--ptr = '0' + dig;
10069                     } while (uv >>= 3);
10070                     if (alt && *ptr != '0')
10071                         *--ptr = '0';
10072                     break;
10073                 case 2:
10074                     do {
10075                         dig = uv & 1;
10076                         *--ptr = '0' + dig;
10077                     } while (uv >>= 1);
10078                     if (tempalt) {
10079                         esignbuf[esignlen++] = '0';
10080                         esignbuf[esignlen++] = c;
10081                     }
10082                     break;
10083                 default:                /* it had better be ten or less */
10084                     do {
10085                         dig = uv % base;
10086                         *--ptr = '0' + dig;
10087                     } while (uv /= base);
10088                     break;
10089                 }
10090                 elen = (ebuf + sizeof ebuf) - ptr;
10091                 eptr = ptr;
10092                 if (has_precis) {
10093                     if (precis > elen)
10094                         zeros = precis - elen;
10095                     else if (precis == 0 && elen == 1 && *eptr == '0'
10096                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10097                         elen = 0;
10098
10099                 /* a precision nullifies the 0 flag. */
10100                     if (fill == '0')
10101                         fill = ' ';
10102                 }
10103             }
10104             break;
10105
10106             /* FLOATING POINT */
10107
10108         case 'F':
10109             c = 'f';            /* maybe %F isn't supported here */
10110             /*FALLTHROUGH*/
10111         case 'e': case 'E':
10112         case 'f':
10113         case 'g': case 'G':
10114             if (vectorize)
10115                 goto unknown;
10116
10117             /* This is evil, but floating point is even more evil */
10118
10119             /* for SV-style calling, we can only get NV
10120                for C-style calling, we assume %f is double;
10121                for simplicity we allow any of %Lf, %llf, %qf for long double
10122             */
10123             switch (intsize) {
10124             case 'V':
10125 #if defined(USE_LONG_DOUBLE)
10126                 intsize = 'q';
10127 #endif
10128                 break;
10129 /* [perl #20339] - we should accept and ignore %lf rather than die */
10130             case 'l':
10131                 /*FALLTHROUGH*/
10132             default:
10133 #if defined(USE_LONG_DOUBLE)
10134                 intsize = args ? 0 : 'q';
10135 #endif
10136                 break;
10137             case 'q':
10138 #if defined(HAS_LONG_DOUBLE)
10139                 break;
10140 #else
10141                 /*FALLTHROUGH*/
10142 #endif
10143             case 'h':
10144                 goto unknown;
10145             }
10146
10147             /* now we need (long double) if intsize == 'q', else (double) */
10148             nv = (args) ?
10149 #if LONG_DOUBLESIZE > DOUBLESIZE
10150                 intsize == 'q' ?
10151                     va_arg(*args, long double) :
10152                     va_arg(*args, double)
10153 #else
10154                     va_arg(*args, double)
10155 #endif
10156                 : SvNV(argsv);
10157
10158             need = 0;
10159             /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10160                else. frexp() has some unspecified behaviour for those three */
10161             if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10162                 i = PERL_INT_MIN;
10163                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10164                    will cast our (long double) to (double) */
10165                 (void)Perl_frexp(nv, &i);
10166                 if (i == PERL_INT_MIN)
10167                     Perl_die(aTHX_ "panic: frexp");
10168                 if (i > 0)
10169                     need = BIT_DIGITS(i);
10170             }
10171             need += has_precis ? precis : 6; /* known default */
10172
10173             if (need < width)
10174                 need = width;
10175
10176 #ifdef HAS_LDBL_SPRINTF_BUG
10177             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10178                with sfio - Allen <allens@cpan.org> */
10179
10180 #  ifdef DBL_MAX
10181 #    define MY_DBL_MAX DBL_MAX
10182 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10183 #    if DOUBLESIZE >= 8
10184 #      define MY_DBL_MAX 1.7976931348623157E+308L
10185 #    else
10186 #      define MY_DBL_MAX 3.40282347E+38L
10187 #    endif
10188 #  endif
10189
10190 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10191 #    define MY_DBL_MAX_BUG 1L
10192 #  else
10193 #    define MY_DBL_MAX_BUG MY_DBL_MAX
10194 #  endif
10195
10196 #  ifdef DBL_MIN
10197 #    define MY_DBL_MIN DBL_MIN
10198 #  else  /* XXX guessing! -Allen */
10199 #    if DOUBLESIZE >= 8
10200 #      define MY_DBL_MIN 2.2250738585072014E-308L
10201 #    else
10202 #      define MY_DBL_MIN 1.17549435E-38L
10203 #    endif
10204 #  endif
10205
10206             if ((intsize == 'q') && (c == 'f') &&
10207                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10208                 (need < DBL_DIG)) {
10209                 /* it's going to be short enough that
10210                  * long double precision is not needed */
10211
10212                 if ((nv <= 0L) && (nv >= -0L))
10213                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10214                 else {
10215                     /* would use Perl_fp_class as a double-check but not
10216                      * functional on IRIX - see perl.h comments */
10217
10218                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10219                         /* It's within the range that a double can represent */
10220 #if defined(DBL_MAX) && !defined(DBL_MIN)
10221                         if ((nv >= ((long double)1/DBL_MAX)) ||
10222                             (nv <= (-(long double)1/DBL_MAX)))
10223 #endif
10224                         fix_ldbl_sprintf_bug = TRUE;
10225                     }
10226                 }
10227                 if (fix_ldbl_sprintf_bug == TRUE) {
10228                     double temp;
10229
10230                     intsize = 0;
10231                     temp = (double)nv;
10232                     nv = (NV)temp;
10233                 }
10234             }
10235
10236 #  undef MY_DBL_MAX
10237 #  undef MY_DBL_MAX_BUG
10238 #  undef MY_DBL_MIN
10239
10240 #endif /* HAS_LDBL_SPRINTF_BUG */
10241
10242             need += 20; /* fudge factor */
10243             if (PL_efloatsize < need) {
10244                 Safefree(PL_efloatbuf);
10245                 PL_efloatsize = need + 20; /* more fudge */
10246                 Newx(PL_efloatbuf, PL_efloatsize, char);
10247                 PL_efloatbuf[0] = '\0';
10248             }
10249
10250             if ( !(width || left || plus || alt) && fill != '0'
10251                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
10252                 /* See earlier comment about buggy Gconvert when digits,
10253                    aka precis is 0  */
10254                 if ( c == 'g' && precis) {
10255                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10256                     /* May return an empty string for digits==0 */
10257                     if (*PL_efloatbuf) {
10258                         elen = strlen(PL_efloatbuf);
10259                         goto float_converted;
10260                     }
10261                 } else if ( c == 'f' && !precis) {
10262                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10263                         break;
10264                 }
10265             }
10266             {
10267                 char *ptr = ebuf + sizeof ebuf;
10268                 *--ptr = '\0';
10269                 *--ptr = c;
10270                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10271 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10272                 if (intsize == 'q') {
10273                     /* Copy the one or more characters in a long double
10274                      * format before the 'base' ([efgEFG]) character to
10275                      * the format string. */
10276                     static char const prifldbl[] = PERL_PRIfldbl;
10277                     char const *p = prifldbl + sizeof(prifldbl) - 3;
10278                     while (p >= prifldbl) { *--ptr = *p--; }
10279                 }
10280 #endif
10281                 if (has_precis) {
10282                     base = precis;
10283                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10284                     *--ptr = '.';
10285                 }
10286                 if (width) {
10287                     base = width;
10288                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10289                 }
10290                 if (fill == '0')
10291                     *--ptr = fill;
10292                 if (left)
10293                     *--ptr = '-';
10294                 if (plus)
10295                     *--ptr = plus;
10296                 if (alt)
10297                     *--ptr = '#';
10298                 *--ptr = '%';
10299
10300                 /* No taint.  Otherwise we are in the strange situation
10301                  * where printf() taints but print($float) doesn't.
10302                  * --jhi */
10303 #if defined(HAS_LONG_DOUBLE)
10304                 elen = ((intsize == 'q')
10305                         ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10306                         : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10307 #else
10308                 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10309 #endif
10310             }
10311         float_converted:
10312             eptr = PL_efloatbuf;
10313             break;
10314
10315             /* SPECIAL */
10316
10317         case 'n':
10318             if (vectorize)
10319                 goto unknown;
10320             i = SvCUR(sv) - origlen;
10321             if (args) {
10322                 switch (intsize) {
10323                 case 'h':       *(va_arg(*args, short*)) = i; break;
10324                 default:        *(va_arg(*args, int*)) = i; break;
10325                 case 'l':       *(va_arg(*args, long*)) = i; break;
10326                 case 'V':       *(va_arg(*args, IV*)) = i; break;
10327                 case 'q':
10328 #ifdef HAS_QUAD
10329                                 *(va_arg(*args, Quad_t*)) = i; break;
10330 #else
10331                                 goto unknown;
10332 #endif
10333                 }
10334             }
10335             else
10336                 sv_setuv_mg(argsv, (UV)i);
10337             continue;   /* not "break" */
10338
10339             /* UNKNOWN */
10340
10341         default:
10342       unknown:
10343             if (!args
10344                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10345                 && ckWARN(WARN_PRINTF))
10346             {
10347                 SV * const msg = sv_newmortal();
10348                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10349                           (PL_op->op_type == OP_PRTF) ? "" : "s");
10350                 if (fmtstart < patend) {
10351                     const char * const fmtend = q < patend ? q : patend;
10352                     const char * f;
10353                     sv_catpvs(msg, "\"%");
10354                     for (f = fmtstart; f < fmtend; f++) {
10355                         if (isPRINT(*f)) {
10356                             sv_catpvn(msg, f, 1);
10357                         } else {
10358                             Perl_sv_catpvf(aTHX_ msg,
10359                                            "\\%03"UVof, (UV)*f & 0xFF);
10360                         }
10361                     }
10362                     sv_catpvs(msg, "\"");
10363                 } else {
10364                     sv_catpvs(msg, "end of string");
10365                 }
10366                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10367             }
10368
10369             /* output mangled stuff ... */
10370             if (c == '\0')
10371                 --q;
10372             eptr = p;
10373             elen = q - p;
10374
10375             /* ... right here, because formatting flags should not apply */
10376             SvGROW(sv, SvCUR(sv) + elen + 1);
10377             p = SvEND(sv);
10378             Copy(eptr, p, elen, char);
10379             p += elen;
10380             *p = '\0';
10381             SvCUR_set(sv, p - SvPVX_const(sv));
10382             svix = osvix;
10383             continue;   /* not "break" */
10384         }
10385
10386         if (is_utf8 != has_utf8) {
10387             if (is_utf8) {
10388                 if (SvCUR(sv))
10389                     sv_utf8_upgrade(sv);
10390             }
10391             else {
10392                 const STRLEN old_elen = elen;
10393                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10394                 sv_utf8_upgrade(nsv);
10395                 eptr = SvPVX_const(nsv);
10396                 elen = SvCUR(nsv);
10397
10398                 if (width) { /* fudge width (can't fudge elen) */
10399                     width += elen - old_elen;
10400                 }
10401                 is_utf8 = TRUE;
10402             }
10403         }
10404
10405         have = esignlen + zeros + elen;
10406         if (have < zeros)
10407             Perl_croak_nocontext("%s", PL_memory_wrap);
10408
10409         need = (have > width ? have : width);
10410         gap = need - have;
10411
10412         if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10413             Perl_croak_nocontext("%s", PL_memory_wrap);
10414         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10415         p = SvEND(sv);
10416         if (esignlen && fill == '0') {
10417             int i;
10418             for (i = 0; i < (int)esignlen; i++)
10419                 *p++ = esignbuf[i];
10420         }
10421         if (gap && !left) {
10422             memset(p, fill, gap);
10423             p += gap;
10424         }
10425         if (esignlen && fill != '0') {
10426             int i;
10427             for (i = 0; i < (int)esignlen; i++)
10428                 *p++ = esignbuf[i];
10429         }
10430         if (zeros) {
10431             int i;
10432             for (i = zeros; i; i--)
10433                 *p++ = '0';
10434         }
10435         if (elen) {
10436             Copy(eptr, p, elen, char);
10437             p += elen;
10438         }
10439         if (gap && left) {
10440             memset(p, ' ', gap);
10441             p += gap;
10442         }
10443         if (vectorize) {
10444             if (veclen) {
10445                 Copy(dotstr, p, dotstrlen, char);
10446                 p += dotstrlen;
10447             }
10448             else
10449                 vectorize = FALSE;              /* done iterating over vecstr */
10450         }
10451         if (is_utf8)
10452             has_utf8 = TRUE;
10453         if (has_utf8)
10454             SvUTF8_on(sv);
10455         *p = '\0';
10456         SvCUR_set(sv, p - SvPVX_const(sv));
10457         if (vectorize) {
10458             esignlen = 0;
10459             goto vector;
10460         }
10461     }
10462     SvTAINT(sv);
10463 }
10464
10465 /* =========================================================================
10466
10467 =head1 Cloning an interpreter
10468
10469 All the macros and functions in this section are for the private use of
10470 the main function, perl_clone().
10471
10472 The foo_dup() functions make an exact copy of an existing foo thingy.
10473 During the course of a cloning, a hash table is used to map old addresses
10474 to new addresses. The table is created and manipulated with the
10475 ptr_table_* functions.
10476
10477 =cut
10478
10479  * =========================================================================*/
10480
10481
10482 #if defined(USE_ITHREADS)
10483
10484 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10485 #ifndef GpREFCNT_inc
10486 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10487 #endif
10488
10489
10490 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10491    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10492    If this changes, please unmerge ss_dup.
10493    Likewise, sv_dup_inc_multiple() relies on this fact.  */
10494 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10495 #define sv_dup_inc_NN(s,t)      SvREFCNT_inc_NN(sv_dup(s,t))
10496 #define av_dup(s,t)     MUTABLE_AV(sv_dup((const SV *)s,t))
10497 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10498 #define hv_dup(s,t)     MUTABLE_HV(sv_dup((const SV *)s,t))
10499 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10500 #define cv_dup(s,t)     MUTABLE_CV(sv_dup((const SV *)s,t))
10501 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10502 #define io_dup(s,t)     MUTABLE_IO(sv_dup((const SV *)s,t))
10503 #define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10504 #define gv_dup(s,t)     MUTABLE_GV(sv_dup((const SV *)s,t))
10505 #define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10506 #define SAVEPV(p)       ((p) ? savepv(p) : NULL)
10507 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
10508
10509 /* clone a parser */
10510
10511 yy_parser *
10512 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10513 {
10514     yy_parser *parser;
10515
10516     PERL_ARGS_ASSERT_PARSER_DUP;
10517
10518     if (!proto)
10519         return NULL;
10520
10521     /* look for it in the table first */
10522     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10523     if (parser)
10524         return parser;
10525
10526     /* create anew and remember what it is */
10527     Newxz(parser, 1, yy_parser);
10528     ptr_table_store(PL_ptr_table, proto, parser);
10529
10530     parser->yyerrstatus = 0;
10531     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
10532
10533     /* XXX these not yet duped */
10534     parser->old_parser = NULL;
10535     parser->stack = NULL;
10536     parser->ps = NULL;
10537     parser->stack_size = 0;
10538     /* XXX parser->stack->state = 0; */
10539
10540     /* XXX eventually, just Copy() most of the parser struct ? */
10541
10542     parser->lex_brackets = proto->lex_brackets;
10543     parser->lex_casemods = proto->lex_casemods;
10544     parser->lex_brackstack = savepvn(proto->lex_brackstack,
10545                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10546     parser->lex_casestack = savepvn(proto->lex_casestack,
10547                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10548     parser->lex_defer   = proto->lex_defer;
10549     parser->lex_dojoin  = proto->lex_dojoin;
10550     parser->lex_expect  = proto->lex_expect;
10551     parser->lex_formbrack = proto->lex_formbrack;
10552     parser->lex_inpat   = proto->lex_inpat;
10553     parser->lex_inwhat  = proto->lex_inwhat;
10554     parser->lex_op      = proto->lex_op;
10555     parser->lex_repl    = sv_dup_inc(proto->lex_repl, param);
10556     parser->lex_starts  = proto->lex_starts;
10557     parser->lex_stuff   = sv_dup_inc(proto->lex_stuff, param);
10558     parser->multi_close = proto->multi_close;
10559     parser->multi_open  = proto->multi_open;
10560     parser->multi_start = proto->multi_start;
10561     parser->multi_end   = proto->multi_end;
10562     parser->pending_ident = proto->pending_ident;
10563     parser->preambled   = proto->preambled;
10564     parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10565     parser->linestr     = sv_dup_inc(proto->linestr, param);
10566     parser->expect      = proto->expect;
10567     parser->copline     = proto->copline;
10568     parser->last_lop_op = proto->last_lop_op;
10569     parser->lex_state   = proto->lex_state;
10570     parser->rsfp        = fp_dup(proto->rsfp, '<', param);
10571     /* rsfp_filters entries have fake IoDIRP() */
10572     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10573     parser->in_my       = proto->in_my;
10574     parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10575     parser->error_count = proto->error_count;
10576
10577
10578     parser->linestr     = sv_dup_inc(proto->linestr, param);
10579
10580     {
10581         char * const ols = SvPVX(proto->linestr);
10582         char * const ls  = SvPVX(parser->linestr);
10583
10584         parser->bufptr      = ls + (proto->bufptr >= ols ?
10585                                     proto->bufptr -  ols : 0);
10586         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
10587                                     proto->oldbufptr -  ols : 0);
10588         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10589                                     proto->oldoldbufptr -  ols : 0);
10590         parser->linestart   = ls + (proto->linestart >= ols ?
10591                                     proto->linestart -  ols : 0);
10592         parser->last_uni    = ls + (proto->last_uni >= ols ?
10593                                     proto->last_uni -  ols : 0);
10594         parser->last_lop    = ls + (proto->last_lop >= ols ?
10595                                     proto->last_lop -  ols : 0);
10596
10597         parser->bufend      = ls + SvCUR(parser->linestr);
10598     }
10599
10600     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10601
10602
10603 #ifdef PERL_MAD
10604     parser->endwhite    = proto->endwhite;
10605     parser->faketokens  = proto->faketokens;
10606     parser->lasttoke    = proto->lasttoke;
10607     parser->nextwhite   = proto->nextwhite;
10608     parser->realtokenstart = proto->realtokenstart;
10609     parser->skipwhite   = proto->skipwhite;
10610     parser->thisclose   = proto->thisclose;
10611     parser->thismad     = proto->thismad;
10612     parser->thisopen    = proto->thisopen;
10613     parser->thisstuff   = proto->thisstuff;
10614     parser->thistoken   = proto->thistoken;
10615     parser->thiswhite   = proto->thiswhite;
10616
10617     Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10618     parser->curforce    = proto->curforce;
10619 #else
10620     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10621     Copy(proto->nexttype, parser->nexttype, 5,  I32);
10622     parser->nexttoke    = proto->nexttoke;
10623 #endif
10624
10625     /* XXX should clone saved_curcop here, but we aren't passed
10626      * proto_perl; so do it in perl_clone_using instead */
10627
10628     return parser;
10629 }
10630
10631
10632 /* duplicate a file handle */
10633
10634 PerlIO *
10635 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10636 {
10637     PerlIO *ret;
10638
10639     PERL_ARGS_ASSERT_FP_DUP;
10640     PERL_UNUSED_ARG(type);
10641
10642     if (!fp)
10643         return (PerlIO*)NULL;
10644
10645     /* look for it in the table first */
10646     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10647     if (ret)
10648         return ret;
10649
10650     /* create anew and remember what it is */
10651     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10652     ptr_table_store(PL_ptr_table, fp, ret);
10653     return ret;
10654 }
10655
10656 /* duplicate a directory handle */
10657
10658 DIR *
10659 Perl_dirp_dup(pTHX_ DIR *const dp)
10660 {
10661     PERL_UNUSED_CONTEXT;
10662     if (!dp)
10663         return (DIR*)NULL;
10664     /* XXX TODO */
10665     return dp;
10666 }
10667
10668 /* duplicate a typeglob */
10669
10670 GP *
10671 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10672 {
10673     GP *ret;
10674
10675     PERL_ARGS_ASSERT_GP_DUP;
10676
10677     if (!gp)
10678         return (GP*)NULL;
10679     /* look for it in the table first */
10680     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10681     if (ret)
10682         return ret;
10683
10684     /* create anew and remember what it is */
10685     Newxz(ret, 1, GP);
10686     ptr_table_store(PL_ptr_table, gp, ret);
10687
10688     /* clone */
10689     /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
10690        on Newxz() to do this for us.  */
10691     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
10692     ret->gp_io          = io_dup_inc(gp->gp_io, param);
10693     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
10694     ret->gp_av          = av_dup_inc(gp->gp_av, param);
10695     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
10696     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10697     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
10698     ret->gp_cvgen       = gp->gp_cvgen;
10699     ret->gp_line        = gp->gp_line;
10700     ret->gp_file_hek    = hek_dup(gp->gp_file_hek, param);
10701     return ret;
10702 }
10703
10704 /* duplicate a chain of magic */
10705
10706 MAGIC *
10707 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10708 {
10709     MAGIC *mgret = NULL;
10710     MAGIC **mgprev_p = &mgret;
10711
10712     PERL_ARGS_ASSERT_MG_DUP;
10713
10714     for (; mg; mg = mg->mg_moremagic) {
10715         MAGIC *nmg;
10716         Newx(nmg, 1, MAGIC);
10717         *mgprev_p = nmg;
10718         mgprev_p = &(nmg->mg_moremagic);
10719
10720         /* There was a comment "XXX copy dynamic vtable?" but as we don't have
10721            dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
10722            from the original commit adding Perl_mg_dup() - revision 4538.
10723            Similarly there is the annotation "XXX random ptr?" next to the
10724            assignment to nmg->mg_ptr.  */
10725         *nmg = *mg;
10726
10727         /* FIXME for plugins
10728         if (nmg->mg_type == PERL_MAGIC_qr) {
10729             nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
10730         }
10731         else
10732         */
10733         if(nmg->mg_type == PERL_MAGIC_backref) {
10734             /* The backref AV has its reference count deliberately bumped by
10735                1.  */
10736             nmg->mg_obj
10737                 = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param));
10738         }
10739         else {
10740             nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
10741                               ? sv_dup_inc(nmg->mg_obj, param)
10742                               : sv_dup(nmg->mg_obj, param);
10743         }
10744
10745         if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
10746             if (nmg->mg_len > 0) {
10747                 nmg->mg_ptr     = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
10748                 if (nmg->mg_type == PERL_MAGIC_overload_table &&
10749                         AMT_AMAGIC((AMT*)nmg->mg_ptr))
10750                 {
10751                     AMT * const namtp = (AMT*)nmg->mg_ptr;
10752                     sv_dup_inc_multiple((SV**)(namtp->table),
10753                                         (SV**)(namtp->table), NofAMmeth, param);
10754                 }
10755             }
10756             else if (nmg->mg_len == HEf_SVKEY)
10757                 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
10758         }
10759         if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
10760             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10761         }
10762     }
10763     return mgret;
10764 }
10765
10766 #endif /* USE_ITHREADS */
10767
10768 struct ptr_tbl_arena {
10769     struct ptr_tbl_arena *next;
10770     struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers.  */
10771 };
10772
10773 /* create a new pointer-mapping table */
10774
10775 PTR_TBL_t *
10776 Perl_ptr_table_new(pTHX)
10777 {
10778     PTR_TBL_t *tbl;
10779     PERL_UNUSED_CONTEXT;
10780
10781     Newx(tbl, 1, PTR_TBL_t);
10782     tbl->tbl_max        = 511;
10783     tbl->tbl_items      = 0;
10784     tbl->tbl_arena      = NULL;
10785     tbl->tbl_arena_next = NULL;
10786     tbl->tbl_arena_end  = NULL;
10787     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10788     return tbl;
10789 }
10790
10791 #define PTR_TABLE_HASH(ptr) \
10792   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10793
10794 /* map an existing pointer using a table */
10795
10796 STATIC PTR_TBL_ENT_t *
10797 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10798 {
10799     PTR_TBL_ENT_t *tblent;
10800     const UV hash = PTR_TABLE_HASH(sv);
10801
10802     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10803
10804     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10805     for (; tblent; tblent = tblent->next) {
10806         if (tblent->oldval == sv)
10807             return tblent;
10808     }
10809     return NULL;
10810 }
10811
10812 void *
10813 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10814 {
10815     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10816
10817     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10818     PERL_UNUSED_CONTEXT;
10819
10820     return tblent ? tblent->newval : NULL;
10821 }
10822
10823 /* add a new entry to a pointer-mapping table */
10824
10825 void
10826 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10827 {
10828     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10829
10830     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10831     PERL_UNUSED_CONTEXT;
10832
10833     if (tblent) {
10834         tblent->newval = newsv;
10835     } else {
10836         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10837
10838         if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
10839             struct ptr_tbl_arena *new_arena;
10840
10841             Newx(new_arena, 1, struct ptr_tbl_arena);
10842             new_arena->next = tbl->tbl_arena;
10843             tbl->tbl_arena = new_arena;
10844             tbl->tbl_arena_next = new_arena->array;
10845             tbl->tbl_arena_end = new_arena->array
10846                 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
10847         }
10848
10849         tblent = tbl->tbl_arena_next++;
10850
10851         tblent->oldval = oldsv;
10852         tblent->newval = newsv;
10853         tblent->next = tbl->tbl_ary[entry];
10854         tbl->tbl_ary[entry] = tblent;
10855         tbl->tbl_items++;
10856         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10857             ptr_table_split(tbl);
10858     }
10859 }
10860
10861 /* double the hash bucket size of an existing ptr table */
10862
10863 void
10864 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10865 {
10866     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10867     const UV oldsize = tbl->tbl_max + 1;
10868     UV newsize = oldsize * 2;
10869     UV i;
10870
10871     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10872     PERL_UNUSED_CONTEXT;
10873
10874     Renew(ary, newsize, PTR_TBL_ENT_t*);
10875     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10876     tbl->tbl_max = --newsize;
10877     tbl->tbl_ary = ary;
10878     for (i=0; i < oldsize; i++, ary++) {
10879         PTR_TBL_ENT_t **curentp, **entp, *ent;
10880         if (!*ary)
10881             continue;
10882         curentp = ary + oldsize;
10883         for (entp = ary, ent = *ary; ent; ent = *entp) {
10884             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10885                 *entp = ent->next;
10886                 ent->next = *curentp;
10887                 *curentp = ent;
10888                 continue;
10889             }
10890             else
10891                 entp = &ent->next;
10892         }
10893     }
10894 }
10895
10896 /* remove all the entries from a ptr table */
10897 /* Deprecated - will be removed post 5.14 */
10898
10899 void
10900 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10901 {
10902     if (tbl && tbl->tbl_items) {
10903         struct ptr_tbl_arena *arena = tbl->tbl_arena;
10904
10905         Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
10906
10907         while (arena) {
10908             struct ptr_tbl_arena *next = arena->next;
10909
10910             Safefree(arena);
10911             arena = next;
10912         };
10913
10914         tbl->tbl_items = 0;
10915         tbl->tbl_arena = NULL;
10916         tbl->tbl_arena_next = NULL;
10917         tbl->tbl_arena_end = NULL;
10918     }
10919 }
10920
10921 /* clear and free a ptr table */
10922
10923 void
10924 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10925 {
10926     struct ptr_tbl_arena *arena;
10927
10928     if (!tbl) {
10929         return;
10930     }
10931
10932     arena = tbl->tbl_arena;
10933
10934     while (arena) {
10935         struct ptr_tbl_arena *next = arena->next;
10936
10937         Safefree(arena);
10938         arena = next;
10939     }
10940
10941     Safefree(tbl->tbl_ary);
10942     Safefree(tbl);
10943 }
10944
10945 #if defined(USE_ITHREADS)
10946
10947 void
10948 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10949 {
10950     PERL_ARGS_ASSERT_RVPV_DUP;
10951
10952     if (SvROK(sstr)) {
10953         SvRV_set(dstr, SvWEAKREF(sstr)
10954                        ? sv_dup(SvRV_const(sstr), param)
10955                        : sv_dup_inc(SvRV_const(sstr), param));
10956
10957     }
10958     else if (SvPVX_const(sstr)) {
10959         /* Has something there */
10960         if (SvLEN(sstr)) {
10961             /* Normal PV - clone whole allocated space */
10962             SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10963             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10964                 /* Not that normal - actually sstr is copy on write.
10965                    But we are a true, independant SV, so:  */
10966                 SvREADONLY_off(dstr);
10967                 SvFAKE_off(dstr);
10968             }
10969         }
10970         else {
10971             /* Special case - not normally malloced for some reason */
10972             if (isGV_with_GP(sstr)) {
10973                 /* Don't need to do anything here.  */
10974             }
10975             else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10976                 /* A "shared" PV - clone it as "shared" PV */
10977                 SvPV_set(dstr,
10978                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10979                                          param)));
10980             }
10981             else {
10982                 /* Some other special case - random pointer */
10983                 SvPV_set(dstr, (char *) SvPVX_const(sstr));
10984             }
10985         }
10986     }
10987     else {
10988         /* Copy the NULL */
10989         SvPV_set(dstr, NULL);
10990     }
10991 }
10992
10993 /* duplicate a list of SVs. source and dest may point to the same memory.  */
10994 static SV **
10995 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
10996                       SSize_t items, CLONE_PARAMS *const param)
10997 {
10998     PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
10999
11000     while (items-- > 0) {
11001         *dest++ = sv_dup_inc(*source++, param);
11002     }
11003
11004     return dest;
11005 }
11006
11007 /* duplicate an SV of any type (including AV, HV etc) */
11008
11009 SV *
11010 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11011 {
11012     dVAR;
11013     SV *dstr;
11014
11015     PERL_ARGS_ASSERT_SV_DUP;
11016
11017     if (!sstr)
11018         return NULL;
11019     if (SvTYPE(sstr) == SVTYPEMASK) {
11020 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11021         abort();
11022 #endif
11023         return NULL;
11024     }
11025     /* look for it in the table first */
11026     dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11027     if (dstr)
11028         return dstr;
11029
11030     if(param->flags & CLONEf_JOIN_IN) {
11031         /** We are joining here so we don't want do clone
11032             something that is bad **/
11033         if (SvTYPE(sstr) == SVt_PVHV) {
11034             const HEK * const hvname = HvNAME_HEK(sstr);
11035             if (hvname)
11036                 /** don't clone stashes if they already exist **/
11037                 return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
11038         }
11039     }
11040
11041     /* create anew and remember what it is */
11042     new_SV(dstr);
11043
11044 #ifdef DEBUG_LEAKING_SCALARS
11045     dstr->sv_debug_optype = sstr->sv_debug_optype;
11046     dstr->sv_debug_line = sstr->sv_debug_line;
11047     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11048     dstr->sv_debug_cloned = 1;
11049     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11050 #endif
11051
11052     ptr_table_store(PL_ptr_table, sstr, dstr);
11053
11054     /* clone */
11055     SvFLAGS(dstr)       = SvFLAGS(sstr);
11056     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
11057     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
11058
11059 #ifdef DEBUGGING
11060     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11061         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11062                       (void*)PL_watch_pvx, SvPVX_const(sstr));
11063 #endif
11064
11065     /* don't clone objects whose class has asked us not to */
11066     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11067         SvFLAGS(dstr) = 0;
11068         return dstr;
11069     }
11070
11071     switch (SvTYPE(sstr)) {
11072     case SVt_NULL:
11073         SvANY(dstr)     = NULL;
11074         break;
11075     case SVt_IV:
11076         SvANY(dstr)     = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11077         if(SvROK(sstr)) {
11078             Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11079         } else {
11080             SvIV_set(dstr, SvIVX(sstr));
11081         }
11082         break;
11083     case SVt_NV:
11084         SvANY(dstr)     = new_XNV();
11085         SvNV_set(dstr, SvNVX(sstr));
11086         break;
11087         /* case SVt_BIND: */
11088     default:
11089         {
11090             /* These are all the types that need complex bodies allocating.  */
11091             void *new_body;
11092             const svtype sv_type = SvTYPE(sstr);
11093             const struct body_details *const sv_type_details
11094                 = bodies_by_type + sv_type;
11095
11096             switch (sv_type) {
11097             default:
11098                 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11099                 break;
11100
11101             case SVt_PVGV:
11102             case SVt_PVIO:
11103             case SVt_PVFM:
11104             case SVt_PVHV:
11105             case SVt_PVAV:
11106             case SVt_PVCV:
11107             case SVt_PVLV:
11108             case SVt_REGEXP:
11109             case SVt_PVMG:
11110             case SVt_PVNV:
11111             case SVt_PVIV:
11112             case SVt_PV:
11113                 assert(sv_type_details->body_size);
11114                 if (sv_type_details->arena) {
11115                     new_body_inline(new_body, sv_type);
11116                     new_body
11117                         = (void*)((char*)new_body - sv_type_details->offset);
11118                 } else {
11119                     new_body = new_NOARENA(sv_type_details);
11120                 }
11121             }
11122             assert(new_body);
11123             SvANY(dstr) = new_body;
11124
11125 #ifndef PURIFY
11126             Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11127                  ((char*)SvANY(dstr)) + sv_type_details->offset,
11128                  sv_type_details->copy, char);
11129 #else
11130             Copy(((char*)SvANY(sstr)),
11131                  ((char*)SvANY(dstr)),
11132                  sv_type_details->body_size + sv_type_details->offset, char);
11133 #endif
11134
11135             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11136                 && !isGV_with_GP(dstr))
11137                 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11138
11139             /* The Copy above means that all the source (unduplicated) pointers
11140                are now in the destination.  We can check the flags and the
11141                pointers in either, but it's possible that there's less cache
11142                missing by always going for the destination.
11143                FIXME - instrument and check that assumption  */
11144             if (sv_type >= SVt_PVMG) {
11145                 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11146                     SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11147                 } else if (SvMAGIC(dstr))
11148                     SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11149                 if (SvSTASH(dstr))
11150                     SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11151             }
11152
11153             /* The cast silences a GCC warning about unhandled types.  */
11154             switch ((int)sv_type) {
11155             case SVt_PV:
11156                 break;
11157             case SVt_PVIV:
11158                 break;
11159             case SVt_PVNV:
11160                 break;
11161             case SVt_PVMG:
11162                 break;
11163             case SVt_REGEXP:
11164                 /* FIXME for plugins */
11165                 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11166                 break;
11167             case SVt_PVLV:
11168                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11169                 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11170                     LvTARG(dstr) = dstr;
11171                 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11172                     LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11173                 else
11174                     LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11175             case SVt_PVGV:
11176                 if(isGV_with_GP(sstr)) {
11177                     GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11178                     /* Don't call sv_add_backref here as it's going to be
11179                        created as part of the magic cloning of the symbol
11180                        table--unless this is during a join and the stash
11181                        is not actually being cloned.  */
11182                     /* Danger Will Robinson - GvGP(dstr) isn't initialised
11183                        at the point of this comment.  */
11184                     GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11185                     if(param->flags & CLONEf_JOIN_IN) {
11186                         const HEK * const hvname
11187                          = HvNAME_HEK(GvSTASH(dstr));
11188                         if( hvname
11189                          && GvSTASH(dstr) == gv_stashpvn(
11190                              HEK_KEY(hvname), HEK_LEN(hvname), 0
11191                             )
11192                           )
11193                             Perl_sv_add_backref(
11194                              aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr
11195                             );
11196                     }
11197                     GvGP(dstr)  = gp_dup(GvGP(sstr), param);
11198                     (void)GpREFCNT_inc(GvGP(dstr));
11199                 } else
11200                     Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11201                 break;
11202             case SVt_PVIO:
11203                 IoIFP(dstr)     = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
11204                 if (IoOFP(dstr) == IoIFP(sstr))
11205                     IoOFP(dstr) = IoIFP(dstr);
11206                 else
11207                     IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11208                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11209                 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11210                     /* I have no idea why fake dirp (rsfps)
11211                        should be treated differently but otherwise
11212                        we end up with leaks -- sky*/
11213                     IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
11214                     IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
11215                     IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11216                 } else {
11217                     IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
11218                     IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
11219                     IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
11220                     if (IoDIRP(dstr)) {
11221                         IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr));
11222                     } else {
11223                         NOOP;
11224                         /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
11225                     }
11226                 }
11227                 IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
11228                 IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
11229                 IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
11230                 break;
11231             case SVt_PVAV:
11232                 /* avoid cloning an empty array */
11233                 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11234                     SV **dst_ary, **src_ary;
11235                     SSize_t items = AvFILLp((const AV *)sstr) + 1;
11236
11237                     src_ary = AvARRAY((const AV *)sstr);
11238                     Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11239                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11240                     AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11241                     AvALLOC((const AV *)dstr) = dst_ary;
11242                     if (AvREAL((const AV *)sstr)) {
11243                         dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11244                                                       param);
11245                     }
11246                     else {
11247                         while (items-- > 0)
11248                             *dst_ary++ = sv_dup(*src_ary++, param);
11249                         if (!(param->flags & CLONEf_COPY_STACKS)
11250                              && AvREIFY(sstr))
11251                         {
11252                             av_reify(MUTABLE_AV(dstr)); /* #41138 */
11253                         }
11254                     }
11255                     items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11256                     while (items-- > 0) {
11257                         *dst_ary++ = &PL_sv_undef;
11258                     }
11259                 }
11260                 else {
11261                     AvARRAY(MUTABLE_AV(dstr))   = NULL;
11262                     AvALLOC((const AV *)dstr)   = (SV**)NULL;
11263                     AvMAX(  (const AV *)dstr)   = -1;
11264                     AvFILLp((const AV *)dstr)   = -1;
11265                 }
11266                 break;
11267             case SVt_PVHV:
11268                 if (HvARRAY((const HV *)sstr)) {
11269                     STRLEN i = 0;
11270                     const bool sharekeys = !!HvSHAREKEYS(sstr);
11271                     XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11272                     XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11273                     char *darray;
11274                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11275                         + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11276                         char);
11277                     HvARRAY(dstr) = (HE**)darray;
11278                     while (i <= sxhv->xhv_max) {
11279                         const HE * const source = HvARRAY(sstr)[i];
11280                         HvARRAY(dstr)[i] = source
11281                             ? he_dup(source, sharekeys, param) : 0;
11282                         ++i;
11283                     }
11284                     if (SvOOK(sstr)) {
11285                         HEK *hvname;
11286                         const struct xpvhv_aux * const saux = HvAUX(sstr);
11287                         struct xpvhv_aux * const daux = HvAUX(dstr);
11288                         /* This flag isn't copied.  */
11289                         /* SvOOK_on(hv) attacks the IV flags.  */
11290                         SvFLAGS(dstr) |= SVf_OOK;
11291
11292                         hvname = saux->xhv_name;
11293                         daux->xhv_name = hek_dup(hvname, param);
11294
11295                         daux->xhv_riter = saux->xhv_riter;
11296                         daux->xhv_eiter = saux->xhv_eiter
11297                             ? he_dup(saux->xhv_eiter,
11298                                         cBOOL(HvSHAREKEYS(sstr)), param) : 0;
11299                         /* backref array needs refcnt=2; see sv_add_backref */
11300                         daux->xhv_backreferences =
11301                             saux->xhv_backreferences
11302                             ? MUTABLE_AV(SvREFCNT_inc(
11303                                                       sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
11304                                 : 0;
11305
11306                         daux->xhv_mro_meta = saux->xhv_mro_meta
11307                             ? mro_meta_dup(saux->xhv_mro_meta, param)
11308                             : 0;
11309
11310                         /* Record stashes for possible cloning in Perl_clone(). */
11311                         if (hvname)
11312                             av_push(param->stashes, dstr);
11313                     }
11314                 }
11315                 else
11316                     HvARRAY(MUTABLE_HV(dstr)) = NULL;
11317                 break;
11318             case SVt_PVCV:
11319                 if (!(param->flags & CLONEf_COPY_STACKS)) {
11320                     CvDEPTH(dstr) = 0;
11321                 }
11322             case SVt_PVFM:
11323                 /* NOTE: not refcounted */
11324                 CvSTASH(dstr)   = hv_dup(CvSTASH(dstr), param);
11325                 OP_REFCNT_LOCK;
11326                 if (!CvISXSUB(dstr))
11327                     CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11328                 OP_REFCNT_UNLOCK;
11329                 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11330                     CvXSUBANY(dstr).any_ptr =
11331                         sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11332                 }
11333                 /* don't dup if copying back - CvGV isn't refcounted, so the
11334                  * duped GV may never be freed. A bit of a hack! DAPM */
11335                 CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
11336                     NULL : gv_dup(CvGV(dstr), param) ;
11337                 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11338                 CvOUTSIDE(dstr) =
11339                     CvWEAKOUTSIDE(sstr)
11340                     ? cv_dup(    CvOUTSIDE(dstr), param)
11341                     : cv_dup_inc(CvOUTSIDE(dstr), param);
11342                 if (!CvISXSUB(dstr))
11343                     CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11344                 break;
11345             }
11346         }
11347     }
11348
11349     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11350         ++PL_sv_objcount;
11351
11352     return dstr;
11353  }
11354
11355 /* duplicate a context */
11356
11357 PERL_CONTEXT *
11358 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11359 {
11360     PERL_CONTEXT *ncxs;
11361
11362     PERL_ARGS_ASSERT_CX_DUP;
11363
11364     if (!cxs)
11365         return (PERL_CONTEXT*)NULL;
11366
11367     /* look for it in the table first */
11368     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11369     if (ncxs)
11370         return ncxs;
11371
11372     /* create anew and remember what it is */
11373     Newx(ncxs, max + 1, PERL_CONTEXT);
11374     ptr_table_store(PL_ptr_table, cxs, ncxs);
11375     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11376
11377     while (ix >= 0) {
11378         PERL_CONTEXT * const ncx = &ncxs[ix];
11379         if (CxTYPE(ncx) == CXt_SUBST) {
11380             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11381         }
11382         else {
11383             switch (CxTYPE(ncx)) {
11384             case CXt_SUB:
11385                 ncx->blk_sub.cv         = (ncx->blk_sub.olddepth == 0
11386                                            ? cv_dup_inc(ncx->blk_sub.cv, param)
11387                                            : cv_dup(ncx->blk_sub.cv,param));
11388                 ncx->blk_sub.argarray   = (CxHASARGS(ncx)
11389                                            ? av_dup_inc(ncx->blk_sub.argarray,
11390                                                         param)
11391                                            : NULL);
11392                 ncx->blk_sub.savearray  = av_dup_inc(ncx->blk_sub.savearray,
11393                                                      param);
11394                 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11395                                            ncx->blk_sub.oldcomppad);
11396                 break;
11397             case CXt_EVAL:
11398                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11399                                                       param);
11400                 ncx->blk_eval.cur_text  = sv_dup(ncx->blk_eval.cur_text, param);
11401                 break;
11402             case CXt_LOOP_LAZYSV:
11403                 ncx->blk_loop.state_u.lazysv.end
11404                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11405                 /* We are taking advantage of av_dup_inc and sv_dup_inc
11406                    actually being the same function, and order equivalance of
11407                    the two unions.
11408                    We can assert the later [but only at run time :-(]  */
11409                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11410                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
11411             case CXt_LOOP_FOR:
11412                 ncx->blk_loop.state_u.ary.ary
11413                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11414             case CXt_LOOP_LAZYIV:
11415             case CXt_LOOP_PLAIN:
11416                 if (CxPADLOOP(ncx)) {
11417                     ncx->blk_loop.oldcomppad
11418                         = (PAD*)ptr_table_fetch(PL_ptr_table,
11419                                                 ncx->blk_loop.oldcomppad);
11420                 } else {
11421                     ncx->blk_loop.oldcomppad
11422                         = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
11423                                        param);
11424                 }
11425                 break;
11426             case CXt_FORMAT:
11427                 ncx->blk_format.cv      = cv_dup(ncx->blk_format.cv, param);
11428                 ncx->blk_format.gv      = gv_dup(ncx->blk_format.gv, param);
11429                 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11430                                                      param);
11431                 break;
11432             case CXt_BLOCK:
11433             case CXt_NULL:
11434                 break;
11435             }
11436         }
11437         --ix;
11438     }
11439     return ncxs;
11440 }
11441
11442 /* duplicate a stack info structure */
11443
11444 PERL_SI *
11445 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11446 {
11447     PERL_SI *nsi;
11448
11449     PERL_ARGS_ASSERT_SI_DUP;
11450
11451     if (!si)
11452         return (PERL_SI*)NULL;
11453
11454     /* look for it in the table first */
11455     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11456     if (nsi)
11457         return nsi;
11458
11459     /* create anew and remember what it is */
11460     Newxz(nsi, 1, PERL_SI);
11461     ptr_table_store(PL_ptr_table, si, nsi);
11462
11463     nsi->si_stack       = av_dup_inc(si->si_stack, param);
11464     nsi->si_cxix        = si->si_cxix;
11465     nsi->si_cxmax       = si->si_cxmax;
11466     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11467     nsi->si_type        = si->si_type;
11468     nsi->si_prev        = si_dup(si->si_prev, param);
11469     nsi->si_next        = si_dup(si->si_next, param);
11470     nsi->si_markoff     = si->si_markoff;
11471
11472     return nsi;
11473 }
11474
11475 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
11476 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
11477 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
11478 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
11479 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
11480 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
11481 #define POPUV(ss,ix)    ((ss)[--(ix)].any_uv)
11482 #define TOPUV(ss,ix)    ((ss)[ix].any_uv)
11483 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
11484 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
11485 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
11486 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
11487 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
11488 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
11489 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11490 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11491
11492 /* XXXXX todo */
11493 #define pv_dup_inc(p)   SAVEPV(p)
11494 #define pv_dup(p)       SAVEPV(p)
11495 #define svp_dup_inc(p,pp)       any_dup(p,pp)
11496
11497 /* map any object to the new equivent - either something in the
11498  * ptr table, or something in the interpreter structure
11499  */
11500
11501 void *
11502 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11503 {
11504     void *ret;
11505
11506     PERL_ARGS_ASSERT_ANY_DUP;
11507
11508     if (!v)
11509         return (void*)NULL;
11510
11511     /* look for it in the table first */
11512     ret = ptr_table_fetch(PL_ptr_table, v);
11513     if (ret)
11514         return ret;
11515
11516     /* see if it is part of the interpreter structure */
11517     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11518         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11519     else {
11520         ret = v;
11521     }
11522
11523     return ret;
11524 }
11525
11526 /* duplicate the save stack */
11527
11528 ANY *
11529 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11530 {
11531     dVAR;
11532     ANY * const ss      = proto_perl->Isavestack;
11533     const I32 max       = proto_perl->Isavestack_max;
11534     I32 ix              = proto_perl->Isavestack_ix;
11535     ANY *nss;
11536     const SV *sv;
11537     const GV *gv;
11538     const AV *av;
11539     const HV *hv;
11540     void* ptr;
11541     int intval;
11542     long longval;
11543     GP *gp;
11544     IV iv;
11545     I32 i;
11546     char *c = NULL;
11547     void (*dptr) (void*);
11548     void (*dxptr) (pTHX_ void*);
11549
11550     PERL_ARGS_ASSERT_SS_DUP;
11551
11552     Newxz(nss, max, ANY);
11553
11554     while (ix > 0) {
11555         const UV uv = POPUV(ss,ix);
11556         const U8 type = (U8)uv & SAVE_MASK;
11557
11558         TOPUV(nss,ix) = uv;
11559         switch (type) {
11560         case SAVEt_CLEARSV:
11561             break;
11562         case SAVEt_HELEM:               /* hash element */
11563             sv = (const SV *)POPPTR(ss,ix);
11564             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11565             /* fall through */
11566         case SAVEt_ITEM:                        /* normal string */
11567         case SAVEt_SV:                          /* scalar reference */
11568             sv = (const SV *)POPPTR(ss,ix);
11569             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11570             /* fall through */
11571         case SAVEt_FREESV:
11572         case SAVEt_MORTALIZESV:
11573             sv = (const SV *)POPPTR(ss,ix);
11574             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11575             break;
11576         case SAVEt_SHARED_PVREF:                /* char* in shared space */
11577             c = (char*)POPPTR(ss,ix);
11578             TOPPTR(nss,ix) = savesharedpv(c);
11579             ptr = POPPTR(ss,ix);
11580             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11581             break;
11582         case SAVEt_GENERIC_SVREF:               /* generic sv */
11583         case SAVEt_SVREF:                       /* scalar reference */
11584             sv = (const SV *)POPPTR(ss,ix);
11585             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11586             ptr = POPPTR(ss,ix);
11587             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11588             break;
11589         case SAVEt_HV:                          /* hash reference */
11590         case SAVEt_AV:                          /* array reference */
11591             sv = (const SV *) POPPTR(ss,ix);
11592             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11593             /* fall through */
11594         case SAVEt_COMPPAD:
11595         case SAVEt_NSTAB:
11596             sv = (const SV *) POPPTR(ss,ix);
11597             TOPPTR(nss,ix) = sv_dup(sv, param);
11598             break;
11599         case SAVEt_INT:                         /* int reference */
11600             ptr = POPPTR(ss,ix);
11601             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11602             intval = (int)POPINT(ss,ix);
11603             TOPINT(nss,ix) = intval;
11604             break;
11605         case SAVEt_LONG:                        /* long reference */
11606             ptr = POPPTR(ss,ix);
11607             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11608             longval = (long)POPLONG(ss,ix);
11609             TOPLONG(nss,ix) = longval;
11610             break;
11611         case SAVEt_I32:                         /* I32 reference */
11612         case SAVEt_COP_ARYBASE:                 /* call CopARYBASE_set */
11613             ptr = POPPTR(ss,ix);
11614             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11615             i = POPINT(ss,ix);
11616             TOPINT(nss,ix) = i;
11617             break;
11618         case SAVEt_IV:                          /* IV reference */
11619             ptr = POPPTR(ss,ix);
11620             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11621             iv = POPIV(ss,ix);
11622             TOPIV(nss,ix) = iv;
11623             break;
11624         case SAVEt_HPTR:                        /* HV* reference */
11625         case SAVEt_APTR:                        /* AV* reference */
11626         case SAVEt_SPTR:                        /* SV* reference */
11627             ptr = POPPTR(ss,ix);
11628             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11629             sv = (const SV *)POPPTR(ss,ix);
11630             TOPPTR(nss,ix) = sv_dup(sv, param);
11631             break;
11632         case SAVEt_VPTR:                        /* random* reference */
11633             ptr = POPPTR(ss,ix);
11634             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11635             /* Fall through */
11636         case SAVEt_INT_SMALL:
11637         case SAVEt_I32_SMALL:
11638         case SAVEt_I16:                         /* I16 reference */
11639         case SAVEt_I8:                          /* I8 reference */
11640         case SAVEt_BOOL:
11641             ptr = POPPTR(ss,ix);
11642             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11643             break;
11644         case SAVEt_GENERIC_PVREF:               /* generic char* */
11645         case SAVEt_PPTR:                        /* char* reference */
11646             ptr = POPPTR(ss,ix);
11647             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11648             c = (char*)POPPTR(ss,ix);
11649             TOPPTR(nss,ix) = pv_dup(c);
11650             break;
11651         case SAVEt_GP:                          /* scalar reference */
11652             gv = (const GV *)POPPTR(ss,ix);
11653             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11654             gp = (GP*)POPPTR(ss,ix);
11655             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11656             (void)GpREFCNT_inc(gp);
11657             i = POPINT(ss,ix);
11658             TOPINT(nss,ix) = i;
11659             break;
11660         case SAVEt_FREEOP:
11661             ptr = POPPTR(ss,ix);
11662             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11663                 /* these are assumed to be refcounted properly */
11664                 OP *o;
11665                 switch (((OP*)ptr)->op_type) {
11666                 case OP_LEAVESUB:
11667                 case OP_LEAVESUBLV:
11668                 case OP_LEAVEEVAL:
11669                 case OP_LEAVE:
11670                 case OP_SCOPE:
11671                 case OP_LEAVEWRITE:
11672                     TOPPTR(nss,ix) = ptr;
11673                     o = (OP*)ptr;
11674                     OP_REFCNT_LOCK;
11675                     (void) OpREFCNT_inc(o);
11676                     OP_REFCNT_UNLOCK;
11677                     break;
11678                 default:
11679                     TOPPTR(nss,ix) = NULL;
11680                     break;
11681                 }
11682             }
11683             else
11684                 TOPPTR(nss,ix) = NULL;
11685             break;
11686         case SAVEt_DELETE:
11687             hv = (const HV *)POPPTR(ss,ix);
11688             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11689             i = POPINT(ss,ix);
11690             TOPINT(nss,ix) = i;
11691             /* Fall through */
11692         case SAVEt_FREEPV:
11693             c = (char*)POPPTR(ss,ix);
11694             TOPPTR(nss,ix) = pv_dup_inc(c);
11695             break;
11696         case SAVEt_STACK_POS:           /* Position on Perl stack */
11697             i = POPINT(ss,ix);
11698             TOPINT(nss,ix) = i;
11699             break;
11700         case SAVEt_DESTRUCTOR:
11701             ptr = POPPTR(ss,ix);
11702             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11703             dptr = POPDPTR(ss,ix);
11704             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11705                                         any_dup(FPTR2DPTR(void *, dptr),
11706                                                 proto_perl));
11707             break;
11708         case SAVEt_DESTRUCTOR_X:
11709             ptr = POPPTR(ss,ix);
11710             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11711             dxptr = POPDXPTR(ss,ix);
11712             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11713                                          any_dup(FPTR2DPTR(void *, dxptr),
11714                                                  proto_perl));
11715             break;
11716         case SAVEt_REGCONTEXT:
11717         case SAVEt_ALLOC:
11718             ix -= uv >> SAVE_TIGHT_SHIFT;
11719             break;
11720         case SAVEt_AELEM:               /* array element */
11721             sv = (const SV *)POPPTR(ss,ix);
11722             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11723             i = POPINT(ss,ix);
11724             TOPINT(nss,ix) = i;
11725             av = (const AV *)POPPTR(ss,ix);
11726             TOPPTR(nss,ix) = av_dup_inc(av, param);
11727             break;
11728         case SAVEt_OP:
11729             ptr = POPPTR(ss,ix);
11730             TOPPTR(nss,ix) = ptr;
11731             break;
11732         case SAVEt_HINTS:
11733             ptr = POPPTR(ss,ix);
11734             if (ptr) {
11735                 HINTS_REFCNT_LOCK;
11736                 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11737                 HINTS_REFCNT_UNLOCK;
11738             }
11739             TOPPTR(nss,ix) = ptr;
11740             i = POPINT(ss,ix);
11741             TOPINT(nss,ix) = i;
11742             if (i & HINT_LOCALIZE_HH) {
11743                 hv = (const HV *)POPPTR(ss,ix);
11744                 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11745             }
11746             break;
11747         case SAVEt_PADSV_AND_MORTALIZE:
11748             longval = (long)POPLONG(ss,ix);
11749             TOPLONG(nss,ix) = longval;
11750             ptr = POPPTR(ss,ix);
11751             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11752             sv = (const SV *)POPPTR(ss,ix);
11753             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11754             break;
11755         case SAVEt_SET_SVFLAGS:
11756             i = POPINT(ss,ix);
11757             TOPINT(nss,ix) = i;
11758             i = POPINT(ss,ix);
11759             TOPINT(nss,ix) = i;
11760             sv = (const SV *)POPPTR(ss,ix);
11761             TOPPTR(nss,ix) = sv_dup(sv, param);
11762             break;
11763         case SAVEt_RE_STATE:
11764             {
11765                 const struct re_save_state *const old_state
11766                     = (struct re_save_state *)
11767                     (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11768                 struct re_save_state *const new_state
11769                     = (struct re_save_state *)
11770                     (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11771
11772                 Copy(old_state, new_state, 1, struct re_save_state);
11773                 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11774
11775                 new_state->re_state_bostr
11776                     = pv_dup(old_state->re_state_bostr);
11777                 new_state->re_state_reginput
11778                     = pv_dup(old_state->re_state_reginput);
11779                 new_state->re_state_regeol
11780                     = pv_dup(old_state->re_state_regeol);
11781                 new_state->re_state_regoffs
11782                     = (regexp_paren_pair*)
11783                         any_dup(old_state->re_state_regoffs, proto_perl);
11784                 new_state->re_state_reglastparen
11785                     = (U32*) any_dup(old_state->re_state_reglastparen,
11786                               proto_perl);
11787                 new_state->re_state_reglastcloseparen
11788                     = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11789                               proto_perl);
11790                 /* XXX This just has to be broken. The old save_re_context
11791                    code did SAVEGENERICPV(PL_reg_start_tmp);
11792                    PL_reg_start_tmp is char **.
11793                    Look above to what the dup code does for
11794                    SAVEt_GENERIC_PVREF
11795                    It can never have worked.
11796                    So this is merely a faithful copy of the exiting bug:  */
11797                 new_state->re_state_reg_start_tmp
11798                     = (char **) pv_dup((char *)
11799                                       old_state->re_state_reg_start_tmp);
11800                 /* I assume that it only ever "worked" because no-one called
11801                    (pseudo)fork while the regexp engine had re-entered itself.
11802                 */
11803 #ifdef PERL_OLD_COPY_ON_WRITE
11804                 new_state->re_state_nrs
11805                     = sv_dup(old_state->re_state_nrs, param);
11806 #endif
11807                 new_state->re_state_reg_magic
11808                     = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11809                                proto_perl);
11810                 new_state->re_state_reg_oldcurpm
11811                     = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11812                               proto_perl);
11813                 new_state->re_state_reg_curpm
11814                     = (PMOP*)  any_dup(old_state->re_state_reg_curpm,
11815                                proto_perl);
11816                 new_state->re_state_reg_oldsaved
11817                     = pv_dup(old_state->re_state_reg_oldsaved);
11818                 new_state->re_state_reg_poscache
11819                     = pv_dup(old_state->re_state_reg_poscache);
11820                 new_state->re_state_reg_starttry
11821                     = pv_dup(old_state->re_state_reg_starttry);
11822                 break;
11823             }
11824         case SAVEt_COMPILE_WARNINGS:
11825             ptr = POPPTR(ss,ix);
11826             TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11827             break;
11828         case SAVEt_PARSER:
11829             ptr = POPPTR(ss,ix);
11830             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11831             break;
11832         default:
11833             Perl_croak(aTHX_
11834                        "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11835         }
11836     }
11837
11838     return nss;
11839 }
11840
11841
11842 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11843  * flag to the result. This is done for each stash before cloning starts,
11844  * so we know which stashes want their objects cloned */
11845
11846 static void
11847 do_mark_cloneable_stash(pTHX_ SV *const sv)
11848 {
11849     const HEK * const hvname = HvNAME_HEK((const HV *)sv);
11850     if (hvname) {
11851         GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
11852         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11853         if (cloner && GvCV(cloner)) {
11854             dSP;
11855             UV status;
11856
11857             ENTER;
11858             SAVETMPS;
11859             PUSHMARK(SP);
11860             mXPUSHs(newSVhek(hvname));
11861             PUTBACK;
11862             call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
11863             SPAGAIN;
11864             status = POPu;
11865             PUTBACK;
11866             FREETMPS;
11867             LEAVE;
11868             if (status)
11869                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11870         }
11871     }
11872 }
11873
11874
11875
11876 /*
11877 =for apidoc perl_clone
11878
11879 Create and return a new interpreter by cloning the current one.
11880
11881 perl_clone takes these flags as parameters:
11882
11883 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11884 without it we only clone the data and zero the stacks,
11885 with it we copy the stacks and the new perl interpreter is
11886 ready to run at the exact same point as the previous one.
11887 The pseudo-fork code uses COPY_STACKS while the
11888 threads->create doesn't.
11889
11890 CLONEf_KEEP_PTR_TABLE
11891 perl_clone keeps a ptr_table with the pointer of the old
11892 variable as a key and the new variable as a value,
11893 this allows it to check if something has been cloned and not
11894 clone it again but rather just use the value and increase the
11895 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11896 the ptr_table using the function
11897 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11898 reason to keep it around is if you want to dup some of your own
11899 variable who are outside the graph perl scans, example of this
11900 code is in threads.xs create
11901
11902 CLONEf_CLONE_HOST
11903 This is a win32 thing, it is ignored on unix, it tells perls
11904 win32host code (which is c++) to clone itself, this is needed on
11905 win32 if you want to run two threads at the same time,
11906 if you just want to do some stuff in a separate perl interpreter
11907 and then throw it away and return to the original one,
11908 you don't need to do anything.
11909
11910 =cut
11911 */
11912
11913 /* XXX the above needs expanding by someone who actually understands it ! */
11914 EXTERN_C PerlInterpreter *
11915 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11916
11917 PerlInterpreter *
11918 perl_clone(PerlInterpreter *proto_perl, UV flags)
11919 {
11920    dVAR;
11921 #ifdef PERL_IMPLICIT_SYS
11922
11923     PERL_ARGS_ASSERT_PERL_CLONE;
11924
11925    /* perlhost.h so we need to call into it
11926    to clone the host, CPerlHost should have a c interface, sky */
11927
11928    if (flags & CLONEf_CLONE_HOST) {
11929        return perl_clone_host(proto_perl,flags);
11930    }
11931    return perl_clone_using(proto_perl, flags,
11932                             proto_perl->IMem,
11933                             proto_perl->IMemShared,
11934                             proto_perl->IMemParse,
11935                             proto_perl->IEnv,
11936                             proto_perl->IStdIO,
11937                             proto_perl->ILIO,
11938                             proto_perl->IDir,
11939                             proto_perl->ISock,
11940                             proto_perl->IProc);
11941 }
11942
11943 PerlInterpreter *
11944 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11945                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
11946                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11947                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11948                  struct IPerlDir* ipD, struct IPerlSock* ipS,
11949                  struct IPerlProc* ipP)
11950 {
11951     /* XXX many of the string copies here can be optimized if they're
11952      * constants; they need to be allocated as common memory and just
11953      * their pointers copied. */
11954
11955     IV i;
11956     CLONE_PARAMS clone_params;
11957     CLONE_PARAMS* const param = &clone_params;
11958
11959     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11960
11961     PERL_ARGS_ASSERT_PERL_CLONE_USING;
11962 #else           /* !PERL_IMPLICIT_SYS */
11963     IV i;
11964     CLONE_PARAMS clone_params;
11965     CLONE_PARAMS* param = &clone_params;
11966     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11967
11968     PERL_ARGS_ASSERT_PERL_CLONE;
11969 #endif          /* PERL_IMPLICIT_SYS */
11970
11971     /* for each stash, determine whether its objects should be cloned */
11972     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11973     PERL_SET_THX(my_perl);
11974
11975 #ifdef DEBUGGING
11976     PoisonNew(my_perl, 1, PerlInterpreter);
11977     PL_op = NULL;
11978     PL_curcop = NULL;
11979     PL_markstack = 0;
11980     PL_scopestack = 0;
11981     PL_scopestack_name = 0;
11982     PL_savestack = 0;
11983     PL_savestack_ix = 0;
11984     PL_savestack_max = -1;
11985     PL_sig_pending = 0;
11986     PL_parser = NULL;
11987     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11988 #  ifdef DEBUG_LEAKING_SCALARS
11989     PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
11990 #  endif
11991 #else   /* !DEBUGGING */
11992     Zero(my_perl, 1, PerlInterpreter);
11993 #endif  /* DEBUGGING */
11994
11995 #ifdef PERL_IMPLICIT_SYS
11996     /* host pointers */
11997     PL_Mem              = ipM;
11998     PL_MemShared        = ipMS;
11999     PL_MemParse         = ipMP;
12000     PL_Env              = ipE;
12001     PL_StdIO            = ipStd;
12002     PL_LIO              = ipLIO;
12003     PL_Dir              = ipD;
12004     PL_Sock             = ipS;
12005     PL_Proc             = ipP;
12006 #endif          /* PERL_IMPLICIT_SYS */
12007
12008     param->flags = flags;
12009     param->proto_perl = proto_perl;
12010
12011     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12012
12013     PL_body_arenas = NULL;
12014     Zero(&PL_body_roots, 1, PL_body_roots);
12015
12016     PL_nice_chunk       = NULL;
12017     PL_nice_chunk_size  = 0;
12018     PL_sv_count         = 0;
12019     PL_sv_objcount      = 0;
12020     PL_sv_root          = NULL;
12021     PL_sv_arenaroot     = NULL;
12022
12023     PL_debug            = proto_perl->Idebug;
12024
12025     PL_hash_seed        = proto_perl->Ihash_seed;
12026     PL_rehash_seed      = proto_perl->Irehash_seed;
12027
12028 #ifdef USE_REENTRANT_API
12029     /* XXX: things like -Dm will segfault here in perlio, but doing
12030      *  PERL_SET_CONTEXT(proto_perl);
12031      * breaks too many other things
12032      */
12033     Perl_reentrant_init(aTHX);
12034 #endif
12035
12036     /* create SV map for pointer relocation */
12037     PL_ptr_table = ptr_table_new();
12038
12039     /* initialize these special pointers as early as possible */
12040     SvANY(&PL_sv_undef)         = NULL;
12041     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
12042     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
12043     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12044
12045     SvANY(&PL_sv_no)            = new_XPVNV();
12046     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
12047     SvFLAGS(&PL_sv_no)          = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12048                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12049     SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12050     SvCUR_set(&PL_sv_no, 0);
12051     SvLEN_set(&PL_sv_no, 1);
12052     SvIV_set(&PL_sv_no, 0);
12053     SvNV_set(&PL_sv_no, 0);
12054     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12055
12056     SvANY(&PL_sv_yes)           = new_XPVNV();
12057     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
12058     SvFLAGS(&PL_sv_yes)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12059                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12060     SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12061     SvCUR_set(&PL_sv_yes, 1);
12062     SvLEN_set(&PL_sv_yes, 2);
12063     SvIV_set(&PL_sv_yes, 1);
12064     SvNV_set(&PL_sv_yes, 1);
12065     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12066
12067     /* dbargs array probably holds garbage */
12068     PL_dbargs           = NULL;
12069
12070     /* create (a non-shared!) shared string table */
12071     PL_strtab           = newHV();
12072     HvSHAREKEYS_off(PL_strtab);
12073     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12074     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12075
12076     PL_compiling = proto_perl->Icompiling;
12077
12078     /* These two PVs will be free'd special way so must set them same way op.c does */
12079     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12080     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12081
12082     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
12083     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12084
12085     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12086     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12087     if (PL_compiling.cop_hints_hash) {
12088         HINTS_REFCNT_LOCK;
12089         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
12090         HINTS_REFCNT_UNLOCK;
12091     }
12092     PL_curcop           = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12093 #ifdef PERL_DEBUG_READONLY_OPS
12094     PL_slabs = NULL;
12095     PL_slab_count = 0;
12096 #endif
12097
12098     /* pseudo environmental stuff */
12099     PL_origargc         = proto_perl->Iorigargc;
12100     PL_origargv         = proto_perl->Iorigargv;
12101
12102     param->stashes      = newAV();  /* Setup array of objects to call clone on */
12103
12104     /* Set tainting stuff before PerlIO_debug can possibly get called */
12105     PL_tainting         = proto_perl->Itainting;
12106     PL_taint_warn       = proto_perl->Itaint_warn;
12107
12108 #ifdef PERLIO_LAYERS
12109     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12110     PerlIO_clone(aTHX_ proto_perl, param);
12111 #endif
12112
12113     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
12114     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
12115     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
12116     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
12117     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
12118     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
12119
12120     /* switches */
12121     PL_minus_c          = proto_perl->Iminus_c;
12122     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
12123     PL_localpatches     = proto_perl->Ilocalpatches;
12124     PL_splitstr         = proto_perl->Isplitstr;
12125     PL_minus_n          = proto_perl->Iminus_n;
12126     PL_minus_p          = proto_perl->Iminus_p;
12127     PL_minus_l          = proto_perl->Iminus_l;
12128     PL_minus_a          = proto_perl->Iminus_a;
12129     PL_minus_E          = proto_perl->Iminus_E;
12130     PL_minus_F          = proto_perl->Iminus_F;
12131     PL_doswitches       = proto_perl->Idoswitches;
12132     PL_dowarn           = proto_perl->Idowarn;
12133     PL_doextract        = proto_perl->Idoextract;
12134     PL_sawampersand     = proto_perl->Isawampersand;
12135     PL_unsafe           = proto_perl->Iunsafe;
12136     PL_inplace          = SAVEPV(proto_perl->Iinplace);
12137     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
12138     PL_perldb           = proto_perl->Iperldb;
12139     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12140     PL_exit_flags       = proto_perl->Iexit_flags;
12141
12142     /* magical thingies */
12143     /* XXX time(&PL_basetime) when asked for? */
12144     PL_basetime         = proto_perl->Ibasetime;
12145     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
12146
12147     PL_maxsysfd         = proto_perl->Imaxsysfd;
12148     PL_statusvalue      = proto_perl->Istatusvalue;
12149 #ifdef VMS
12150     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
12151 #else
12152     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12153 #endif
12154     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
12155
12156     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
12157     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
12158     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
12159
12160
12161     /* RE engine related */
12162     Zero(&PL_reg_state, 1, struct re_save_state);
12163     PL_reginterp_cnt    = 0;
12164     PL_regmatch_slab    = NULL;
12165
12166     /* Clone the regex array */
12167     /* ORANGE FIXME for plugins, probably in the SV dup code.
12168        newSViv(PTR2IV(CALLREGDUPE(
12169        INT2PTR(REGEXP *, SvIVX(regex)), param))))
12170     */
12171     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12172     PL_regex_pad = AvARRAY(PL_regex_padav);
12173
12174     /* shortcuts to various I/O objects */
12175     PL_ofsgv            = gv_dup(proto_perl->Iofsgv, param);
12176     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
12177     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
12178     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
12179     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
12180     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
12181     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
12182
12183     /* shortcuts to regexp stuff */
12184     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
12185
12186     /* shortcuts to misc objects */
12187     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
12188
12189     /* shortcuts to debugging objects */
12190     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
12191     PL_DBline           = gv_dup(proto_perl->IDBline, param);
12192     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
12193     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
12194     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
12195     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
12196
12197     /* symbol tables */
12198     PL_defstash         = hv_dup_inc(proto_perl->Idefstash, param);
12199     PL_curstash         = hv_dup(proto_perl->Icurstash, param);
12200     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
12201     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
12202     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
12203
12204     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
12205     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
12206     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
12207     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
12208     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12209     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
12210     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
12211     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
12212
12213     PL_sub_generation   = proto_perl->Isub_generation;
12214     PL_isarev           = hv_dup_inc(proto_perl->Iisarev, param);
12215
12216     /* funky return mechanisms */
12217     PL_forkprocess      = proto_perl->Iforkprocess;
12218
12219     /* subprocess state */
12220     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
12221
12222     /* internal state */
12223     PL_maxo             = proto_perl->Imaxo;
12224     if (proto_perl->Iop_mask)
12225         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12226     else
12227         PL_op_mask      = NULL;
12228     /* PL_asserting        = proto_perl->Iasserting; */
12229
12230     /* current interpreter roots */
12231     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
12232     OP_REFCNT_LOCK;
12233     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
12234     OP_REFCNT_UNLOCK;
12235     PL_main_start       = proto_perl->Imain_start;
12236     PL_eval_root        = proto_perl->Ieval_root;
12237     PL_eval_start       = proto_perl->Ieval_start;
12238
12239     /* runtime control stuff */
12240     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12241
12242     PL_filemode         = proto_perl->Ifilemode;
12243     PL_lastfd           = proto_perl->Ilastfd;
12244     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
12245     PL_Argv             = NULL;
12246     PL_Cmd              = NULL;
12247     PL_gensym           = proto_perl->Igensym;
12248     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
12249     PL_laststatval      = proto_perl->Ilaststatval;
12250     PL_laststype        = proto_perl->Ilaststype;
12251     PL_mess_sv          = NULL;
12252
12253     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
12254
12255     /* interpreter atexit processing */
12256     PL_exitlistlen      = proto_perl->Iexitlistlen;
12257     if (PL_exitlistlen) {
12258         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12259         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12260     }
12261     else
12262         PL_exitlist     = (PerlExitListEntry*)NULL;
12263
12264     PL_my_cxt_size = proto_perl->Imy_cxt_size;
12265     if (PL_my_cxt_size) {
12266         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12267         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12268 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12269         Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12270         Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12271 #endif
12272     }
12273     else {
12274         PL_my_cxt_list  = (void**)NULL;
12275 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12276         PL_my_cxt_keys  = (const char**)NULL;
12277 #endif
12278     }
12279     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
12280     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
12281     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12282
12283     PL_profiledata      = NULL;
12284
12285     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
12286
12287     PAD_CLONE_VARS(proto_perl, param);
12288
12289 #ifdef HAVE_INTERP_INTERN
12290     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12291 #endif
12292
12293     /* more statics moved here */
12294     PL_generation       = proto_perl->Igeneration;
12295     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
12296
12297     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
12298     PL_in_clean_all     = proto_perl->Iin_clean_all;
12299
12300     PL_uid              = proto_perl->Iuid;
12301     PL_euid             = proto_perl->Ieuid;
12302     PL_gid              = proto_perl->Igid;
12303     PL_egid             = proto_perl->Iegid;
12304     PL_nomemok          = proto_perl->Inomemok;
12305     PL_an               = proto_perl->Ian;
12306     PL_evalseq          = proto_perl->Ievalseq;
12307     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
12308     PL_origalen         = proto_perl->Iorigalen;
12309 #ifdef PERL_USES_PL_PIDSTATUS
12310     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
12311 #endif
12312     PL_osname           = SAVEPV(proto_perl->Iosname);
12313     PL_sighandlerp      = proto_perl->Isighandlerp;
12314
12315     PL_runops           = proto_perl->Irunops;
12316
12317     PL_parser           = parser_dup(proto_perl->Iparser, param);
12318
12319     /* XXX this only works if the saved cop has already been cloned */
12320     if (proto_perl->Iparser) {
12321         PL_parser->saved_curcop = (COP*)any_dup(
12322                                     proto_perl->Iparser->saved_curcop,
12323                                     proto_perl);
12324     }
12325
12326     PL_subline          = proto_perl->Isubline;
12327     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
12328
12329 #ifdef FCRYPT
12330     PL_cryptseen        = proto_perl->Icryptseen;
12331 #endif
12332
12333     PL_hints            = proto_perl->Ihints;
12334
12335     PL_amagic_generation        = proto_perl->Iamagic_generation;
12336
12337 #ifdef USE_LOCALE_COLLATE
12338     PL_collation_ix     = proto_perl->Icollation_ix;
12339     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
12340     PL_collation_standard       = proto_perl->Icollation_standard;
12341     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
12342     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
12343 #endif /* USE_LOCALE_COLLATE */
12344
12345 #ifdef USE_LOCALE_NUMERIC
12346     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
12347     PL_numeric_standard = proto_perl->Inumeric_standard;
12348     PL_numeric_local    = proto_perl->Inumeric_local;
12349     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12350 #endif /* !USE_LOCALE_NUMERIC */
12351
12352     /* utf8 character classes */
12353     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12354     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12355     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12356     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
12357     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12358     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
12359     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
12360     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
12361     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
12362     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
12363     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
12364     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12365     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
12366     PL_utf8_X_begin     = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
12367     PL_utf8_X_extend    = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
12368     PL_utf8_X_prepend   = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
12369     PL_utf8_X_non_hangul        = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
12370     PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
12371     PL_utf8_X_LV        = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
12372     PL_utf8_X_LVT       = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
12373     PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
12374     PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
12375     PL_utf8_X_LV_LVT_V  = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
12376     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12377     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12378     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12379     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12380     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12381     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12382
12383     /* Did the locale setup indicate UTF-8? */
12384     PL_utf8locale       = proto_perl->Iutf8locale;
12385     /* Unicode features (see perlrun/-C) */
12386     PL_unicode          = proto_perl->Iunicode;
12387
12388     /* Pre-5.8 signals control */
12389     PL_signals          = proto_perl->Isignals;
12390
12391     /* times() ticks per second */
12392     PL_clocktick        = proto_perl->Iclocktick;
12393
12394     /* Recursion stopper for PerlIO_find_layer */
12395     PL_in_load_module   = proto_perl->Iin_load_module;
12396
12397     /* sort() routine */
12398     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
12399
12400     /* Not really needed/useful since the reenrant_retint is "volatile",
12401      * but do it for consistency's sake. */
12402     PL_reentrant_retint = proto_perl->Ireentrant_retint;
12403
12404     /* Hooks to shared SVs and locks. */
12405     PL_sharehook        = proto_perl->Isharehook;
12406     PL_lockhook         = proto_perl->Ilockhook;
12407     PL_unlockhook       = proto_perl->Iunlockhook;
12408     PL_threadhook       = proto_perl->Ithreadhook;
12409     PL_destroyhook      = proto_perl->Idestroyhook;
12410
12411 #ifdef THREADS_HAVE_PIDS
12412     PL_ppid             = proto_perl->Ippid;
12413 #endif
12414
12415     /* swatch cache */
12416     PL_last_swash_hv    = NULL; /* reinits on demand */
12417     PL_last_swash_klen  = 0;
12418     PL_last_swash_key[0]= '\0';
12419     PL_last_swash_tmps  = (U8*)NULL;
12420     PL_last_swash_slen  = 0;
12421
12422     PL_glob_index       = proto_perl->Iglob_index;
12423     PL_srand_called     = proto_perl->Isrand_called;
12424
12425     if (proto_perl->Ipsig_pend) {
12426         Newxz(PL_psig_pend, SIG_SIZE, int);
12427     }
12428     else {
12429         PL_psig_pend    = (int*)NULL;
12430     }
12431
12432     if (proto_perl->Ipsig_name) {
12433         Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
12434         sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
12435                             param);
12436         PL_psig_ptr = PL_psig_name + SIG_SIZE;
12437     }
12438     else {
12439         PL_psig_ptr     = (SV**)NULL;
12440         PL_psig_name    = (SV**)NULL;
12441     }
12442
12443     /* intrpvar.h stuff */
12444
12445     if (flags & CLONEf_COPY_STACKS) {
12446         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12447         PL_tmps_ix              = proto_perl->Itmps_ix;
12448         PL_tmps_max             = proto_perl->Itmps_max;
12449         PL_tmps_floor           = proto_perl->Itmps_floor;
12450         Newx(PL_tmps_stack, PL_tmps_max, SV*);
12451         sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
12452                             PL_tmps_ix+1, param);
12453
12454         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12455         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12456         Newxz(PL_markstack, i, I32);
12457         PL_markstack_max        = PL_markstack + (proto_perl->Imarkstack_max
12458                                                   - proto_perl->Imarkstack);
12459         PL_markstack_ptr        = PL_markstack + (proto_perl->Imarkstack_ptr
12460                                                   - proto_perl->Imarkstack);
12461         Copy(proto_perl->Imarkstack, PL_markstack,
12462              PL_markstack_ptr - PL_markstack + 1, I32);
12463
12464         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12465          * NOTE: unlike the others! */
12466         PL_scopestack_ix        = proto_perl->Iscopestack_ix;
12467         PL_scopestack_max       = proto_perl->Iscopestack_max;
12468         Newxz(PL_scopestack, PL_scopestack_max, I32);
12469         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12470
12471 #ifdef DEBUGGING
12472         Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
12473         Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
12474 #endif
12475         /* NOTE: si_dup() looks at PL_markstack */
12476         PL_curstackinfo         = si_dup(proto_perl->Icurstackinfo, param);
12477
12478         /* PL_curstack          = PL_curstackinfo->si_stack; */
12479         PL_curstack             = av_dup(proto_perl->Icurstack, param);
12480         PL_mainstack            = av_dup(proto_perl->Imainstack, param);
12481
12482         /* next PUSHs() etc. set *(PL_stack_sp+1) */
12483         PL_stack_base           = AvARRAY(PL_curstack);
12484         PL_stack_sp             = PL_stack_base + (proto_perl->Istack_sp
12485                                                    - proto_perl->Istack_base);
12486         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
12487
12488         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12489          * NOTE: unlike the others! */
12490         PL_savestack_ix         = proto_perl->Isavestack_ix;
12491         PL_savestack_max        = proto_perl->Isavestack_max;
12492         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12493         PL_savestack            = ss_dup(proto_perl, param);
12494     }
12495     else {
12496         init_stacks();
12497         ENTER;                  /* perl_destruct() wants to LEAVE; */
12498
12499         /* although we're not duplicating the tmps stack, we should still
12500          * add entries for any SVs on the tmps stack that got cloned by a
12501          * non-refcount means (eg a temp in @_); otherwise they will be
12502          * orphaned
12503          */
12504         for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12505             SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
12506                     proto_perl->Itmps_stack[i]));
12507             if (nsv && !SvREFCNT(nsv)) {
12508                 PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv));
12509             }
12510         }
12511     }
12512
12513     PL_start_env        = proto_perl->Istart_env;       /* XXXXXX */
12514     PL_top_env          = &PL_start_env;
12515
12516     PL_op               = proto_perl->Iop;
12517
12518     PL_Sv               = NULL;
12519     PL_Xpv              = (XPV*)NULL;
12520     my_perl->Ina        = proto_perl->Ina;
12521
12522     PL_statbuf          = proto_perl->Istatbuf;
12523     PL_statcache        = proto_perl->Istatcache;
12524     PL_statgv           = gv_dup(proto_perl->Istatgv, param);
12525     PL_statname         = sv_dup_inc(proto_perl->Istatname, param);
12526 #ifdef HAS_TIMES
12527     PL_timesbuf         = proto_perl->Itimesbuf;
12528 #endif
12529
12530     PL_tainted          = proto_perl->Itainted;
12531     PL_curpm            = proto_perl->Icurpm;   /* XXX No PMOP ref count */
12532     PL_rs               = sv_dup_inc(proto_perl->Irs, param);
12533     PL_last_in_gv       = gv_dup(proto_perl->Ilast_in_gv, param);
12534     PL_defoutgv         = gv_dup_inc(proto_perl->Idefoutgv, param);
12535     PL_chopset          = proto_perl->Ichopset; /* XXX never deallocated */
12536     PL_toptarget        = sv_dup_inc(proto_perl->Itoptarget, param);
12537     PL_bodytarget       = sv_dup_inc(proto_perl->Ibodytarget, param);
12538     PL_formtarget       = sv_dup(proto_perl->Iformtarget, param);
12539
12540     PL_restartjmpenv    = proto_perl->Irestartjmpenv;
12541     PL_restartop        = proto_perl->Irestartop;
12542     PL_in_eval          = proto_perl->Iin_eval;
12543     PL_delaymagic       = proto_perl->Idelaymagic;
12544     PL_dirty            = proto_perl->Idirty;
12545     PL_localizing       = proto_perl->Ilocalizing;
12546
12547     PL_errors           = sv_dup_inc(proto_perl->Ierrors, param);
12548     PL_hv_fetch_ent_mh  = NULL;
12549     PL_modcount         = proto_perl->Imodcount;
12550     PL_lastgotoprobe    = NULL;
12551     PL_dumpindent       = proto_perl->Idumpindent;
12552
12553     PL_sortcop          = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12554     PL_sortstash        = hv_dup(proto_perl->Isortstash, param);
12555     PL_firstgv          = gv_dup(proto_perl->Ifirstgv, param);
12556     PL_secondgv         = gv_dup(proto_perl->Isecondgv, param);
12557     PL_efloatbuf        = NULL;         /* reinits on demand */
12558     PL_efloatsize       = 0;                    /* reinits on demand */
12559
12560     /* regex stuff */
12561
12562     PL_screamfirst      = NULL;
12563     PL_screamnext       = NULL;
12564     PL_maxscream        = -1;                   /* reinits on demand */
12565     PL_lastscream       = NULL;
12566
12567
12568     PL_regdummy         = proto_perl->Iregdummy;
12569     PL_colorset         = 0;            /* reinits PL_colors[] */
12570     /*PL_colors[6]      = {0,0,0,0,0,0};*/
12571
12572
12573
12574     /* Pluggable optimizer */
12575     PL_peepp            = proto_perl->Ipeepp;
12576     /* op_free() hook */
12577     PL_opfreehook       = proto_perl->Iopfreehook;
12578
12579     PL_stashcache       = newHV();
12580
12581     PL_watchaddr        = (char **) ptr_table_fetch(PL_ptr_table,
12582                                             proto_perl->Iwatchaddr);
12583     PL_watchok          = PL_watchaddr ? * PL_watchaddr : NULL;
12584     if (PL_debug && PL_watchaddr) {
12585         PerlIO_printf(Perl_debug_log,
12586           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12587           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12588           PTR2UV(PL_watchok));
12589     }
12590
12591     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
12592
12593     /* Call the ->CLONE method, if it exists, for each of the stashes
12594        identified by sv_dup() above.
12595     */
12596     while(av_len(param->stashes) != -1) {
12597         HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12598         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12599         if (cloner && GvCV(cloner)) {
12600             dSP;
12601             ENTER;
12602             SAVETMPS;
12603             PUSHMARK(SP);
12604             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12605             PUTBACK;
12606             call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
12607             FREETMPS;
12608             LEAVE;
12609         }
12610     }
12611
12612     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12613         ptr_table_free(PL_ptr_table);
12614         PL_ptr_table = NULL;
12615     }
12616
12617
12618     SvREFCNT_dec(param->stashes);
12619
12620     /* orphaned? eg threads->new inside BEGIN or use */
12621     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12622         SvREFCNT_inc_simple_void(PL_compcv);
12623         SAVEFREESV(PL_compcv);
12624     }
12625
12626     return my_perl;
12627 }
12628
12629 #endif /* USE_ITHREADS */
12630
12631 /*
12632 =head1 Unicode Support
12633
12634 =for apidoc sv_recode_to_utf8
12635
12636 The encoding is assumed to be an Encode object, on entry the PV
12637 of the sv is assumed to be octets in that encoding, and the sv
12638 will be converted into Unicode (and UTF-8).
12639
12640 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12641 is not a reference, nothing is done to the sv.  If the encoding is not
12642 an C<Encode::XS> Encoding object, bad things will happen.
12643 (See F<lib/encoding.pm> and L<Encode>).
12644
12645 The PV of the sv is returned.
12646
12647 =cut */
12648
12649 char *
12650 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12651 {
12652     dVAR;
12653
12654     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12655
12656     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12657         SV *uni;
12658         STRLEN len;
12659         const char *s;
12660         dSP;
12661         ENTER;
12662         SAVETMPS;
12663         save_re_context();
12664         PUSHMARK(sp);
12665         EXTEND(SP, 3);
12666         XPUSHs(encoding);
12667         XPUSHs(sv);
12668 /*
12669   NI-S 2002/07/09
12670   Passing sv_yes is wrong - it needs to be or'ed set of constants
12671   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12672   remove converted chars from source.
12673
12674   Both will default the value - let them.
12675
12676         XPUSHs(&PL_sv_yes);
12677 */
12678         PUTBACK;
12679         call_method("decode", G_SCALAR);
12680         SPAGAIN;
12681         uni = POPs;
12682         PUTBACK;
12683         s = SvPV_const(uni, len);
12684         if (s != SvPVX_const(sv)) {
12685             SvGROW(sv, len + 1);
12686             Move(s, SvPVX(sv), len + 1, char);
12687             SvCUR_set(sv, len);
12688         }
12689         FREETMPS;
12690         LEAVE;
12691         SvUTF8_on(sv);
12692         return SvPVX(sv);
12693     }
12694     return SvPOKp(sv) ? SvPVX(sv) : NULL;
12695 }
12696
12697 /*
12698 =for apidoc sv_cat_decode
12699
12700 The encoding is assumed to be an Encode object, the PV of the ssv is
12701 assumed to be octets in that encoding and decoding the input starts
12702 from the position which (PV + *offset) pointed to.  The dsv will be
12703 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
12704 when the string tstr appears in decoding output or the input ends on
12705 the PV of the ssv. The value which the offset points will be modified
12706 to the last input position on the ssv.
12707
12708 Returns TRUE if the terminator was found, else returns FALSE.
12709
12710 =cut */
12711
12712 bool
12713 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12714                    SV *ssv, int *offset, char *tstr, int tlen)
12715 {
12716     dVAR;
12717     bool ret = FALSE;
12718
12719     PERL_ARGS_ASSERT_SV_CAT_DECODE;
12720
12721     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12722         SV *offsv;
12723         dSP;
12724         ENTER;
12725         SAVETMPS;
12726         save_re_context();
12727         PUSHMARK(sp);
12728         EXTEND(SP, 6);
12729         XPUSHs(encoding);
12730         XPUSHs(dsv);
12731         XPUSHs(ssv);
12732         offsv = newSViv(*offset);
12733         mXPUSHs(offsv);
12734         mXPUSHp(tstr, tlen);
12735         PUTBACK;
12736         call_method("cat_decode", G_SCALAR);
12737         SPAGAIN;
12738         ret = SvTRUE(TOPs);
12739         *offset = SvIV(offsv);
12740         PUTBACK;
12741         FREETMPS;
12742         LEAVE;
12743     }
12744     else
12745         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12746     return ret;
12747
12748 }
12749
12750 /* ---------------------------------------------------------------------
12751  *
12752  * support functions for report_uninit()
12753  */
12754
12755 /* the maxiumum size of array or hash where we will scan looking
12756  * for the undefined element that triggered the warning */
12757
12758 #define FUV_MAX_SEARCH_SIZE 1000
12759
12760 /* Look for an entry in the hash whose value has the same SV as val;
12761  * If so, return a mortal copy of the key. */
12762
12763 STATIC SV*
12764 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
12765 {
12766     dVAR;
12767     register HE **array;
12768     I32 i;
12769
12770     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12771
12772     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12773                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12774         return NULL;
12775
12776     array = HvARRAY(hv);
12777
12778     for (i=HvMAX(hv); i>0; i--) {
12779         register HE *entry;
12780         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12781             if (HeVAL(entry) != val)
12782                 continue;
12783             if (    HeVAL(entry) == &PL_sv_undef ||
12784                     HeVAL(entry) == &PL_sv_placeholder)
12785                 continue;
12786             if (!HeKEY(entry))
12787                 return NULL;
12788             if (HeKLEN(entry) == HEf_SVKEY)
12789                 return sv_mortalcopy(HeKEY_sv(entry));
12790             return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12791         }
12792     }
12793     return NULL;
12794 }
12795
12796 /* Look for an entry in the array whose value has the same SV as val;
12797  * If so, return the index, otherwise return -1. */
12798
12799 STATIC I32
12800 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
12801 {
12802     dVAR;
12803
12804     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12805
12806     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12807                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12808         return -1;
12809
12810     if (val != &PL_sv_undef) {
12811         SV ** const svp = AvARRAY(av);
12812         I32 i;
12813
12814         for (i=AvFILLp(av); i>=0; i--)
12815             if (svp[i] == val)
12816                 return i;
12817     }
12818     return -1;
12819 }
12820
12821 /* S_varname(): return the name of a variable, optionally with a subscript.
12822  * If gv is non-zero, use the name of that global, along with gvtype (one
12823  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12824  * targ.  Depending on the value of the subscript_type flag, return:
12825  */
12826
12827 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
12828 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
12829 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
12830 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
12831
12832 STATIC SV*
12833 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
12834         const SV *const keyname, I32 aindex, int subscript_type)
12835 {
12836
12837     SV * const name = sv_newmortal();
12838     if (gv) {
12839         char buffer[2];
12840         buffer[0] = gvtype;
12841         buffer[1] = 0;
12842
12843         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
12844
12845         gv_fullname4(name, gv, buffer, 0);
12846
12847         if ((unsigned int)SvPVX(name)[1] <= 26) {
12848             buffer[0] = '^';
12849             buffer[1] = SvPVX(name)[1] + 'A' - 1;
12850
12851             /* Swap the 1 unprintable control character for the 2 byte pretty
12852                version - ie substr($name, 1, 1) = $buffer; */
12853             sv_insert(name, 1, 1, buffer, 2);
12854         }
12855     }
12856     else {
12857         CV * const cv = find_runcv(NULL);
12858         SV *sv;
12859         AV *av;
12860
12861         if (!cv || !CvPADLIST(cv))
12862             return NULL;
12863         av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
12864         sv = *av_fetch(av, targ, FALSE);
12865         sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12866     }
12867
12868     if (subscript_type == FUV_SUBSCRIPT_HASH) {
12869         SV * const sv = newSV(0);
12870         *SvPVX(name) = '$';
12871         Perl_sv_catpvf(aTHX_ name, "{%s}",
12872             pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12873         SvREFCNT_dec(sv);
12874     }
12875     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12876         *SvPVX(name) = '$';
12877         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12878     }
12879     else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12880         /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12881         Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
12882     }
12883
12884     return name;
12885 }
12886
12887
12888 /*
12889 =for apidoc find_uninit_var
12890
12891 Find the name of the undefined variable (if any) that caused the operator o
12892 to issue a "Use of uninitialized value" warning.
12893 If match is true, only return a name if it's value matches uninit_sv.
12894 So roughly speaking, if a unary operator (such as OP_COS) generates a
12895 warning, then following the direct child of the op may yield an
12896 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12897 other hand, with OP_ADD there are two branches to follow, so we only print
12898 the variable name if we get an exact match.
12899
12900 The name is returned as a mortal SV.
12901
12902 Assumes that PL_op is the op that originally triggered the error, and that
12903 PL_comppad/PL_curpad points to the currently executing pad.
12904
12905 =cut
12906 */
12907
12908 STATIC SV *
12909 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
12910                   bool match)
12911 {
12912     dVAR;
12913     SV *sv;
12914     const GV *gv;
12915     const OP *o, *o2, *kid;
12916
12917     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12918                             uninit_sv == &PL_sv_placeholder)))
12919         return NULL;
12920
12921     switch (obase->op_type) {
12922
12923     case OP_RV2AV:
12924     case OP_RV2HV:
12925     case OP_PADAV:
12926     case OP_PADHV:
12927       {
12928         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12929         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12930         I32 index = 0;
12931         SV *keysv = NULL;
12932         int subscript_type = FUV_SUBSCRIPT_WITHIN;
12933
12934         if (pad) { /* @lex, %lex */
12935             sv = PAD_SVl(obase->op_targ);
12936             gv = NULL;
12937         }
12938         else {
12939             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12940             /* @global, %global */
12941                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12942                 if (!gv)
12943                     break;
12944                 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
12945             }
12946             else /* @{expr}, %{expr} */
12947                 return find_uninit_var(cUNOPx(obase)->op_first,
12948                                                     uninit_sv, match);
12949         }
12950
12951         /* attempt to find a match within the aggregate */
12952         if (hash) {
12953             keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12954             if (keysv)
12955                 subscript_type = FUV_SUBSCRIPT_HASH;
12956         }
12957         else {
12958             index = find_array_subscript((const AV *)sv, uninit_sv);
12959             if (index >= 0)
12960                 subscript_type = FUV_SUBSCRIPT_ARRAY;
12961         }
12962
12963         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12964             break;
12965
12966         return varname(gv, hash ? '%' : '@', obase->op_targ,
12967                                     keysv, index, subscript_type);
12968       }
12969
12970     case OP_PADSV:
12971         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12972             break;
12973         return varname(NULL, '$', obase->op_targ,
12974                                     NULL, 0, FUV_SUBSCRIPT_NONE);
12975
12976     case OP_GVSV:
12977         gv = cGVOPx_gv(obase);
12978         if (!gv || (match && GvSV(gv) != uninit_sv))
12979             break;
12980         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12981
12982     case OP_AELEMFAST:
12983         if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12984             if (match) {
12985                 SV **svp;
12986                 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
12987                 if (!av || SvRMAGICAL(av))
12988                     break;
12989                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12990                 if (!svp || *svp != uninit_sv)
12991                     break;
12992             }
12993             return varname(NULL, '$', obase->op_targ,
12994                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12995         }
12996         else {
12997             gv = cGVOPx_gv(obase);
12998             if (!gv)
12999                 break;
13000             if (match) {
13001                 SV **svp;
13002                 AV *const av = GvAV(gv);
13003                 if (!av || SvRMAGICAL(av))
13004                     break;
13005                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13006                 if (!svp || *svp != uninit_sv)
13007                     break;
13008             }
13009             return varname(gv, '$', 0,
13010                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13011         }
13012         break;
13013
13014     case OP_EXISTS:
13015         o = cUNOPx(obase)->op_first;
13016         if (!o || o->op_type != OP_NULL ||
13017                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
13018             break;
13019         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
13020
13021     case OP_AELEM:
13022     case OP_HELEM:
13023         if (PL_op == obase)
13024             /* $a[uninit_expr] or $h{uninit_expr} */
13025             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
13026
13027         gv = NULL;
13028         o = cBINOPx(obase)->op_first;
13029         kid = cBINOPx(obase)->op_last;
13030
13031         /* get the av or hv, and optionally the gv */
13032         sv = NULL;
13033         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
13034             sv = PAD_SV(o->op_targ);
13035         }
13036         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
13037                 && cUNOPo->op_first->op_type == OP_GV)
13038         {
13039             gv = cGVOPx_gv(cUNOPo->op_first);
13040             if (!gv)
13041                 break;
13042             sv = o->op_type
13043                 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13044         }
13045         if (!sv)
13046             break;
13047
13048         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13049             /* index is constant */
13050             if (match) {
13051                 if (SvMAGICAL(sv))
13052                     break;
13053                 if (obase->op_type == OP_HELEM) {
13054                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13055                     if (!he || HeVAL(he) != uninit_sv)
13056                         break;
13057                 }
13058                 else {
13059                     SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13060                     if (!svp || *svp != uninit_sv)
13061                         break;
13062                 }
13063             }
13064             if (obase->op_type == OP_HELEM)
13065                 return varname(gv, '%', o->op_targ,
13066                             cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13067             else
13068                 return varname(gv, '@', o->op_targ, NULL,
13069                             SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13070         }
13071         else  {
13072             /* index is an expression;
13073              * attempt to find a match within the aggregate */
13074             if (obase->op_type == OP_HELEM) {
13075                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13076                 if (keysv)
13077                     return varname(gv, '%', o->op_targ,
13078                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
13079             }
13080             else {
13081                 const I32 index
13082                     = find_array_subscript((const AV *)sv, uninit_sv);
13083                 if (index >= 0)
13084                     return varname(gv, '@', o->op_targ,
13085                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
13086             }
13087             if (match)
13088                 break;
13089             return varname(gv,
13090                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13091                 ? '@' : '%',
13092                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13093         }
13094         break;
13095
13096     case OP_AASSIGN:
13097         /* only examine RHS */
13098         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13099
13100     case OP_OPEN:
13101         o = cUNOPx(obase)->op_first;
13102         if (o->op_type == OP_PUSHMARK)
13103             o = o->op_sibling;
13104
13105         if (!o->op_sibling) {
13106             /* one-arg version of open is highly magical */
13107
13108             if (o->op_type == OP_GV) { /* open FOO; */
13109                 gv = cGVOPx_gv(o);
13110                 if (match && GvSV(gv) != uninit_sv)
13111                     break;
13112                 return varname(gv, '$', 0,
13113                             NULL, 0, FUV_SUBSCRIPT_NONE);
13114             }
13115             /* other possibilities not handled are:
13116              * open $x; or open my $x;  should return '${*$x}'
13117              * open expr;               should return '$'.expr ideally
13118              */
13119              break;
13120         }
13121         goto do_op;
13122
13123     /* ops where $_ may be an implicit arg */
13124     case OP_TRANS:
13125     case OP_SUBST:
13126     case OP_MATCH:
13127         if ( !(obase->op_flags & OPf_STACKED)) {
13128             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13129                                  ? PAD_SVl(obase->op_targ)
13130                                  : DEFSV))
13131             {
13132                 sv = sv_newmortal();
13133                 sv_setpvs(sv, "$_");
13134                 return sv;
13135             }
13136         }
13137         goto do_op;
13138
13139     case OP_PRTF:
13140     case OP_PRINT:
13141     case OP_SAY:
13142         match = 1; /* print etc can return undef on defined args */
13143         /* skip filehandle as it can't produce 'undef' warning  */
13144         o = cUNOPx(obase)->op_first;
13145         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13146             o = o->op_sibling->op_sibling;
13147         goto do_op2;
13148
13149
13150     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13151     case OP_RV2SV:
13152     case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13153
13154         /* the following ops are capable of returning PL_sv_undef even for
13155          * defined arg(s) */
13156
13157     case OP_BACKTICK:
13158     case OP_PIPE_OP:
13159     case OP_FILENO:
13160     case OP_BINMODE:
13161     case OP_TIED:
13162     case OP_GETC:
13163     case OP_SYSREAD:
13164     case OP_SEND:
13165     case OP_IOCTL:
13166     case OP_SOCKET:
13167     case OP_SOCKPAIR:
13168     case OP_BIND:
13169     case OP_CONNECT:
13170     case OP_LISTEN:
13171     case OP_ACCEPT:
13172     case OP_SHUTDOWN:
13173     case OP_SSOCKOPT:
13174     case OP_GETPEERNAME:
13175     case OP_FTRREAD:
13176     case OP_FTRWRITE:
13177     case OP_FTREXEC:
13178     case OP_FTROWNED:
13179     case OP_FTEREAD:
13180     case OP_FTEWRITE:
13181     case OP_FTEEXEC:
13182     case OP_FTEOWNED:
13183     case OP_FTIS:
13184     case OP_FTZERO:
13185     case OP_FTSIZE:
13186     case OP_FTFILE:
13187     case OP_FTDIR:
13188     case OP_FTLINK:
13189     case OP_FTPIPE:
13190     case OP_FTSOCK:
13191     case OP_FTBLK:
13192     case OP_FTCHR:
13193     case OP_FTTTY:
13194     case OP_FTSUID:
13195     case OP_FTSGID:
13196     case OP_FTSVTX:
13197     case OP_FTTEXT:
13198     case OP_FTBINARY:
13199     case OP_FTMTIME:
13200     case OP_FTATIME:
13201     case OP_FTCTIME:
13202     case OP_READLINK:
13203     case OP_OPEN_DIR:
13204     case OP_READDIR:
13205     case OP_TELLDIR:
13206     case OP_SEEKDIR:
13207     case OP_REWINDDIR:
13208     case OP_CLOSEDIR:
13209     case OP_GMTIME:
13210     case OP_ALARM:
13211     case OP_SEMGET:
13212     case OP_GETLOGIN:
13213     case OP_UNDEF:
13214     case OP_SUBSTR:
13215     case OP_AEACH:
13216     case OP_EACH:
13217     case OP_SORT:
13218     case OP_CALLER:
13219     case OP_DOFILE:
13220     case OP_PROTOTYPE:
13221     case OP_NCMP:
13222     case OP_SMARTMATCH:
13223     case OP_UNPACK:
13224     case OP_SYSOPEN:
13225     case OP_SYSSEEK:
13226         match = 1;
13227         goto do_op;
13228
13229     case OP_ENTERSUB:
13230     case OP_GOTO:
13231         /* XXX tmp hack: these two may call an XS sub, and currently
13232           XS subs don't have a SUB entry on the context stack, so CV and
13233           pad determination goes wrong, and BAD things happen. So, just
13234           don't try to determine the value under those circumstances.
13235           Need a better fix at dome point. DAPM 11/2007 */
13236         break;
13237
13238     case OP_FLIP:
13239     case OP_FLOP:
13240     {
13241         GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
13242         if (gv && GvSV(gv) == uninit_sv)
13243             return newSVpvs_flags("$.", SVs_TEMP);
13244         goto do_op;
13245     }
13246
13247     case OP_POS:
13248         /* def-ness of rval pos() is independent of the def-ness of its arg */
13249         if ( !(obase->op_flags & OPf_MOD))
13250             break;
13251
13252     case OP_SCHOMP:
13253     case OP_CHOMP:
13254         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13255             return newSVpvs_flags("${$/}", SVs_TEMP);
13256         /*FALLTHROUGH*/
13257
13258     default:
13259     do_op:
13260         if (!(obase->op_flags & OPf_KIDS))
13261             break;
13262         o = cUNOPx(obase)->op_first;
13263
13264     do_op2:
13265         if (!o)
13266             break;
13267
13268         /* if all except one arg are constant, or have no side-effects,
13269          * or are optimized away, then it's unambiguous */
13270         o2 = NULL;
13271         for (kid=o; kid; kid = kid->op_sibling) {
13272             if (kid) {
13273                 const OPCODE type = kid->op_type;
13274                 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13275                   || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
13276                   || (type == OP_PUSHMARK)
13277                 )
13278                 continue;
13279             }
13280             if (o2) { /* more than one found */
13281                 o2 = NULL;
13282                 break;
13283             }
13284             o2 = kid;
13285         }
13286         if (o2)
13287             return find_uninit_var(o2, uninit_sv, match);
13288
13289         /* scan all args */
13290         while (o) {
13291             sv = find_uninit_var(o, uninit_sv, 1);
13292             if (sv)
13293                 return sv;
13294             o = o->op_sibling;
13295         }
13296         break;
13297     }
13298     return NULL;
13299 }
13300
13301
13302 /*
13303 =for apidoc report_uninit
13304
13305 Print appropriate "Use of uninitialized variable" warning
13306
13307 =cut
13308 */
13309
13310 void
13311 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13312 {
13313     dVAR;
13314     if (PL_op) {
13315         SV* varname = NULL;
13316         if (uninit_sv) {
13317             varname = find_uninit_var(PL_op, uninit_sv,0);
13318             if (varname)
13319                 sv_insert(varname, 0, 0, " ", 1);
13320         }
13321         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13322                 varname ? SvPV_nolen_const(varname) : "",
13323                 " in ", OP_DESC(PL_op));
13324     }
13325     else
13326         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13327                     "", "", "");
13328 }
13329
13330 /*
13331  * Local variables:
13332  * c-indentation-style: bsd
13333  * c-basic-offset: 4
13334  * indent-tabs-mode: t
13335  * End:
13336  *
13337  * ex: set ts=8 sts=4 sw=4 noet:
13338  */