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 #ifndef HAS_C99
  36 # if __STDC_VERSION__ >= 199901L && !defined(VMS)
  37 #  define HAS_C99 1
  38 # endif
  39 #endif
  40 #if HAS_C99
  41 # include <stdint.h>
  42 #endif
  43
  44 #define FCALL *f
  45
  46 #ifdef __Lynx__
  47 /* Missing proto on LynxOS */
  48   char *gconvert(double, int, int,  char *);
  49 #endif
  50
  51 #ifdef PERL_UTF8_CACHE_ASSERT
  52 /* if adding more checks watch out for the following tests:
  53  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
  54  *   lib/utf8.t lib/Unicode/Collate/t/index.t
  55  * --jhi
  56  */
  57 #   define ASSERT_UTF8_CACHE(cache) \
  58     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
  59                               assert((cache)[2] <= (cache)[3]); \
  60                               assert((cache)[3] <= (cache)[1]);} \
  61                               } STMT_END
  62 #else
  63 #   define ASSERT_UTF8_CACHE(cache) NOOP
  64 #endif
  65
  66 #ifdef PERL_OLD_COPY_ON_WRITE
  67 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
  68 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
  69 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
  70    on-write.  */
  71 #endif
  72
  73 /* ============================================================================
  74
  75 =head1 Allocation and deallocation of SVs.
  76
  77 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
  78 sv, av, hv...) contains type and reference count information, and for
  79 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
  80 contains fields specific to each type.  Some types store all they need
  81 in the head, so don't have a body.
  82
  83 In all but the most memory-paranoid configurations (ex: PURIFY), heads
  84 and bodies are allocated out of arenas, which by default are
  85 approximately 4K chunks of memory parcelled up into N heads or bodies.
  86 Sv-bodies are allocated by their sv-type, guaranteeing size
  87 consistency needed to allocate safely from arrays.
  88
  89 For SV-heads, the first slot in each arena is reserved, and holds a
  90 link to the next arena, some flags, and a note of the number of slots.
  91 Snaked through each arena chain is a linked list of free items; when
  92 this becomes empty, an extra arena is allocated and divided up into N
  93 items which are threaded into the free list.
  94
  95 SV-bodies are similar, but they use arena-sets by default, which
  96 separate the link and info from the arena itself, and reclaim the 1st
  97 slot in the arena.  SV-bodies are further described later.
  98
  99 The following global variables are associated with arenas:
 100
 101     PL_sv_arenaroot     pointer to list of SV arenas
 102     PL_sv_root          pointer to list of free SV structures
 103
 104     PL_body_arenas      head of linked-list of body arenas
 105     PL_body_roots[]     array of pointers to list of free bodies of svtype
 106                         arrays are indexed by the svtype needed
 107
 108 A few special SV heads are not allocated from an arena, but are
 109 instead directly created in the interpreter structure, eg PL_sv_undef.
 110 The size of arenas can be changed from the default by setting
 111 PERL_ARENA_SIZE appropriately at compile time.
 112
 113 The SV arena serves the secondary purpose of allowing still-live SVs
 114 to be located and destroyed during final cleanup.
 115
 116 At the lowest level, the macros new_SV() and del_SV() grab and free
 117 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
 118 to return the SV to the free list with error checking.) new_SV() calls
 119 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
 120 SVs in the free list have their SvTYPE field set to all ones.
 121
 122 At the time of very final cleanup, sv_free_arenas() is called from
 123 perl_destruct() to physically free all the arenas allocated since the
 124 start of the interpreter.
 125
 126 The function visit() scans the SV arenas list, and calls a specified
 127 function for each SV it finds which is still live - ie which has an SvTYPE
 128 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
 129 following functions (specified as [function that calls visit()] / [function
 130 called by visit() for each SV]):
 131
 132     sv_report_used() / do_report_used()
 133                         dump all remaining SVs (debugging aid)
 134
 135     sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
 136                       do_clean_named_io_objs()
 137                         Attempt to free all objects pointed to by RVs,
 138                         and try to do the same for all objects indirectly
 139                         referenced by typeglobs too.  Called once from
 140                         perl_destruct(), prior to calling sv_clean_all()
 141                         below.
 142
 143     sv_clean_all() / do_clean_all()
 144                         SvREFCNT_dec(sv) each remaining SV, possibly
 145                         triggering an sv_free(). It also sets the
 146                         SVf_BREAK flag on the SV to indicate that the
 147                         refcnt has been artificially lowered, and thus
 148                         stopping sv_free() from giving spurious warnings
 149                         about SVs which unexpectedly have a refcnt
 150                         of zero.  called repeatedly from perl_destruct()
 151                         until there are no SVs left.
 152
 153 =head2 Arena allocator API Summary
 154
 155 Private API to rest of sv.c
 156
 157     new_SV(),  del_SV(),
 158
 159     new_XPVNV(), del_XPVGV(),
 160     etc
 161
 162 Public API:
 163
 164     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
 165
 166 =cut
 167
 168  * ========================================================================= */
 169
 170 /*
 171  * "A time to plant, and a time to uproot what was planted..."
 172  */
 173
 174 #ifdef PERL_MEM_LOG
 175 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
 176             Perl_mem_log_new_sv(sv, file, line, func)
 177 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
 178             Perl_mem_log_del_sv(sv, file, line, func)
 179 #else
 180 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
 181 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
 182 #endif
 183
 184 #ifdef DEBUG_LEAKING_SCALARS
 185 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
 186 #  define DEBUG_SV_SERIAL(sv)                                               \
 187     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
 188             PTR2UV(sv), (long)(sv)->sv_debug_serial))
 189 #else
 190 #  define FREE_SV_DEBUG_FILE(sv)
 191 #  define DEBUG_SV_SERIAL(sv)   NOOP
 192 #endif
 193
 194 #ifdef PERL_POISON
 195 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
 196 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = MUTABLE_SV((val))
 197 /* Whilst I'd love to do this, it seems that things like to check on
 198    unreferenced scalars
 199 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
 200 */
 201 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
 202                                 PoisonNew(&SvREFCNT(sv), 1, U32)
 203 #else
 204 #  define SvARENA_CHAIN(sv)     SvANY(sv)
 205 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
 206 #  define POSION_SV_HEAD(sv)
 207 #endif
 208
 209 /* Mark an SV head as unused, and add to free list.
 210  *
 211  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
 212  * its refcount artificially decremented during global destruction, so
 213  * there may be dangling pointers to it. The last thing we want in that
 214  * case is for it to be reused. */
 215
 216 #define plant_SV(p) \
 217     STMT_START {                                        \
 218         const U32 old_flags = SvFLAGS(p);                       \
 219         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 220         DEBUG_SV_SERIAL(p);                             \
 221         FREE_SV_DEBUG_FILE(p);                          \
 222         POSION_SV_HEAD(p);                              \
 223         SvFLAGS(p) = SVTYPEMASK;                        \
 224         if (!(old_flags & SVf_BREAK)) {         \
 225             SvARENA_CHAIN_SET(p, PL_sv_root);   \
 226             PL_sv_root = (p);                           \
 227         }                                               \
 228         --PL_sv_count;                                  \
 229     } STMT_END
 230
 231 #define uproot_SV(p) \
 232     STMT_START {                                        \
 233         (p) = PL_sv_root;                               \
 234         PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p));              \
 235         ++PL_sv_count;                                  \
 236     } STMT_END
 237
 238
 239 /* make some more SVs by adding another arena */
 240
 241 STATIC SV*
 242 S_more_sv(pTHX)
 243 {
 244     dVAR;
 245     SV* sv;
 246     char *chunk;                /* must use New here to match call to */
 247     Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
 248     sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
 249     uproot_SV(sv);
 250     return sv;
 251 }
 252
 253 /* new_SV(): return a new, empty SV head */
 254
 255 #ifdef DEBUG_LEAKING_SCALARS
 256 /* provide a real function for a debugger to play with */
 257 STATIC SV*
 258 S_new_SV(pTHX_ const char *file, int line, const char *func)
 259 {
 260     SV* sv;
 261
 262     if (PL_sv_root)
 263         uproot_SV(sv);
 264     else
 265         sv = S_more_sv(aTHX);
 266     SvANY(sv) = 0;
 267     SvREFCNT(sv) = 1;
 268     SvFLAGS(sv) = 0;
 269     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
 270     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
 271                 ? PL_parser->copline
 272                 :  PL_curcop
 273                     ? CopLINE(PL_curcop)
 274                     : 0
 275             );
 276     sv->sv_debug_inpad = 0;
 277     sv->sv_debug_parent = NULL;
 278     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 279
 280     sv->sv_debug_serial = PL_sv_serial++;
 281
 282     MEM_LOG_NEW_SV(sv, file, line, func);
 283     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
 284             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
 285
 286     return sv;
 287 }
 288 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
 289
 290 #else
 291 #  define new_SV(p) \
 292     STMT_START {                                        \
 293         if (PL_sv_root)                                 \
 294             uproot_SV(p);                               \
 295         else                                            \
 296             (p) = S_more_sv(aTHX);                      \
 297         SvANY(p) = 0;                                   \
 298         SvREFCNT(p) = 1;                                \
 299         SvFLAGS(p) = 0;                                 \
 300         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 301     } STMT_END
 302 #endif
 303
 304
 305 /* del_SV(): return an empty SV head to the free list */
 306
 307 #ifdef DEBUGGING
 308
 309 #define del_SV(p) \
 310     STMT_START {                                        \
 311         if (DEBUG_D_TEST)                               \
 312             del_sv(p);                                  \
 313         else                                            \
 314             plant_SV(p);                                \
 315     } STMT_END
 316
 317 STATIC void
 318 S_del_sv(pTHX_ SV *p)
 319 {
 320     dVAR;
 321
 322     PERL_ARGS_ASSERT_DEL_SV;
 323
 324     if (DEBUG_D_TEST) {
 325         SV* sva;
 326         bool ok = 0;
 327         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 328             const SV * const sv = sva + 1;
 329             const SV * const svend = &sva[SvREFCNT(sva)];
 330             if (p >= sv && p < svend) {
 331                 ok = 1;
 332                 break;
 333             }
 334         }
 335         if (!ok) {
 336             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
 337                              "Attempt to free non-arena SV: 0x%"UVxf
 338                              pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
 339             return;
 340         }
 341     }
 342     plant_SV(p);
 343 }
 344
 345 #else /* ! DEBUGGING */
 346
 347 #define del_SV(p)   plant_SV(p)
 348
 349 #endif /* DEBUGGING */
 350
 351
 352 /*
 353 =head1 SV Manipulation Functions
 354
 355 =for apidoc sv_add_arena
 356
 357 Given a chunk of memory, link it to the head of the list of arenas,
 358 and split it into a list of free SVs.
 359
 360 =cut
 361 */
 362
 363 static void
 364 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
 365 {
 366     dVAR;
 367     SV *const sva = MUTABLE_SV(ptr);
 368     register SV* sv;
 369     register SV* svend;
 370
 371     PERL_ARGS_ASSERT_SV_ADD_ARENA;
 372
 373     /* The first SV in an arena isn't an SV. */
 374     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 375     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 376     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 377
 378     PL_sv_arenaroot = sva;
 379     PL_sv_root = sva + 1;
 380
 381     svend = &sva[SvREFCNT(sva) - 1];
 382     sv = sva + 1;
 383     while (sv < svend) {
 384         SvARENA_CHAIN_SET(sv, (sv + 1));
 385 #ifdef DEBUGGING
 386         SvREFCNT(sv) = 0;
 387 #endif
 388         /* Must always set typemask because it's always checked in on cleanup
 389            when the arenas are walked looking for objects.  */
 390         SvFLAGS(sv) = SVTYPEMASK;
 391         sv++;
 392     }
 393     SvARENA_CHAIN_SET(sv, 0);
 394 #ifdef DEBUGGING
 395     SvREFCNT(sv) = 0;
 396 #endif
 397     SvFLAGS(sv) = SVTYPEMASK;
 398 }
 399
 400 /* visit(): call the named function for each non-free SV in the arenas
 401  * whose flags field matches the flags/mask args. */
 402
 403 STATIC I32
 404 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
 405 {
 406     dVAR;
 407     SV* sva;
 408     I32 visited = 0;
 409
 410     PERL_ARGS_ASSERT_VISIT;
 411
 412     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 413         register const SV * const svend = &sva[SvREFCNT(sva)];
 414         register SV* sv;
 415         for (sv = sva + 1; sv < svend; ++sv) {
 416             if (SvTYPE(sv) != (svtype)SVTYPEMASK
 417                     && (sv->sv_flags & mask) == flags
 418                     && SvREFCNT(sv))
 419             {
 420                 (FCALL)(aTHX_ sv);
 421                 ++visited;
 422             }
 423         }
 424     }
 425     return visited;
 426 }
 427
 428 #ifdef DEBUGGING
 429
 430 /* called by sv_report_used() for each live SV */
 431
 432 static void
 433 do_report_used(pTHX_ SV *const sv)
 434 {
 435     if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
 436         PerlIO_printf(Perl_debug_log, "****\n");
 437         sv_dump(sv);
 438     }
 439 }
 440 #endif
 441
 442 /*
 443 =for apidoc sv_report_used
 444
 445 Dump the contents of all SVs not yet freed (debugging aid).
 446
 447 =cut
 448 */
 449
 450 void
 451 Perl_sv_report_used(pTHX)
 452 {
 453 #ifdef DEBUGGING
 454     visit(do_report_used, 0, 0);
 455 #else
 456     PERL_UNUSED_CONTEXT;
 457 #endif
 458 }
 459
 460 /* called by sv_clean_objs() for each live SV */
 461
 462 static void
 463 do_clean_objs(pTHX_ SV *const ref)
 464 {
 465     dVAR;
 466     assert (SvROK(ref));
 467     {
 468         SV * const target = SvRV(ref);
 469         if (SvOBJECT(target)) {
 470             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
 471             if (SvWEAKREF(ref)) {
 472                 sv_del_backref(target, ref);
 473                 SvWEAKREF_off(ref);
 474                 SvRV_set(ref, NULL);
 475             } else {
 476                 SvROK_off(ref);
 477                 SvRV_set(ref, NULL);
 478                 SvREFCNT_dec(target);
 479             }
 480         }
 481     }
 482
 483     /* XXX Might want to check arrays, etc. */
 484 }
 485
 486
 487 /* clear any slots in a GV which hold objects - except IO;
 488  * called by sv_clean_objs() for each live GV */
 489
 490 static void
 491 do_clean_named_objs(pTHX_ SV *const sv)
 492 {
 493     dVAR;
 494     SV *obj;
 495     assert(SvTYPE(sv) == SVt_PVGV);
 496     assert(isGV_with_GP(sv));
 497     if (!GvGP(sv))
 498         return;
 499
 500     /* freeing GP entries may indirectly free the current GV;
 501      * hold onto it while we mess with the GP slots */
 502     SvREFCNT_inc(sv);
 503
 504     if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
 505         DEBUG_D((PerlIO_printf(Perl_debug_log,
 506                 "Cleaning named glob SV object:\n "), sv_dump(obj)));
 507         GvSV(sv) = NULL;
 508         SvREFCNT_dec(obj);
 509     }
 510     if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
 511         DEBUG_D((PerlIO_printf(Perl_debug_log,
 512                 "Cleaning named glob AV object:\n "), sv_dump(obj)));
 513         GvAV(sv) = NULL;
 514         SvREFCNT_dec(obj);
 515     }
 516     if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
 517         DEBUG_D((PerlIO_printf(Perl_debug_log,
 518                 "Cleaning named glob HV object:\n "), sv_dump(obj)));
 519         GvHV(sv) = NULL;
 520         SvREFCNT_dec(obj);
 521     }
 522     if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
 523         DEBUG_D((PerlIO_printf(Perl_debug_log,
 524                 "Cleaning named glob CV object:\n "), sv_dump(obj)));
 525         GvCV_set(sv, NULL);
 526         SvREFCNT_dec(obj);
 527     }
 528     SvREFCNT_dec(sv); /* undo the inc above */
 529 }
 530
 531 /* clear any IO slots in a GV which hold objects (except stderr, defout);
 532  * called by sv_clean_objs() for each live GV */
 533
 534 static void
 535 do_clean_named_io_objs(pTHX_ SV *const sv)
 536 {
 537     dVAR;
 538     SV *obj;
 539     assert(SvTYPE(sv) == SVt_PVGV);
 540     assert(isGV_with_GP(sv));
 541     if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
 542         return;
 543
 544     SvREFCNT_inc(sv);
 545     if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
 546         DEBUG_D((PerlIO_printf(Perl_debug_log,
 547                 "Cleaning named glob IO object:\n "), sv_dump(obj)));
 548         GvIOp(sv) = NULL;
 549         SvREFCNT_dec(obj);
 550     }
 551     SvREFCNT_dec(sv); /* undo the inc above */
 552 }
 553
 554 /* Void wrapper to pass to visit() */
 555 static void
 556 do_curse(pTHX_ SV * const sv) {
 557     if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
 558      || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
 559         return;
 560     (void)curse(sv, 0);
 561 }
 562
 563 /*
 564 =for apidoc sv_clean_objs
 565
 566 Attempt to destroy all objects not yet freed.
 567
 568 =cut
 569 */
 570
 571 void
 572 Perl_sv_clean_objs(pTHX)
 573 {
 574     dVAR;
 575     GV *olddef, *olderr;
 576     PL_in_clean_objs = TRUE;
 577     visit(do_clean_objs, SVf_ROK, SVf_ROK);
 578     /* Some barnacles may yet remain, clinging to typeglobs.
 579      * Run the non-IO destructors first: they may want to output
 580      * error messages, close files etc */
 581     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
 582     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
 583     /* And if there are some very tenacious barnacles clinging to arrays,
 584        closures, or what have you.... */
 585     visit(do_curse, SVs_OBJECT, SVs_OBJECT);
 586     olddef = PL_defoutgv;
 587     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
 588     if (olddef && isGV_with_GP(olddef))
 589         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
 590     olderr = PL_stderrgv;
 591     PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
 592     if (olderr && isGV_with_GP(olderr))
 593         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
 594     SvREFCNT_dec(olddef);
 595     PL_in_clean_objs = FALSE;
 596 }
 597
 598 /* called by sv_clean_all() for each live SV */
 599
 600 static void
 601 do_clean_all(pTHX_ SV *const sv)
 602 {
 603     dVAR;
 604     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
 605         /* don't clean pid table and strtab */
 606         return;
 607     }
 608     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
 609     SvFLAGS(sv) |= SVf_BREAK;
 610     SvREFCNT_dec(sv);
 611 }
 612
 613 /*
 614 =for apidoc sv_clean_all
 615
 616 Decrement the refcnt of each remaining SV, possibly triggering a
 617 cleanup.  This function may have to be called multiple times to free
 618 SVs which are in complex self-referential hierarchies.
 619
 620 =cut
 621 */
 622
 623 I32
 624 Perl_sv_clean_all(pTHX)
 625 {
 626     dVAR;
 627     I32 cleaned;
 628     PL_in_clean_all = TRUE;
 629     cleaned = visit(do_clean_all, 0,0);
 630     return cleaned;
 631 }
 632
 633 /*
 634   ARENASETS: a meta-arena implementation which separates arena-info
 635   into struct arena_set, which contains an array of struct
 636   arena_descs, each holding info for a single arena.  By separating
 637   the meta-info from the arena, we recover the 1st slot, formerly
 638   borrowed for list management.  The arena_set is about the size of an
 639   arena, avoiding the needless malloc overhead of a naive linked-list.
 640
 641   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
 642   memory in the last arena-set (1/2 on average).  In trade, we get
 643   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
 644   smaller types).  The recovery of the wasted space allows use of
 645   small arenas for large, rare body types, by changing array* fields
 646   in body_details_by_type[] below.
 647 */
 648 struct arena_desc {
 649     char       *arena;          /* the raw storage, allocated aligned */
 650     size_t      size;           /* its size ~4k typ */
 651     svtype      utype;          /* bodytype stored in arena */
 652 };
 653
 654 struct arena_set;
 655
 656 /* Get the maximum number of elements in set[] such that struct arena_set
 657    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
 658    therefore likely to be 1 aligned memory page.  */
 659
 660 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
 661                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
 662
 663 struct arena_set {
 664     struct arena_set* next;
 665     unsigned int   set_size;    /* ie ARENAS_PER_SET */
 666     unsigned int   curr;        /* index of next available arena-desc */
 667     struct arena_desc set[ARENAS_PER_SET];
 668 };
 669
 670 /*
 671 =for apidoc sv_free_arenas
 672
 673 Deallocate the memory used by all arenas.  Note that all the individual SV
 674 heads and bodies within the arenas must already have been freed.
 675
 676 =cut
 677 */
 678 void
 679 Perl_sv_free_arenas(pTHX)
 680 {
 681     dVAR;
 682     SV* sva;
 683     SV* svanext;
 684     unsigned int i;
 685
 686     /* Free arenas here, but be careful about fake ones.  (We assume
 687        contiguity of the fake ones with the corresponding real ones.) */
 688
 689     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 690         svanext = MUTABLE_SV(SvANY(sva));
 691         while (svanext && SvFAKE(svanext))
 692             svanext = MUTABLE_SV(SvANY(svanext));
 693
 694         if (!SvFAKE(sva))
 695             Safefree(sva);
 696     }
 697
 698     {
 699         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 700
 701         while (aroot) {
 702             struct arena_set *current = aroot;
 703             i = aroot->curr;
 704             while (i--) {
 705                 assert(aroot->set[i].arena);
 706                 Safefree(aroot->set[i].arena);
 707             }
 708             aroot = aroot->next;
 709             Safefree(current);
 710         }
 711     }
 712     PL_body_arenas = 0;
 713
 714     i = PERL_ARENA_ROOTS_SIZE;
 715     while (i--)
 716         PL_body_roots[i] = 0;
 717
 718     PL_sv_arenaroot = 0;
 719     PL_sv_root = 0;
 720 }
 721
 722 /*
 723   Here are mid-level routines that manage the allocation of bodies out
 724   of the various arenas.  There are 5 kinds of arenas:
 725
 726   1. SV-head arenas, which are discussed and handled above
 727   2. regular body arenas
 728   3. arenas for reduced-size bodies
 729   4. Hash-Entry arenas
 730
 731   Arena types 2 & 3 are chained by body-type off an array of
 732   arena-root pointers, which is indexed by svtype.  Some of the
 733   larger/less used body types are malloced singly, since a large
 734   unused block of them is wasteful.  Also, several svtypes dont have
 735   bodies; the data fits into the sv-head itself.  The arena-root
 736   pointer thus has a few unused root-pointers (which may be hijacked
 737   later for arena types 4,5)
 738
 739   3 differs from 2 as an optimization; some body types have several
 740   unused fields in the front of the structure (which are kept in-place
 741   for consistency).  These bodies can be allocated in smaller chunks,
 742   because the leading fields arent accessed.  Pointers to such bodies
 743   are decremented to point at the unused 'ghost' memory, knowing that
 744   the pointers are used with offsets to the real memory.
 745
 746
 747 =head1 SV-Body Allocation
 748
 749 Allocation of SV-bodies is similar to SV-heads, differing as follows;
 750 the allocation mechanism is used for many body types, so is somewhat
 751 more complicated, it uses arena-sets, and has no need for still-live
 752 SV detection.
 753
 754 At the outermost level, (new|del)_X*V macros return bodies of the
 755 appropriate type.  These macros call either (new|del)_body_type or
 756 (new|del)_body_allocated macro pairs, depending on specifics of the
 757 type.  Most body types use the former pair, the latter pair is used to
 758 allocate body types with "ghost fields".
 759
 760 "ghost fields" are fields that are unused in certain types, and
 761 consequently don't need to actually exist.  They are declared because
 762 they're part of a "base type", which allows use of functions as
 763 methods.  The simplest examples are AVs and HVs, 2 aggregate types
 764 which don't use the fields which support SCALAR semantics.
 765
 766 For these types, the arenas are carved up into appropriately sized
 767 chunks, we thus avoid wasted memory for those unaccessed members.
 768 When bodies are allocated, we adjust the pointer back in memory by the
 769 size of the part not allocated, so it's as if we allocated the full
 770 structure.  (But things will all go boom if you write to the part that
 771 is "not there", because you'll be overwriting the last members of the
 772 preceding structure in memory.)
 773
 774 We calculate the correction using the STRUCT_OFFSET macro on the first
 775 member present. If the allocated structure is smaller (no initial NV
 776 actually allocated) then the net effect is to subtract the size of the NV
 777 from the pointer, to return a new pointer as if an initial NV were actually
 778 allocated. (We were using structures named *_allocated for this, but
 779 this turned out to be a subtle bug, because a structure without an NV
 780 could have a lower alignment constraint, but the compiler is allowed to
 781 optimised accesses based on the alignment constraint of the actual pointer
 782 to the full structure, for example, using a single 64 bit load instruction
 783 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
 784
 785 This is the same trick as was used for NV and IV bodies. Ironically it
 786 doesn't need to be used for NV bodies any more, because NV is now at
 787 the start of the structure. IV bodies don't need it either, because
 788 they are no longer allocated.
 789
 790 In turn, the new_body_* allocators call S_new_body(), which invokes
 791 new_body_inline macro, which takes a lock, and takes a body off the
 792 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
 793 necessary to refresh an empty list.  Then the lock is released, and
 794 the body is returned.
 795
 796 Perl_more_bodies allocates a new arena, and carves it up into an array of N
 797 bodies, which it strings into a linked list.  It looks up arena-size
 798 and body-size from the body_details table described below, thus
 799 supporting the multiple body-types.
 800
 801 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
 802 the (new|del)_X*V macros are mapped directly to malloc/free.
 803
 804 For each sv-type, struct body_details bodies_by_type[] carries
 805 parameters which control these aspects of SV handling:
 806
 807 Arena_size determines whether arenas are used for this body type, and if
 808 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
 809 zero, forcing individual mallocs and frees.
 810
 811 Body_size determines how big a body is, and therefore how many fit into
 812 each arena.  Offset carries the body-pointer adjustment needed for
 813 "ghost fields", and is used in *_allocated macros.
 814
 815 But its main purpose is to parameterize info needed in
 816 Perl_sv_upgrade().  The info here dramatically simplifies the function
 817 vs the implementation in 5.8.8, making it table-driven.  All fields
 818 are used for this, except for arena_size.
 819
 820 For the sv-types that have no bodies, arenas are not used, so those
 821 PL_body_roots[sv_type] are unused, and can be overloaded.  In
 822 something of a special case, SVt_NULL is borrowed for HE arenas;
 823 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
 824 bodies_by_type[SVt_NULL] slot is not used, as the table is not
 825 available in hv.c.
 826
 827 */
 828
 829 struct body_details {
 830     U8 body_size;       /* Size to allocate  */
 831     U8 copy;            /* Size of structure to copy (may be shorter)  */
 832     U8 offset;
 833     unsigned int type : 4;          /* We have space for a sanity check.  */
 834     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
 835     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
 836     unsigned int arena : 1;         /* Allocated from an arena */
 837     size_t arena_size;              /* Size of arena to allocate */
 838 };
 839
 840 #define HADNV FALSE
 841 #define NONV TRUE
 842
 843
 844 #ifdef PURIFY
 845 /* With -DPURFIY we allocate everything directly, and don't use arenas.
 846    This seems a rather elegant way to simplify some of the code below.  */
 847 #define HASARENA FALSE
 848 #else
 849 #define HASARENA TRUE
 850 #endif
 851 #define NOARENA FALSE
 852
 853 /* Size the arenas to exactly fit a given number of bodies.  A count
 854    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
 855    simplifying the default.  If count > 0, the arena is sized to fit
 856    only that many bodies, allowing arenas to be used for large, rare
 857    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
 858    limited by PERL_ARENA_SIZE, so we can safely oversize the
 859    declarations.
 860  */
 861 #define FIT_ARENA0(body_size)                           \
 862     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
 863 #define FIT_ARENAn(count,body_size)                     \
 864     ( count * body_size <= PERL_ARENA_SIZE)             \
 865     ? count * body_size                                 \
 866     : FIT_ARENA0 (body_size)
 867 #define FIT_ARENA(count,body_size)                      \
 868     count                                               \
 869     ? FIT_ARENAn (count, body_size)                     \
 870     : FIT_ARENA0 (body_size)
 871
 872 /* Calculate the length to copy. Specifically work out the length less any
 873    final padding the compiler needed to add.  See the comment in sv_upgrade
 874    for why copying the padding proved to be a bug.  */
 875
 876 #define copy_length(type, last_member) \
 877         STRUCT_OFFSET(type, last_member) \
 878         + sizeof (((type*)SvANY((const SV *)0))->last_member)
 879
 880 static const struct body_details bodies_by_type[] = {
 881     /* HEs use this offset for their arena.  */
 882     { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
 883
 884     /* The bind placeholder pretends to be an RV for now.
 885        Also it's marked as "can't upgrade" to stop anyone using it before it's
 886        implemented.  */
 887     { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
 888
 889     /* IVs are in the head, so the allocation size is 0.  */
 890     { 0,
 891       sizeof(IV), /* This is used to copy out the IV body.  */
 892       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
 893       NOARENA /* IVS don't need an arena  */, 0
 894     },
 895
 896     { sizeof(NV), sizeof(NV),
 897       STRUCT_OFFSET(XPVNV, xnv_u),
 898       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
 899
 900     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
 901       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
 902       + STRUCT_OFFSET(XPV, xpv_cur),
 903       SVt_PV, FALSE, NONV, HASARENA,
 904       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 905
 906     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
 907       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 908       + STRUCT_OFFSET(XPV, xpv_cur),
 909       SVt_PVIV, FALSE, NONV, HASARENA,
 910       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 911
 912     { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
 913       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 914       + STRUCT_OFFSET(XPV, xpv_cur),
 915       SVt_PVNV, FALSE, HADNV, HASARENA,
 916       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 917
 918     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
 919       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 920
 921     { sizeof(regexp),
 922       sizeof(regexp),
 923       0,
 924       SVt_REGEXP, FALSE, NONV, HASARENA,
 925       FIT_ARENA(0, sizeof(regexp))
 926     },
 927
 928     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
 929       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
 930
 931     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
 932       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
 933
 934     { sizeof(XPVAV),
 935       copy_length(XPVAV, xav_alloc),
 936       0,
 937       SVt_PVAV, TRUE, NONV, HASARENA,
 938       FIT_ARENA(0, sizeof(XPVAV)) },
 939
 940     { sizeof(XPVHV),
 941       copy_length(XPVHV, xhv_max),
 942       0,
 943       SVt_PVHV, TRUE, NONV, HASARENA,
 944       FIT_ARENA(0, sizeof(XPVHV)) },
 945
 946     { sizeof(XPVCV),
 947       sizeof(XPVCV),
 948       0,
 949       SVt_PVCV, TRUE, NONV, HASARENA,
 950       FIT_ARENA(0, sizeof(XPVCV)) },
 951
 952     { sizeof(XPVFM),
 953       sizeof(XPVFM),
 954       0,
 955       SVt_PVFM, TRUE, NONV, NOARENA,
 956       FIT_ARENA(20, sizeof(XPVFM)) },
 957
 958     { sizeof(XPVIO),
 959       sizeof(XPVIO),
 960       0,
 961       SVt_PVIO, TRUE, NONV, HASARENA,
 962       FIT_ARENA(24, sizeof(XPVIO)) },
 963 };
 964
 965 #define new_body_allocated(sv_type)             \
 966     (void *)((char *)S_new_body(aTHX_ sv_type)  \
 967              - bodies_by_type[sv_type].offset)
 968
 969 /* return a thing to the free list */
 970
 971 #define del_body(thing, root)                           \
 972     STMT_START {                                        \
 973         void ** const thing_copy = (void **)thing;      \
 974         *thing_copy = *root;                            \
 975         *root = (void*)thing_copy;                      \
 976     } STMT_END
 977
 978 #ifdef PURIFY
 979
 980 #define new_XNV()       safemalloc(sizeof(XPVNV))
 981 #define new_XPVNV()     safemalloc(sizeof(XPVNV))
 982 #define new_XPVMG()     safemalloc(sizeof(XPVMG))
 983
 984 #define del_XPVGV(p)    safefree(p)
 985
 986 #else /* !PURIFY */
 987
 988 #define new_XNV()       new_body_allocated(SVt_NV)
 989 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
 990 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
 991
 992 #define del_XPVGV(p)    del_body(p + bodies_by_type[SVt_PVGV].offset,   \
 993                                  &PL_body_roots[SVt_PVGV])
 994
 995 #endif /* PURIFY */
 996
 997 /* no arena for you! */
 998
 999 #define new_NOARENA(details) \
1000         safemalloc((details)->body_size + (details)->offset)
1001 #define new_NOARENAZ(details) \
1002         safecalloc((details)->body_size + (details)->offset, 1)
1003
1004 void *
1005 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1006                   const size_t arena_size)
1007 {
1008     dVAR;
1009     void ** const root = &PL_body_roots[sv_type];
1010     struct arena_desc *adesc;
1011     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1012     unsigned int curr;
1013     char *start;
1014     const char *end;
1015     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1016 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1017     static bool done_sanity_check;
1018
1019     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1020      * variables like done_sanity_check. */
1021     if (!done_sanity_check) {
1022         unsigned int i = SVt_LAST;
1023
1024         done_sanity_check = TRUE;
1025
1026         while (i--)
1027             assert (bodies_by_type[i].type == i);
1028     }
1029 #endif
1030
1031     assert(arena_size);
1032
1033     /* may need new arena-set to hold new arena */
1034     if (!aroot || aroot->curr >= aroot->set_size) {
1035         struct arena_set *newroot;
1036         Newxz(newroot, 1, struct arena_set);
1037         newroot->set_size = ARENAS_PER_SET;
1038         newroot->next = aroot;
1039         aroot = newroot;
1040         PL_body_arenas = (void *) newroot;
1041         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1042     }
1043
1044     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1045     curr = aroot->curr++;
1046     adesc = &(aroot->set[curr]);
1047     assert(!adesc->arena);
1048
1049     Newx(adesc->arena, good_arena_size, char);
1050     adesc->size = good_arena_size;
1051     adesc->utype = sv_type;
1052     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1053                           curr, (void*)adesc->arena, (UV)good_arena_size));
1054
1055     start = (char *) adesc->arena;
1056
1057     /* Get the address of the byte after the end of the last body we can fit.
1058        Remember, this is integer division:  */
1059     end = start + good_arena_size / body_size * body_size;
1060
1061     /* computed count doesn't reflect the 1st slot reservation */
1062 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1063     DEBUG_m(PerlIO_printf(Perl_debug_log,
1064                           "arena %p end %p arena-size %d (from %d) type %d "
1065                           "size %d ct %d\n",
1066                           (void*)start, (void*)end, (int)good_arena_size,
1067                           (int)arena_size, sv_type, (int)body_size,
1068                           (int)good_arena_size / (int)body_size));
1069 #else
1070     DEBUG_m(PerlIO_printf(Perl_debug_log,
1071                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1072                           (void*)start, (void*)end,
1073                           (int)arena_size, sv_type, (int)body_size,
1074                           (int)good_arena_size / (int)body_size));
1075 #endif
1076     *root = (void *)start;
1077
1078     while (1) {
1079         /* Where the next body would start:  */
1080         char * const next = start + body_size;
1081
1082         if (next >= end) {
1083             /* This is the last body:  */
1084             assert(next == end);
1085
1086             *(void **)start = 0;
1087             return *root;
1088         }
1089
1090         *(void**) start = (void *)next;
1091         start = next;
1092     }
1093 }
1094
1095 /* grab a new thing from the free list, allocating more if necessary.
1096    The inline version is used for speed in hot routines, and the
1097    function using it serves the rest (unless PURIFY).
1098 */
1099 #define new_body_inline(xpv, sv_type) \
1100     STMT_START { \
1101         void ** const r3wt = &PL_body_roots[sv_type]; \
1102         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1103           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1104                                              bodies_by_type[sv_type].body_size,\
1105                                              bodies_by_type[sv_type].arena_size)); \
1106         *(r3wt) = *(void**)(xpv); \
1107     } STMT_END
1108
1109 #ifndef PURIFY
1110
1111 STATIC void *
1112 S_new_body(pTHX_ const svtype sv_type)
1113 {
1114     dVAR;
1115     void *xpv;
1116     new_body_inline(xpv, sv_type);
1117     return xpv;
1118 }
1119
1120 #endif
1121
1122 static const struct body_details fake_rv =
1123     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1124
1125 /*
1126 =for apidoc sv_upgrade
1127
1128 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1129 SV, then copies across as much information as possible from the old body.
1130 It croaks if the SV is already in a more complex form than requested.  You
1131 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1132 before calling C<sv_upgrade>, and hence does not croak.  See also
1133 C<svtype>.
1134
1135 =cut
1136 */
1137
1138 void
1139 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1140 {
1141     dVAR;
1142     void*       old_body;
1143     void*       new_body;
1144     const svtype old_type = SvTYPE(sv);
1145     const struct body_details *new_type_details;
1146     const struct body_details *old_type_details
1147         = bodies_by_type + old_type;
1148     SV *referant = NULL;
1149
1150     PERL_ARGS_ASSERT_SV_UPGRADE;
1151
1152     if (old_type == new_type)
1153         return;
1154
1155     /* This clause was purposefully added ahead of the early return above to
1156        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1157        inference by Nick I-S that it would fix other troublesome cases. See
1158        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1159
1160        Given that shared hash key scalars are no longer PVIV, but PV, there is
1161        no longer need to unshare so as to free up the IVX slot for its proper
1162        purpose. So it's safe to move the early return earlier.  */
1163
1164     if (new_type != SVt_PV && SvIsCOW(sv)) {
1165         sv_force_normal_flags(sv, 0);
1166     }
1167
1168     old_body = SvANY(sv);
1169
1170     /* Copying structures onto other structures that have been neatly zeroed
1171        has a subtle gotcha. Consider XPVMG
1172
1173        +------+------+------+------+------+-------+-------+
1174        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1175        +------+------+------+------+------+-------+-------+
1176        0      4      8     12     16     20      24      28
1177
1178        where NVs are aligned to 8 bytes, so that sizeof that structure is
1179        actually 32 bytes long, with 4 bytes of padding at the end:
1180
1181        +------+------+------+------+------+-------+-------+------+
1182        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1183        +------+------+------+------+------+-------+-------+------+
1184        0      4      8     12     16     20      24      28     32
1185
1186        so what happens if you allocate memory for this structure:
1187
1188        +------+------+------+------+------+-------+-------+------+------+...
1189        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1190        +------+------+------+------+------+-------+-------+------+------+...
1191        0      4      8     12     16     20      24      28     32     36
1192
1193        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1194        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1195        started out as zero once, but it's quite possible that it isn't. So now,
1196        rather than a nicely zeroed GP, you have it pointing somewhere random.
1197        Bugs ensue.
1198
1199        (In fact, GP ends up pointing at a previous GP structure, because the
1200        principle cause of the padding in XPVMG getting garbage is a copy of
1201        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1202        this happens to be moot because XPVGV has been re-ordered, with GP
1203        no longer after STASH)
1204
1205        So we are careful and work out the size of used parts of all the
1206        structures.  */
1207
1208     switch (old_type) {
1209     case SVt_NULL:
1210         break;
1211     case SVt_IV:
1212         if (SvROK(sv)) {
1213             referant = SvRV(sv);
1214             old_type_details = &fake_rv;
1215             if (new_type == SVt_NV)
1216                 new_type = SVt_PVNV;
1217         } else {
1218             if (new_type < SVt_PVIV) {
1219                 new_type = (new_type == SVt_NV)
1220                     ? SVt_PVNV : SVt_PVIV;
1221             }
1222         }
1223         break;
1224     case SVt_NV:
1225         if (new_type < SVt_PVNV) {
1226             new_type = SVt_PVNV;
1227         }
1228         break;
1229     case SVt_PV:
1230         assert(new_type > SVt_PV);
1231         assert(SVt_IV < SVt_PV);
1232         assert(SVt_NV < SVt_PV);
1233         break;
1234     case SVt_PVIV:
1235         break;
1236     case SVt_PVNV:
1237         break;
1238     case SVt_PVMG:
1239         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1240            there's no way that it can be safely upgraded, because perl.c
1241            expects to Safefree(SvANY(PL_mess_sv))  */
1242         assert(sv != PL_mess_sv);
1243         /* This flag bit is used to mean other things in other scalar types.
1244            Given that it only has meaning inside the pad, it shouldn't be set
1245            on anything that can get upgraded.  */
1246         assert(!SvPAD_TYPED(sv));
1247         break;
1248     default:
1249         if (old_type_details->cant_upgrade)
1250             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1251                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1252     }
1253
1254     if (old_type > new_type)
1255         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1256                 (int)old_type, (int)new_type);
1257
1258     new_type_details = bodies_by_type + new_type;
1259
1260     SvFLAGS(sv) &= ~SVTYPEMASK;
1261     SvFLAGS(sv) |= new_type;
1262
1263     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1264        the return statements above will have triggered.  */
1265     assert (new_type != SVt_NULL);
1266     switch (new_type) {
1267     case SVt_IV:
1268         assert(old_type == SVt_NULL);
1269         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1270         SvIV_set(sv, 0);
1271         return;
1272     case SVt_NV:
1273         assert(old_type == SVt_NULL);
1274         SvANY(sv) = new_XNV();
1275         SvNV_set(sv, 0);
1276         return;
1277     case SVt_PVHV:
1278     case SVt_PVAV:
1279         assert(new_type_details->body_size);
1280
1281 #ifndef PURIFY
1282         assert(new_type_details->arena);
1283         assert(new_type_details->arena_size);
1284         /* This points to the start of the allocated area.  */
1285         new_body_inline(new_body, new_type);
1286         Zero(new_body, new_type_details->body_size, char);
1287         new_body = ((char *)new_body) - new_type_details->offset;
1288 #else
1289         /* We always allocated the full length item with PURIFY. To do this
1290            we fake things so that arena is false for all 16 types..  */
1291         new_body = new_NOARENAZ(new_type_details);
1292 #endif
1293         SvANY(sv) = new_body;
1294         if (new_type == SVt_PVAV) {
1295             AvMAX(sv)   = -1;
1296             AvFILLp(sv) = -1;
1297             AvREAL_only(sv);
1298             if (old_type_details->body_size) {
1299                 AvALLOC(sv) = 0;
1300             } else {
1301                 /* It will have been zeroed when the new body was allocated.
1302                    Lets not write to it, in case it confuses a write-back
1303                    cache.  */
1304             }
1305         } else {
1306             assert(!SvOK(sv));
1307             SvOK_off(sv);
1308 #ifndef NODEFAULT_SHAREKEYS
1309             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1310 #endif
1311             HvMAX(sv) = 7; /* (start with 8 buckets) */
1312         }
1313
1314         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1315            The target created by newSVrv also is, and it can have magic.
1316            However, it never has SvPVX set.
1317         */
1318         if (old_type == SVt_IV) {
1319             assert(!SvROK(sv));
1320         } else if (old_type >= SVt_PV) {
1321             assert(SvPVX_const(sv) == 0);
1322         }
1323
1324         if (old_type >= SVt_PVMG) {
1325             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1326             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1327         } else {
1328             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1329         }
1330         break;
1331
1332
1333     case SVt_REGEXP:
1334         /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1335            sv_force_normal_flags(sv) is called.  */
1336         SvFAKE_on(sv);
1337     case SVt_PVIV:
1338         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1339            no route from NV to PVIV, NOK can never be true  */
1340         assert(!SvNOKp(sv));
1341         assert(!SvNOK(sv));
1342     case SVt_PVIO:
1343     case SVt_PVFM:
1344     case SVt_PVGV:
1345     case SVt_PVCV:
1346     case SVt_PVLV:
1347     case SVt_PVMG:
1348     case SVt_PVNV:
1349     case SVt_PV:
1350
1351         assert(new_type_details->body_size);
1352         /* We always allocated the full length item with PURIFY. To do this
1353            we fake things so that arena is false for all 16 types..  */
1354         if(new_type_details->arena) {
1355             /* This points to the start of the allocated area.  */
1356             new_body_inline(new_body, new_type);
1357             Zero(new_body, new_type_details->body_size, char);
1358             new_body = ((char *)new_body) - new_type_details->offset;
1359         } else {
1360             new_body = new_NOARENAZ(new_type_details);
1361         }
1362         SvANY(sv) = new_body;
1363
1364         if (old_type_details->copy) {
1365             /* There is now the potential for an upgrade from something without
1366                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1367             int offset = old_type_details->offset;
1368             int length = old_type_details->copy;
1369
1370             if (new_type_details->offset > old_type_details->offset) {
1371                 const int difference
1372                     = new_type_details->offset - old_type_details->offset;
1373                 offset += difference;
1374                 length -= difference;
1375             }
1376             assert (length >= 0);
1377
1378             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1379                  char);
1380         }
1381
1382 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1383         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1384          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1385          * NV slot, but the new one does, then we need to initialise the
1386          * freshly created NV slot with whatever the correct bit pattern is
1387          * for 0.0  */
1388         if (old_type_details->zero_nv && !new_type_details->zero_nv
1389             && !isGV_with_GP(sv))
1390             SvNV_set(sv, 0);
1391 #endif
1392
1393         if (new_type == SVt_PVIO) {
1394             IO * const io = MUTABLE_IO(sv);
1395             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1396
1397             SvOBJECT_on(io);
1398             /* Clear the stashcache because a new IO could overrule a package
1399                name */
1400             hv_clear(PL_stashcache);
1401
1402             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1403             IoPAGE_LEN(sv) = 60;
1404         }
1405         if (old_type < SVt_PV) {
1406             /* referant will be NULL unless the old type was SVt_IV emulating
1407                SVt_RV */
1408             sv->sv_u.svu_rv = referant;
1409         }
1410         break;
1411     default:
1412         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1413                    (unsigned long)new_type);
1414     }
1415
1416     if (old_type > SVt_IV) {
1417 #ifdef PURIFY
1418         safefree(old_body);
1419 #else
1420         /* Note that there is an assumption that all bodies of types that
1421            can be upgraded came from arenas. Only the more complex non-
1422            upgradable types are allowed to be directly malloc()ed.  */
1423         assert(old_type_details->arena);
1424         del_body((void*)((char*)old_body + old_type_details->offset),
1425                  &PL_body_roots[old_type]);
1426 #endif
1427     }
1428 }
1429
1430 /*
1431 =for apidoc sv_backoff
1432
1433 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1434 wrapper instead.
1435
1436 =cut
1437 */
1438
1439 int
1440 Perl_sv_backoff(pTHX_ register SV *const sv)
1441 {
1442     STRLEN delta;
1443     const char * const s = SvPVX_const(sv);
1444
1445     PERL_ARGS_ASSERT_SV_BACKOFF;
1446     PERL_UNUSED_CONTEXT;
1447
1448     assert(SvOOK(sv));
1449     assert(SvTYPE(sv) != SVt_PVHV);
1450     assert(SvTYPE(sv) != SVt_PVAV);
1451
1452     SvOOK_offset(sv, delta);
1453
1454     SvLEN_set(sv, SvLEN(sv) + delta);
1455     SvPV_set(sv, SvPVX(sv) - delta);
1456     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1457     SvFLAGS(sv) &= ~SVf_OOK;
1458     return 0;
1459 }
1460
1461 /*
1462 =for apidoc sv_grow
1463
1464 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1465 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1466 Use the C<SvGROW> wrapper instead.
1467
1468 =cut
1469 */
1470
1471 char *
1472 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1473 {
1474     register char *s;
1475
1476     PERL_ARGS_ASSERT_SV_GROW;
1477
1478     if (PL_madskills && newlen >= 0x100000) {
1479         PerlIO_printf(Perl_debug_log,
1480                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1481     }
1482 #ifdef HAS_64K_LIMIT
1483     if (newlen >= 0x10000) {
1484         PerlIO_printf(Perl_debug_log,
1485                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1486         my_exit(1);
1487     }
1488 #endif /* HAS_64K_LIMIT */
1489     if (SvROK(sv))
1490         sv_unref(sv);
1491     if (SvTYPE(sv) < SVt_PV) {
1492         sv_upgrade(sv, SVt_PV);
1493         s = SvPVX_mutable(sv);
1494     }
1495     else if (SvOOK(sv)) {       /* pv is offset? */
1496         sv_backoff(sv);
1497         s = SvPVX_mutable(sv);
1498         if (newlen > SvLEN(sv))
1499             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1500 #ifdef HAS_64K_LIMIT
1501         if (newlen >= 0x10000)
1502             newlen = 0xFFFF;
1503 #endif
1504     }
1505     else
1506         s = SvPVX_mutable(sv);
1507
1508     if (newlen > SvLEN(sv)) {           /* need more room? */
1509         STRLEN minlen = SvCUR(sv);
1510         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1511         if (newlen < minlen)
1512             newlen = minlen;
1513 #ifndef Perl_safesysmalloc_size
1514         newlen = PERL_STRLEN_ROUNDUP(newlen);
1515 #endif
1516         if (SvLEN(sv) && s) {
1517             s = (char*)saferealloc(s, newlen);
1518         }
1519         else {
1520             s = (char*)safemalloc(newlen);
1521             if (SvPVX_const(sv) && SvCUR(sv)) {
1522                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1523             }
1524         }
1525         SvPV_set(sv, s);
1526 #ifdef Perl_safesysmalloc_size
1527         /* Do this here, do it once, do it right, and then we will never get
1528            called back into sv_grow() unless there really is some growing
1529            needed.  */
1530         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1531 #else
1532         SvLEN_set(sv, newlen);
1533 #endif
1534     }
1535     return s;
1536 }
1537
1538 /*
1539 =for apidoc sv_setiv
1540
1541 Copies an integer into the given SV, upgrading first if necessary.
1542 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1543
1544 =cut
1545 */
1546
1547 void
1548 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1549 {
1550     dVAR;
1551
1552     PERL_ARGS_ASSERT_SV_SETIV;
1553
1554     SV_CHECK_THINKFIRST_COW_DROP(sv);
1555     switch (SvTYPE(sv)) {
1556     case SVt_NULL:
1557     case SVt_NV:
1558         sv_upgrade(sv, SVt_IV);
1559         break;
1560     case SVt_PV:
1561         sv_upgrade(sv, SVt_PVIV);
1562         break;
1563
1564     case SVt_PVGV:
1565         if (!isGV_with_GP(sv))
1566             break;
1567     case SVt_PVAV:
1568     case SVt_PVHV:
1569     case SVt_PVCV:
1570     case SVt_PVFM:
1571     case SVt_PVIO:
1572         /* diag_listed_as: Can't coerce %s to %s in %s */
1573         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1574                    OP_DESC(PL_op));
1575     default: NOOP;
1576     }
1577     (void)SvIOK_only(sv);                       /* validate number */
1578     SvIV_set(sv, i);
1579     SvTAINT(sv);
1580 }
1581
1582 /*
1583 =for apidoc sv_setiv_mg
1584
1585 Like C<sv_setiv>, but also handles 'set' magic.
1586
1587 =cut
1588 */
1589
1590 void
1591 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1592 {
1593     PERL_ARGS_ASSERT_SV_SETIV_MG;
1594
1595     sv_setiv(sv,i);
1596     SvSETMAGIC(sv);
1597 }
1598
1599 /*
1600 =for apidoc sv_setuv
1601
1602 Copies an unsigned integer into the given SV, upgrading first if necessary.
1603 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1604
1605 =cut
1606 */
1607
1608 void
1609 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1610 {
1611     PERL_ARGS_ASSERT_SV_SETUV;
1612
1613     /* With the if statement to ensure that integers are stored as IVs whenever
1614        possible:
1615        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1616
1617        without
1618        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1619
1620        If you wish to remove the following if statement, so that this routine
1621        (and its callers) always return UVs, please benchmark to see what the
1622        effect is. Modern CPUs may be different. Or may not :-)
1623     */
1624     if (u <= (UV)IV_MAX) {
1625        sv_setiv(sv, (IV)u);
1626        return;
1627     }
1628     sv_setiv(sv, 0);
1629     SvIsUV_on(sv);
1630     SvUV_set(sv, u);
1631 }
1632
1633 /*
1634 =for apidoc sv_setuv_mg
1635
1636 Like C<sv_setuv>, but also handles 'set' magic.
1637
1638 =cut
1639 */
1640
1641 void
1642 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1643 {
1644     PERL_ARGS_ASSERT_SV_SETUV_MG;
1645
1646     sv_setuv(sv,u);
1647     SvSETMAGIC(sv);
1648 }
1649
1650 /*
1651 =for apidoc sv_setnv
1652
1653 Copies a double into the given SV, upgrading first if necessary.
1654 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1655
1656 =cut
1657 */
1658
1659 void
1660 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1661 {
1662     dVAR;
1663
1664     PERL_ARGS_ASSERT_SV_SETNV;
1665
1666     SV_CHECK_THINKFIRST_COW_DROP(sv);
1667     switch (SvTYPE(sv)) {
1668     case SVt_NULL:
1669     case SVt_IV:
1670         sv_upgrade(sv, SVt_NV);
1671         break;
1672     case SVt_PV:
1673     case SVt_PVIV:
1674         sv_upgrade(sv, SVt_PVNV);
1675         break;
1676
1677     case SVt_PVGV:
1678         if (!isGV_with_GP(sv))
1679             break;
1680     case SVt_PVAV:
1681     case SVt_PVHV:
1682     case SVt_PVCV:
1683     case SVt_PVFM:
1684     case SVt_PVIO:
1685         /* diag_listed_as: Can't coerce %s to %s in %s */
1686         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1687                    OP_DESC(PL_op));
1688     default: NOOP;
1689     }
1690     SvNV_set(sv, num);
1691     (void)SvNOK_only(sv);                       /* validate number */
1692     SvTAINT(sv);
1693 }
1694
1695 /*
1696 =for apidoc sv_setnv_mg
1697
1698 Like C<sv_setnv>, but also handles 'set' magic.
1699
1700 =cut
1701 */
1702
1703 void
1704 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1705 {
1706     PERL_ARGS_ASSERT_SV_SETNV_MG;
1707
1708     sv_setnv(sv,num);
1709     SvSETMAGIC(sv);
1710 }
1711
1712 /* Print an "isn't numeric" warning, using a cleaned-up,
1713  * printable version of the offending string
1714  */
1715
1716 STATIC void
1717 S_not_a_number(pTHX_ SV *const sv)
1718 {
1719      dVAR;
1720      SV *dsv;
1721      char tmpbuf[64];
1722      const char *pv;
1723
1724      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1725
1726      if (DO_UTF8(sv)) {
1727           dsv = newSVpvs_flags("", SVs_TEMP);
1728           pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1729      } else {
1730           char *d = tmpbuf;
1731           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1732           /* each *s can expand to 4 chars + "...\0",
1733              i.e. need room for 8 chars */
1734
1735           const char *s = SvPVX_const(sv);
1736           const char * const end = s + SvCUR(sv);
1737           for ( ; s < end && d < limit; s++ ) {
1738                int ch = *s & 0xFF;
1739                if (ch & 128 && !isPRINT_LC(ch)) {
1740                     *d++ = 'M';
1741                     *d++ = '-';
1742                     ch &= 127;
1743                }
1744                if (ch == '\n') {
1745                     *d++ = '\\';
1746                     *d++ = 'n';
1747                }
1748                else if (ch == '\r') {
1749                     *d++ = '\\';
1750                     *d++ = 'r';
1751                }
1752                else if (ch == '\f') {
1753                     *d++ = '\\';
1754                     *d++ = 'f';
1755                }
1756                else if (ch == '\\') {
1757                     *d++ = '\\';
1758                     *d++ = '\\';
1759                }
1760                else if (ch == '\0') {
1761                     *d++ = '\\';
1762                     *d++ = '0';
1763                }
1764                else if (isPRINT_LC(ch))
1765                     *d++ = ch;
1766                else {
1767                     *d++ = '^';
1768                     *d++ = toCTRL(ch);
1769                }
1770           }
1771           if (s < end) {
1772                *d++ = '.';
1773                *d++ = '.';
1774                *d++ = '.';
1775           }
1776           *d = '\0';
1777           pv = tmpbuf;
1778     }
1779
1780     if (PL_op)
1781         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1782                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1783                     "Argument \"%s\" isn't numeric in %s", pv,
1784                     OP_DESC(PL_op));
1785     else
1786         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1787                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1788                     "Argument \"%s\" isn't numeric", pv);
1789 }
1790
1791 /*
1792 =for apidoc looks_like_number
1793
1794 Test if the content of an SV looks like a number (or is a number).
1795 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1796 non-numeric warning), even if your atof() doesn't grok them.  Get-magic is
1797 ignored.
1798
1799 =cut
1800 */
1801
1802 I32
1803 Perl_looks_like_number(pTHX_ SV *const sv)
1804 {
1805     register const char *sbegin;
1806     STRLEN len;
1807
1808     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1809
1810     if (SvPOK(sv) || SvPOKp(sv)) {
1811         sbegin = SvPV_nomg_const(sv, len);
1812     }
1813     else
1814         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1815     return grok_number(sbegin, len, NULL);
1816 }
1817
1818 STATIC bool
1819 S_glob_2number(pTHX_ GV * const gv)
1820 {
1821     SV *const buffer = sv_newmortal();
1822
1823     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1824
1825     gv_efullname3(buffer, gv, "*");
1826
1827     /* We know that all GVs stringify to something that is not-a-number,
1828         so no need to test that.  */
1829     if (ckWARN(WARN_NUMERIC))
1830         not_a_number(buffer);
1831     /* We just want something true to return, so that S_sv_2iuv_common
1832         can tail call us and return true.  */
1833     return TRUE;
1834 }
1835
1836 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1837    until proven guilty, assume that things are not that bad... */
1838
1839 /*
1840    NV_PRESERVES_UV:
1841
1842    As 64 bit platforms often have an NV that doesn't preserve all bits of
1843    an IV (an assumption perl has been based on to date) it becomes necessary
1844    to remove the assumption that the NV always carries enough precision to
1845    recreate the IV whenever needed, and that the NV is the canonical form.
1846    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1847    precision as a side effect of conversion (which would lead to insanity
1848    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1849    1) to distinguish between IV/UV/NV slots that have cached a valid
1850       conversion where precision was lost and IV/UV/NV slots that have a
1851       valid conversion which has lost no precision
1852    2) to ensure that if a numeric conversion to one form is requested that
1853       would lose precision, the precise conversion (or differently
1854       imprecise conversion) is also performed and cached, to prevent
1855       requests for different numeric formats on the same SV causing
1856       lossy conversion chains. (lossless conversion chains are perfectly
1857       acceptable (still))
1858
1859
1860    flags are used:
1861    SvIOKp is true if the IV slot contains a valid value
1862    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1863    SvNOKp is true if the NV slot contains a valid value
1864    SvNOK  is true only if the NV value is accurate
1865
1866    so
1867    while converting from PV to NV, check to see if converting that NV to an
1868    IV(or UV) would lose accuracy over a direct conversion from PV to
1869    IV(or UV). If it would, cache both conversions, return NV, but mark
1870    SV as IOK NOKp (ie not NOK).
1871
1872    While converting from PV to IV, check to see if converting that IV to an
1873    NV would lose accuracy over a direct conversion from PV to NV. If it
1874    would, cache both conversions, flag similarly.
1875
1876    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1877    correctly because if IV & NV were set NV *always* overruled.
1878    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1879    changes - now IV and NV together means that the two are interchangeable:
1880    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1881
1882    The benefit of this is that operations such as pp_add know that if
1883    SvIOK is true for both left and right operands, then integer addition
1884    can be used instead of floating point (for cases where the result won't
1885    overflow). Before, floating point was always used, which could lead to
1886    loss of precision compared with integer addition.
1887
1888    * making IV and NV equal status should make maths accurate on 64 bit
1889      platforms
1890    * may speed up maths somewhat if pp_add and friends start to use
1891      integers when possible instead of fp. (Hopefully the overhead in
1892      looking for SvIOK and checking for overflow will not outweigh the
1893      fp to integer speedup)
1894    * will slow down integer operations (callers of SvIV) on "inaccurate"
1895      values, as the change from SvIOK to SvIOKp will cause a call into
1896      sv_2iv each time rather than a macro access direct to the IV slot
1897    * should speed up number->string conversion on integers as IV is
1898      favoured when IV and NV are equally accurate
1899
1900    ####################################################################
1901    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1902    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1903    On the other hand, SvUOK is true iff UV.
1904    ####################################################################
1905
1906    Your mileage will vary depending your CPU's relative fp to integer
1907    performance ratio.
1908 */
1909
1910 #ifndef NV_PRESERVES_UV
1911 #  define IS_NUMBER_UNDERFLOW_IV 1
1912 #  define IS_NUMBER_UNDERFLOW_UV 2
1913 #  define IS_NUMBER_IV_AND_UV    2
1914 #  define IS_NUMBER_OVERFLOW_IV  4
1915 #  define IS_NUMBER_OVERFLOW_UV  5
1916
1917 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1918
1919 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1920 STATIC int
1921 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1922 #  ifdef DEBUGGING
1923                        , I32 numtype
1924 #  endif
1925                        )
1926 {
1927     dVAR;
1928
1929     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1930
1931     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));
1932     if (SvNVX(sv) < (NV)IV_MIN) {
1933         (void)SvIOKp_on(sv);
1934         (void)SvNOK_on(sv);
1935         SvIV_set(sv, IV_MIN);
1936         return IS_NUMBER_UNDERFLOW_IV;
1937     }
1938     if (SvNVX(sv) > (NV)UV_MAX) {
1939         (void)SvIOKp_on(sv);
1940         (void)SvNOK_on(sv);
1941         SvIsUV_on(sv);
1942         SvUV_set(sv, UV_MAX);
1943         return IS_NUMBER_OVERFLOW_UV;
1944     }
1945     (void)SvIOKp_on(sv);
1946     (void)SvNOK_on(sv);
1947     /* Can't use strtol etc to convert this string.  (See truth table in
1948        sv_2iv  */
1949     if (SvNVX(sv) <= (UV)IV_MAX) {
1950         SvIV_set(sv, I_V(SvNVX(sv)));
1951         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1952             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1953         } else {
1954             /* Integer is imprecise. NOK, IOKp */
1955         }
1956         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1957     }
1958     SvIsUV_on(sv);
1959     SvUV_set(sv, U_V(SvNVX(sv)));
1960     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1961         if (SvUVX(sv) == UV_MAX) {
1962             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1963                possibly be preserved by NV. Hence, it must be overflow.
1964                NOK, IOKp */
1965             return IS_NUMBER_OVERFLOW_UV;
1966         }
1967         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1968     } else {
1969         /* Integer is imprecise. NOK, IOKp */
1970     }
1971     return IS_NUMBER_OVERFLOW_IV;
1972 }
1973 #endif /* !NV_PRESERVES_UV*/
1974
1975 STATIC bool
1976 S_sv_2iuv_common(pTHX_ SV *const sv)
1977 {
1978     dVAR;
1979
1980     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1981
1982     if (SvNOKp(sv)) {
1983         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1984          * without also getting a cached IV/UV from it at the same time
1985          * (ie PV->NV conversion should detect loss of accuracy and cache
1986          * IV or UV at same time to avoid this. */
1987         /* IV-over-UV optimisation - choose to cache IV if possible */
1988
1989         if (SvTYPE(sv) == SVt_NV)
1990             sv_upgrade(sv, SVt_PVNV);
1991
1992         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1993         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1994            certainly cast into the IV range at IV_MAX, whereas the correct
1995            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1996            cases go to UV */
1997 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1998         if (Perl_isnan(SvNVX(sv))) {
1999             SvUV_set(sv, 0);
2000             SvIsUV_on(sv);
2001             return FALSE;
2002         }
2003 #endif
2004         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2005             SvIV_set(sv, I_V(SvNVX(sv)));
2006             if (SvNVX(sv) == (NV) SvIVX(sv)
2007 #ifndef NV_PRESERVES_UV
2008                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2009                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2010                 /* Don't flag it as "accurately an integer" if the number
2011                    came from a (by definition imprecise) NV operation, and
2012                    we're outside the range of NV integer precision */
2013 #endif
2014                 ) {
2015                 if (SvNOK(sv))
2016                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2017                 else {
2018                     /* scalar has trailing garbage, eg "42a" */
2019                 }
2020                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2021                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2022                                       PTR2UV(sv),
2023                                       SvNVX(sv),
2024                                       SvIVX(sv)));
2025
2026             } else {
2027                 /* IV not precise.  No need to convert from PV, as NV
2028                    conversion would already have cached IV if it detected
2029                    that PV->IV would be better than PV->NV->IV
2030                    flags already correct - don't set public IOK.  */
2031                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2032                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2033                                       PTR2UV(sv),
2034                                       SvNVX(sv),
2035                                       SvIVX(sv)));
2036             }
2037             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2038                but the cast (NV)IV_MIN rounds to a the value less (more
2039                negative) than IV_MIN which happens to be equal to SvNVX ??
2040                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2041                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2042                (NV)UVX == NVX are both true, but the values differ. :-(
2043                Hopefully for 2s complement IV_MIN is something like
2044                0x8000000000000000 which will be exact. NWC */
2045         }
2046         else {
2047             SvUV_set(sv, U_V(SvNVX(sv)));
2048             if (
2049                 (SvNVX(sv) == (NV) SvUVX(sv))
2050 #ifndef  NV_PRESERVES_UV
2051                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2052                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2053                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2054                 /* Don't flag it as "accurately an integer" if the number
2055                    came from a (by definition imprecise) NV operation, and
2056                    we're outside the range of NV integer precision */
2057 #endif
2058                 && SvNOK(sv)
2059                 )
2060                 SvIOK_on(sv);
2061             SvIsUV_on(sv);
2062             DEBUG_c(PerlIO_printf(Perl_debug_log,
2063                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2064                                   PTR2UV(sv),
2065                                   SvUVX(sv),
2066                                   SvUVX(sv)));
2067         }
2068     }
2069     else if (SvPOKp(sv) && SvLEN(sv)) {
2070         UV value;
2071         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2072         /* We want to avoid a possible problem when we cache an IV/ a UV which
2073            may be later translated to an NV, and the resulting NV is not
2074            the same as the direct translation of the initial string
2075            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2076            be careful to ensure that the value with the .456 is around if the
2077            NV value is requested in the future).
2078
2079            This means that if we cache such an IV/a UV, we need to cache the
2080            NV as well.  Moreover, we trade speed for space, and do not
2081            cache the NV if we are sure it's not needed.
2082          */
2083
2084         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2085         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2086              == IS_NUMBER_IN_UV) {
2087             /* It's definitely an integer, only upgrade to PVIV */
2088             if (SvTYPE(sv) < SVt_PVIV)
2089                 sv_upgrade(sv, SVt_PVIV);
2090             (void)SvIOK_on(sv);
2091         } else if (SvTYPE(sv) < SVt_PVNV)
2092             sv_upgrade(sv, SVt_PVNV);
2093
2094         /* If NVs preserve UVs then we only use the UV value if we know that
2095            we aren't going to call atof() below. If NVs don't preserve UVs
2096            then the value returned may have more precision than atof() will
2097            return, even though value isn't perfectly accurate.  */
2098         if ((numtype & (IS_NUMBER_IN_UV
2099 #ifdef NV_PRESERVES_UV
2100                         | IS_NUMBER_NOT_INT
2101 #endif
2102             )) == IS_NUMBER_IN_UV) {
2103             /* This won't turn off the public IOK flag if it was set above  */
2104             (void)SvIOKp_on(sv);
2105
2106             if (!(numtype & IS_NUMBER_NEG)) {
2107                 /* positive */;
2108                 if (value <= (UV)IV_MAX) {
2109                     SvIV_set(sv, (IV)value);
2110                 } else {
2111                     /* it didn't overflow, and it was positive. */
2112                     SvUV_set(sv, value);
2113                     SvIsUV_on(sv);
2114                 }
2115             } else {
2116                 /* 2s complement assumption  */
2117                 if (value <= (UV)IV_MIN) {
2118                     SvIV_set(sv, -(IV)value);
2119                 } else {
2120                     /* Too negative for an IV.  This is a double upgrade, but
2121                        I'm assuming it will be rare.  */
2122                     if (SvTYPE(sv) < SVt_PVNV)
2123                         sv_upgrade(sv, SVt_PVNV);
2124                     SvNOK_on(sv);
2125                     SvIOK_off(sv);
2126                     SvIOKp_on(sv);
2127                     SvNV_set(sv, -(NV)value);
2128                     SvIV_set(sv, IV_MIN);
2129                 }
2130             }
2131         }
2132         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2133            will be in the previous block to set the IV slot, and the next
2134            block to set the NV slot.  So no else here.  */
2135
2136         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2137             != IS_NUMBER_IN_UV) {
2138             /* It wasn't an (integer that doesn't overflow the UV). */
2139             SvNV_set(sv, Atof(SvPVX_const(sv)));
2140
2141             if (! numtype && ckWARN(WARN_NUMERIC))
2142                 not_a_number(sv);
2143
2144 #if defined(USE_LONG_DOUBLE)
2145             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2146                                   PTR2UV(sv), SvNVX(sv)));
2147 #else
2148             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2149                                   PTR2UV(sv), SvNVX(sv)));
2150 #endif
2151
2152 #ifdef NV_PRESERVES_UV
2153             (void)SvIOKp_on(sv);
2154             (void)SvNOK_on(sv);
2155             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2156                 SvIV_set(sv, I_V(SvNVX(sv)));
2157                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2158                     SvIOK_on(sv);
2159                 } else {
2160                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2161                 }
2162                 /* UV will not work better than IV */
2163             } else {
2164                 if (SvNVX(sv) > (NV)UV_MAX) {
2165                     SvIsUV_on(sv);
2166                     /* Integer is inaccurate. NOK, IOKp, is UV */
2167                     SvUV_set(sv, UV_MAX);
2168                 } else {
2169                     SvUV_set(sv, U_V(SvNVX(sv)));
2170                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2171                        NV preservse UV so can do correct comparison.  */
2172                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2173                         SvIOK_on(sv);
2174                     } else {
2175                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2176                     }
2177                 }
2178                 SvIsUV_on(sv);
2179             }
2180 #else /* NV_PRESERVES_UV */
2181             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2182                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2183                 /* The IV/UV slot will have been set from value returned by
2184                    grok_number above.  The NV slot has just been set using
2185                    Atof.  */
2186                 SvNOK_on(sv);
2187                 assert (SvIOKp(sv));
2188             } else {
2189                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2190                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2191                     /* Small enough to preserve all bits. */
2192                     (void)SvIOKp_on(sv);
2193                     SvNOK_on(sv);
2194                     SvIV_set(sv, I_V(SvNVX(sv)));
2195                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2196                         SvIOK_on(sv);
2197                     /* Assumption: first non-preserved integer is < IV_MAX,
2198                        this NV is in the preserved range, therefore: */
2199                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2200                           < (UV)IV_MAX)) {
2201                         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);
2202                     }
2203                 } else {
2204                     /* IN_UV NOT_INT
2205                          0      0       already failed to read UV.
2206                          0      1       already failed to read UV.
2207                          1      0       you won't get here in this case. IV/UV
2208                                         slot set, public IOK, Atof() unneeded.
2209                          1      1       already read UV.
2210                        so there's no point in sv_2iuv_non_preserve() attempting
2211                        to use atol, strtol, strtoul etc.  */
2212 #  ifdef DEBUGGING
2213                     sv_2iuv_non_preserve (sv, numtype);
2214 #  else
2215                     sv_2iuv_non_preserve (sv);
2216 #  endif
2217                 }
2218             }
2219 #endif /* NV_PRESERVES_UV */
2220         /* It might be more code efficient to go through the entire logic above
2221            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2222            gets complex and potentially buggy, so more programmer efficient
2223            to do it this way, by turning off the public flags:  */
2224         if (!numtype)
2225             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2226         }
2227     }
2228     else  {
2229         if (isGV_with_GP(sv))
2230             return glob_2number(MUTABLE_GV(sv));
2231
2232         if (!SvPADTMP(sv)) {
2233             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2234                 report_uninit(sv);
2235         }
2236         if (SvTYPE(sv) < SVt_IV)
2237             /* Typically the caller expects that sv_any is not NULL now.  */
2238             sv_upgrade(sv, SVt_IV);
2239         /* Return 0 from the caller.  */
2240         return TRUE;
2241     }
2242     return FALSE;
2243 }
2244
2245 /*
2246 =for apidoc sv_2iv_flags
2247
2248 Return the integer value of an SV, doing any necessary string
2249 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2250 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2251
2252 =cut
2253 */
2254
2255 IV
2256 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2257 {
2258     dVAR;
2259     if (!sv)
2260         return 0;
2261     if (SvGMAGICAL(sv) || SvVALID(sv)) {
2262         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2263            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2264            In practice they are extremely unlikely to actually get anywhere
2265            accessible by user Perl code - the only way that I'm aware of is when
2266            a constant subroutine which is used as the second argument to index.
2267         */
2268         if (flags & SV_GMAGIC)
2269             mg_get(sv);
2270         if (SvIOKp(sv))
2271             return SvIVX(sv);
2272         if (SvNOKp(sv)) {
2273             return I_V(SvNVX(sv));
2274         }
2275         if (SvPOKp(sv) && SvLEN(sv)) {
2276             UV value;
2277             const int numtype
2278                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2279
2280             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2281                 == IS_NUMBER_IN_UV) {
2282                 /* It's definitely an integer */
2283                 if (numtype & IS_NUMBER_NEG) {
2284                     if (value < (UV)IV_MIN)
2285                         return -(IV)value;
2286                 } else {
2287                     if (value < (UV)IV_MAX)
2288                         return (IV)value;
2289                 }
2290             }
2291             if (!numtype) {
2292                 if (ckWARN(WARN_NUMERIC))
2293                     not_a_number(sv);
2294             }
2295             return I_V(Atof(SvPVX_const(sv)));
2296         }
2297         if (SvROK(sv)) {
2298             goto return_rok;
2299         }
2300         assert(SvTYPE(sv) >= SVt_PVMG);
2301         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2302     } else if (SvTHINKFIRST(sv)) {
2303         if (SvROK(sv)) {
2304         return_rok:
2305             if (SvAMAGIC(sv)) {
2306                 SV * tmpstr;
2307                 if (flags & SV_SKIP_OVERLOAD)
2308                     return 0;
2309                 tmpstr = AMG_CALLunary(sv, numer_amg);
2310                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2311                     return SvIV(tmpstr);
2312                 }
2313             }
2314             return PTR2IV(SvRV(sv));
2315         }
2316         if (SvIsCOW(sv)) {
2317             sv_force_normal_flags(sv, 0);
2318         }
2319         if (SvREADONLY(sv) && !SvOK(sv)) {
2320             if (ckWARN(WARN_UNINITIALIZED))
2321                 report_uninit(sv);
2322             return 0;
2323         }
2324     }
2325     if (!SvIOKp(sv)) {
2326         if (S_sv_2iuv_common(aTHX_ sv))
2327             return 0;
2328     }
2329     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2330         PTR2UV(sv),SvIVX(sv)));
2331     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2332 }
2333
2334 /*
2335 =for apidoc sv_2uv_flags
2336
2337 Return the unsigned integer value of an SV, doing any necessary string
2338 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2339 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2340
2341 =cut
2342 */
2343
2344 UV
2345 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2346 {
2347     dVAR;
2348     if (!sv)
2349         return 0;
2350     if (SvGMAGICAL(sv) || SvVALID(sv)) {
2351         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2352            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  */
2353         if (flags & SV_GMAGIC)
2354             mg_get(sv);
2355         if (SvIOKp(sv))
2356             return SvUVX(sv);
2357         if (SvNOKp(sv))
2358             return U_V(SvNVX(sv));
2359         if (SvPOKp(sv) && SvLEN(sv)) {
2360             UV value;
2361             const int numtype
2362                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2363
2364             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2365                 == IS_NUMBER_IN_UV) {
2366                 /* It's definitely an integer */
2367                 if (!(numtype & IS_NUMBER_NEG))
2368                     return value;
2369             }
2370             if (!numtype) {
2371                 if (ckWARN(WARN_NUMERIC))
2372                     not_a_number(sv);
2373             }
2374             return U_V(Atof(SvPVX_const(sv)));
2375         }
2376         if (SvROK(sv)) {
2377             goto return_rok;
2378         }
2379         assert(SvTYPE(sv) >= SVt_PVMG);
2380         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2381     } else if (SvTHINKFIRST(sv)) {
2382         if (SvROK(sv)) {
2383         return_rok:
2384             if (SvAMAGIC(sv)) {
2385                 SV *tmpstr;
2386                 if (flags & SV_SKIP_OVERLOAD)
2387                     return 0;
2388                 tmpstr = AMG_CALLunary(sv, numer_amg);
2389                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2390                     return SvUV(tmpstr);
2391                 }
2392             }
2393             return PTR2UV(SvRV(sv));
2394         }
2395         if (SvIsCOW(sv)) {
2396             sv_force_normal_flags(sv, 0);
2397         }
2398         if (SvREADONLY(sv) && !SvOK(sv)) {
2399             if (ckWARN(WARN_UNINITIALIZED))
2400                 report_uninit(sv);
2401             return 0;
2402         }
2403     }
2404     if (!SvIOKp(sv)) {
2405         if (S_sv_2iuv_common(aTHX_ sv))
2406             return 0;
2407     }
2408
2409     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2410                           PTR2UV(sv),SvUVX(sv)));
2411     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2412 }
2413
2414 /*
2415 =for apidoc sv_2nv_flags
2416
2417 Return the num value of an SV, doing any necessary string or integer
2418 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2419 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2420
2421 =cut
2422 */
2423
2424 NV
2425 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2426 {
2427     dVAR;
2428     if (!sv)
2429         return 0.0;
2430     if (SvGMAGICAL(sv) || SvVALID(sv)) {
2431         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2432            the same flag bit as SVf_IVisUV, so must not let them cache NVs.  */
2433         if (flags & SV_GMAGIC)
2434             mg_get(sv);
2435         if (SvNOKp(sv))
2436             return SvNVX(sv);
2437         if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2438             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2439                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2440                 not_a_number(sv);
2441             return Atof(SvPVX_const(sv));
2442         }
2443         if (SvIOKp(sv)) {
2444             if (SvIsUV(sv))
2445                 return (NV)SvUVX(sv);
2446             else
2447                 return (NV)SvIVX(sv);
2448         }
2449         if (SvROK(sv)) {
2450             goto return_rok;
2451         }
2452         assert(SvTYPE(sv) >= SVt_PVMG);
2453         /* This falls through to the report_uninit near the end of the
2454            function. */
2455     } else if (SvTHINKFIRST(sv)) {
2456         if (SvROK(sv)) {
2457         return_rok:
2458             if (SvAMAGIC(sv)) {
2459                 SV *tmpstr;
2460                 if (flags & SV_SKIP_OVERLOAD)
2461                     return 0;
2462                 tmpstr = AMG_CALLunary(sv, numer_amg);
2463                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2464                     return SvNV(tmpstr);
2465                 }
2466             }
2467             return PTR2NV(SvRV(sv));
2468         }
2469         if (SvIsCOW(sv)) {
2470             sv_force_normal_flags(sv, 0);
2471         }
2472         if (SvREADONLY(sv) && !SvOK(sv)) {
2473             if (ckWARN(WARN_UNINITIALIZED))
2474                 report_uninit(sv);
2475             return 0.0;
2476         }
2477     }
2478     if (SvTYPE(sv) < SVt_NV) {
2479         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2480         sv_upgrade(sv, SVt_NV);
2481 #ifdef USE_LONG_DOUBLE
2482         DEBUG_c({
2483             STORE_NUMERIC_LOCAL_SET_STANDARD();
2484             PerlIO_printf(Perl_debug_log,
2485                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2486                           PTR2UV(sv), SvNVX(sv));
2487             RESTORE_NUMERIC_LOCAL();
2488         });
2489 #else
2490         DEBUG_c({
2491             STORE_NUMERIC_LOCAL_SET_STANDARD();
2492             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2493                           PTR2UV(sv), SvNVX(sv));
2494             RESTORE_NUMERIC_LOCAL();
2495         });
2496 #endif
2497     }
2498     else if (SvTYPE(sv) < SVt_PVNV)
2499         sv_upgrade(sv, SVt_PVNV);
2500     if (SvNOKp(sv)) {
2501         return SvNVX(sv);
2502     }
2503     if (SvIOKp(sv)) {
2504         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2505 #ifdef NV_PRESERVES_UV
2506         if (SvIOK(sv))
2507             SvNOK_on(sv);
2508         else
2509             SvNOKp_on(sv);
2510 #else
2511         /* Only set the public NV OK flag if this NV preserves the IV  */
2512         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2513         if (SvIOK(sv) &&
2514             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2515                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2516             SvNOK_on(sv);
2517         else
2518             SvNOKp_on(sv);
2519 #endif
2520     }
2521     else if (SvPOKp(sv) && SvLEN(sv)) {
2522         UV value;
2523         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2524         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2525             not_a_number(sv);
2526 #ifdef NV_PRESERVES_UV
2527         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2528             == IS_NUMBER_IN_UV) {
2529             /* It's definitely an integer */
2530             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2531         } else
2532             SvNV_set(sv, Atof(SvPVX_const(sv)));
2533         if (numtype)
2534             SvNOK_on(sv);
2535         else
2536             SvNOKp_on(sv);
2537 #else
2538         SvNV_set(sv, Atof(SvPVX_const(sv)));
2539         /* Only set the public NV OK flag if this NV preserves the value in
2540            the PV at least as well as an IV/UV would.
2541            Not sure how to do this 100% reliably. */
2542         /* if that shift count is out of range then Configure's test is
2543            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2544            UV_BITS */
2545         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2546             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2547             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2548         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2549             /* Can't use strtol etc to convert this string, so don't try.
2550                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2551             SvNOK_on(sv);
2552         } else {
2553             /* value has been set.  It may not be precise.  */
2554             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2555                 /* 2s complement assumption for (UV)IV_MIN  */
2556                 SvNOK_on(sv); /* Integer is too negative.  */
2557             } else {
2558                 SvNOKp_on(sv);
2559                 SvIOKp_on(sv);
2560
2561                 if (numtype & IS_NUMBER_NEG) {
2562                     SvIV_set(sv, -(IV)value);
2563                 } else if (value <= (UV)IV_MAX) {
2564                     SvIV_set(sv, (IV)value);
2565                 } else {
2566                     SvUV_set(sv, value);
2567                     SvIsUV_on(sv);
2568                 }
2569
2570                 if (numtype & IS_NUMBER_NOT_INT) {
2571                     /* I believe that even if the original PV had decimals,
2572                        they are lost beyond the limit of the FP precision.
2573                        However, neither is canonical, so both only get p
2574                        flags.  NWC, 2000/11/25 */
2575                     /* Both already have p flags, so do nothing */
2576                 } else {
2577                     const NV nv = SvNVX(sv);
2578                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2579                         if (SvIVX(sv) == I_V(nv)) {
2580                             SvNOK_on(sv);
2581                         } else {
2582                             /* It had no "." so it must be integer.  */
2583                         }
2584                         SvIOK_on(sv);
2585                     } else {
2586                         /* between IV_MAX and NV(UV_MAX).
2587                            Could be slightly > UV_MAX */
2588
2589                         if (numtype & IS_NUMBER_NOT_INT) {
2590                             /* UV and NV both imprecise.  */
2591                         } else {
2592                             const UV nv_as_uv = U_V(nv);
2593
2594                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2595                                 SvNOK_on(sv);
2596                             }
2597                             SvIOK_on(sv);
2598                         }
2599                     }
2600                 }
2601             }
2602         }
2603         /* It might be more code efficient to go through the entire logic above
2604            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2605            gets complex and potentially buggy, so more programmer efficient
2606            to do it this way, by turning off the public flags:  */
2607         if (!numtype)
2608             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2609 #endif /* NV_PRESERVES_UV */
2610     }
2611     else  {
2612         if (isGV_with_GP(sv)) {
2613             glob_2number(MUTABLE_GV(sv));
2614             return 0.0;
2615         }
2616
2617         if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
2618             report_uninit(sv);
2619         assert (SvTYPE(sv) >= SVt_NV);
2620         /* Typically the caller expects that sv_any is not NULL now.  */
2621         /* XXX Ilya implies that this is a bug in callers that assume this
2622            and ideally should be fixed.  */
2623         return 0.0;
2624     }
2625 #if defined(USE_LONG_DOUBLE)
2626     DEBUG_c({
2627         STORE_NUMERIC_LOCAL_SET_STANDARD();
2628         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2629                       PTR2UV(sv), SvNVX(sv));
2630         RESTORE_NUMERIC_LOCAL();
2631     });
2632 #else
2633     DEBUG_c({
2634         STORE_NUMERIC_LOCAL_SET_STANDARD();
2635         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2636                       PTR2UV(sv), SvNVX(sv));
2637         RESTORE_NUMERIC_LOCAL();
2638     });
2639 #endif
2640     return SvNVX(sv);
2641 }
2642
2643 /*
2644 =for apidoc sv_2num
2645
2646 Return an SV with the numeric value of the source SV, doing any necessary
2647 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2648 access this function.
2649
2650 =cut
2651 */
2652
2653 SV *
2654 Perl_sv_2num(pTHX_ register SV *const sv)
2655 {
2656     PERL_ARGS_ASSERT_SV_2NUM;
2657
2658     if (!SvROK(sv))
2659         return sv;
2660     if (SvAMAGIC(sv)) {
2661         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2662         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2663         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2664             return sv_2num(tmpsv);
2665     }
2666     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2667 }
2668
2669 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2670  * UV as a string towards the end of buf, and return pointers to start and
2671  * end of it.
2672  *
2673  * We assume that buf is at least TYPE_CHARS(UV) long.
2674  */
2675
2676 static char *
2677 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2678 {
2679     char *ptr = buf + TYPE_CHARS(UV);
2680     char * const ebuf = ptr;
2681     int sign;
2682
2683     PERL_ARGS_ASSERT_UIV_2BUF;
2684
2685     if (is_uv)
2686         sign = 0;
2687     else if (iv >= 0) {
2688         uv = iv;
2689         sign = 0;
2690     } else {
2691         uv = -iv;
2692         sign = 1;
2693     }
2694     do {
2695         *--ptr = '0' + (char)(uv % 10);
2696     } while (uv /= 10);
2697     if (sign)
2698         *--ptr = '-';
2699     *peob = ebuf;
2700     return ptr;
2701 }
2702
2703 /*
2704 =for apidoc sv_2pv_flags
2705
2706 Returns a pointer to the string value of an SV, and sets *lp to its length.
2707 If flags includes SV_GMAGIC, does an mg_get() first.  Coerces sv to a
2708 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2709 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2710
2711 =cut
2712 */
2713
2714 char *
2715 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2716 {
2717     dVAR;
2718     register char *s;
2719
2720     if (!sv) {
2721         if (lp)
2722             *lp = 0;
2723         return (char *)"";
2724     }
2725     if (SvGMAGICAL(sv)) {
2726         if (flags & SV_GMAGIC)
2727             mg_get(sv);
2728         if (SvPOKp(sv)) {
2729             if (lp)
2730                 *lp = SvCUR(sv);
2731             if (flags & SV_MUTABLE_RETURN)
2732                 return SvPVX_mutable(sv);
2733             if (flags & SV_CONST_RETURN)
2734                 return (char *)SvPVX_const(sv);
2735             return SvPVX(sv);
2736         }
2737         if (SvIOKp(sv) || SvNOKp(sv)) {
2738             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2739             STRLEN len;
2740
2741             if (SvIOKp(sv)) {
2742                 len = SvIsUV(sv)
2743                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2744                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2745             } else if(SvNVX(sv) == 0.0) {
2746                     tbuf[0] = '0';
2747                     tbuf[1] = 0;
2748                     len = 1;
2749             } else {
2750                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2751                 len = strlen(tbuf);
2752             }
2753             assert(!SvROK(sv));
2754             {
2755                 dVAR;
2756
2757                 SvUPGRADE(sv, SVt_PV);
2758                 if (lp)
2759                     *lp = len;
2760                 s = SvGROW_mutable(sv, len + 1);
2761                 SvCUR_set(sv, len);
2762                 SvPOKp_on(sv);
2763                 return (char*)memcpy(s, tbuf, len + 1);
2764             }
2765         }
2766         if (SvROK(sv)) {
2767             goto return_rok;
2768         }
2769         assert(SvTYPE(sv) >= SVt_PVMG);
2770         /* This falls through to the report_uninit near the end of the
2771            function. */
2772     } else if (SvTHINKFIRST(sv)) {
2773         if (SvROK(sv)) {
2774         return_rok:
2775             if (SvAMAGIC(sv)) {
2776                 SV *tmpstr;
2777                 if (flags & SV_SKIP_OVERLOAD)
2778                     return NULL;
2779                 tmpstr = AMG_CALLunary(sv, string_amg);
2780                 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2781                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2782                     /* Unwrap this:  */
2783                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2784                      */
2785
2786                     char *pv;
2787                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2788                         if (flags & SV_CONST_RETURN) {
2789                             pv = (char *) SvPVX_const(tmpstr);
2790                         } else {
2791                             pv = (flags & SV_MUTABLE_RETURN)
2792                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2793                         }
2794                         if (lp)
2795                             *lp = SvCUR(tmpstr);
2796                     } else {
2797                         pv = sv_2pv_flags(tmpstr, lp, flags);
2798                     }
2799                     if (SvUTF8(tmpstr))
2800                         SvUTF8_on(sv);
2801                     else
2802                         SvUTF8_off(sv);
2803                     return pv;
2804                 }
2805             }
2806             {
2807                 STRLEN len;
2808                 char *retval;
2809                 char *buffer;
2810                 SV *const referent = SvRV(sv);
2811
2812                 if (!referent) {
2813                     len = 7;
2814                     retval = buffer = savepvn("NULLREF", len);
2815                 } else if (SvTYPE(referent) == SVt_REGEXP && (
2816                               !(PL_curcop->cop_hints & HINT_NO_AMAGIC)
2817                            || amagic_is_enabled(string_amg)
2818                           )) {
2819                     REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2820                     I32 seen_evals = 0;
2821
2822                     assert(re);
2823
2824                     /* If the regex is UTF-8 we want the containing scalar to
2825                        have an UTF-8 flag too */
2826                     if (RX_UTF8(re))
2827                         SvUTF8_on(sv);
2828                     else
2829                         SvUTF8_off(sv);
2830
2831                     if ((seen_evals = RX_SEEN_EVALS(re)))
2832                         PL_reginterp_cnt += seen_evals;
2833
2834                     if (lp)
2835                         *lp = RX_WRAPLEN(re);
2836
2837                     return RX_WRAPPED(re);
2838                 } else {
2839                     const char *const typestr = sv_reftype(referent, 0);
2840                     const STRLEN typelen = strlen(typestr);
2841                     UV addr = PTR2UV(referent);
2842                     const char *stashname = NULL;
2843                     STRLEN stashnamelen = 0; /* hush, gcc */
2844                     const char *buffer_end;
2845
2846                     if (SvOBJECT(referent)) {
2847                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2848
2849                         if (name) {
2850                             stashname = HEK_KEY(name);
2851                             stashnamelen = HEK_LEN(name);
2852
2853                             if (HEK_UTF8(name)) {
2854                                 SvUTF8_on(sv);
2855                             } else {
2856                                 SvUTF8_off(sv);
2857                             }
2858                         } else {
2859                             stashname = "__ANON__";
2860                             stashnamelen = 8;
2861                         }
2862                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2863                             + 2 * sizeof(UV) + 2 /* )\0 */;
2864                     } else {
2865                         len = typelen + 3 /* (0x */
2866                             + 2 * sizeof(UV) + 2 /* )\0 */;
2867                     }
2868
2869                     Newx(buffer, len, char);
2870                     buffer_end = retval = buffer + len;
2871
2872                     /* Working backwards  */
2873                     *--retval = '\0';
2874                     *--retval = ')';
2875                     do {
2876                         *--retval = PL_hexdigit[addr & 15];
2877                     } while (addr >>= 4);
2878                     *--retval = 'x';
2879                     *--retval = '0';
2880                     *--retval = '(';
2881
2882                     retval -= typelen;
2883                     memcpy(retval, typestr, typelen);
2884
2885                     if (stashname) {
2886                         *--retval = '=';
2887                         retval -= stashnamelen;
2888                         memcpy(retval, stashname, stashnamelen);
2889                     }
2890                     /* retval may not necessarily have reached the start of the
2891                        buffer here.  */
2892                     assert (retval >= buffer);
2893
2894                     len = buffer_end - retval - 1; /* -1 for that \0  */
2895                 }
2896                 if (lp)
2897                     *lp = len;
2898                 SAVEFREEPV(buffer);
2899                 return retval;
2900             }
2901         }
2902         if (SvREADONLY(sv) && !SvOK(sv)) {
2903             if (lp)
2904                 *lp = 0;
2905             if (flags & SV_UNDEF_RETURNS_NULL)
2906                 return NULL;
2907             if (ckWARN(WARN_UNINITIALIZED))
2908                 report_uninit(sv);
2909             return (char *)"";
2910         }
2911     }
2912     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2913         /* I'm assuming that if both IV and NV are equally valid then
2914            converting the IV is going to be more efficient */
2915         const U32 isUIOK = SvIsUV(sv);
2916         char buf[TYPE_CHARS(UV)];
2917         char *ebuf, *ptr;
2918         STRLEN len;
2919
2920         if (SvTYPE(sv) < SVt_PVIV)
2921             sv_upgrade(sv, SVt_PVIV);
2922         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2923         len = ebuf - ptr;
2924         /* inlined from sv_setpvn */
2925         s = SvGROW_mutable(sv, len + 1);
2926         Move(ptr, s, len, char);
2927         s += len;
2928         *s = '\0';
2929     }
2930     else if (SvNOKp(sv)) {
2931         if (SvTYPE(sv) < SVt_PVNV)
2932             sv_upgrade(sv, SVt_PVNV);
2933         if (SvNVX(sv) == 0.0) {
2934             s = SvGROW_mutable(sv, 2);
2935             *s++ = '0';
2936             *s = '\0';
2937         } else {
2938             dSAVE_ERRNO;
2939             /* The +20 is pure guesswork.  Configure test needed. --jhi */
2940             s = SvGROW_mutable(sv, NV_DIG + 20);
2941             /* some Xenix systems wipe out errno here */
2942             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2943             RESTORE_ERRNO;
2944             while (*s) s++;
2945         }
2946 #ifdef hcx
2947         if (s[-1] == '.')
2948             *--s = '\0';
2949 #endif
2950     }
2951     else {
2952         if (isGV_with_GP(sv)) {
2953             GV *const gv = MUTABLE_GV(sv);
2954             SV *const buffer = sv_newmortal();
2955
2956             gv_efullname3(buffer, gv, "*");
2957
2958             assert(SvPOK(buffer));
2959             if (lp) {
2960                     *lp = SvCUR(buffer);
2961             }
2962             if ( SvUTF8(buffer) ) SvUTF8_on(sv);
2963             return SvPVX(buffer);
2964         }
2965
2966         if (lp)
2967             *lp = 0;
2968         if (flags & SV_UNDEF_RETURNS_NULL)
2969             return NULL;
2970         if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
2971             report_uninit(sv);
2972         if (SvTYPE(sv) < SVt_PV)
2973             /* Typically the caller expects that sv_any is not NULL now.  */
2974             sv_upgrade(sv, SVt_PV);
2975         return (char *)"";
2976     }
2977     {
2978         const STRLEN len = s - SvPVX_const(sv);
2979         if (lp)
2980             *lp = len;
2981         SvCUR_set(sv, len);
2982     }
2983     SvPOK_on(sv);
2984     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2985                           PTR2UV(sv),SvPVX_const(sv)));
2986     if (flags & SV_CONST_RETURN)
2987         return (char *)SvPVX_const(sv);
2988     if (flags & SV_MUTABLE_RETURN)
2989         return SvPVX_mutable(sv);
2990     return SvPVX(sv);
2991 }
2992
2993 /*
2994 =for apidoc sv_copypv
2995
2996 Copies a stringified representation of the source SV into the
2997 destination SV.  Automatically performs any necessary mg_get and
2998 coercion of numeric values into strings.  Guaranteed to preserve
2999 UTF8 flag even from overloaded objects.  Similar in nature to
3000 sv_2pv[_flags] but operates directly on an SV instead of just the
3001 string.  Mostly uses sv_2pv_flags to do its work, except when that
3002 would lose the UTF-8'ness of the PV.
3003
3004 =cut
3005 */
3006
3007 void
3008 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3009 {
3010     STRLEN len;
3011     const char * const s = SvPV_const(ssv,len);
3012
3013     PERL_ARGS_ASSERT_SV_COPYPV;
3014
3015     sv_setpvn(dsv,s,len);
3016     if (SvUTF8(ssv))
3017         SvUTF8_on(dsv);
3018     else
3019         SvUTF8_off(dsv);
3020 }
3021
3022 /*
3023 =for apidoc sv_2pvbyte
3024
3025 Return a pointer to the byte-encoded representation of the SV, and set *lp
3026 to its length.  May cause the SV to be downgraded from UTF-8 as a
3027 side-effect.
3028
3029 Usually accessed via the C<SvPVbyte> macro.
3030
3031 =cut
3032 */
3033
3034 char *
3035 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *const lp)
3036 {
3037     PERL_ARGS_ASSERT_SV_2PVBYTE;
3038
3039     if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv)) {
3040         SV *sv2 = sv_newmortal();
3041         sv_copypv(sv2,sv);
3042         sv = sv2;
3043     }
3044     else SvGETMAGIC(sv);
3045     sv_utf8_downgrade(sv,0);
3046     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3047 }
3048
3049 /*
3050 =for apidoc sv_2pvutf8
3051
3052 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3053 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3054
3055 Usually accessed via the C<SvPVutf8> macro.
3056
3057 =cut
3058 */
3059
3060 char *
3061 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp)
3062 {
3063     PERL_ARGS_ASSERT_SV_2PVUTF8;
3064
3065     if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv))
3066         sv = sv_mortalcopy(sv);
3067     sv_utf8_upgrade(sv);
3068     if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~SVf_POK;
3069     assert(SvPOKp(sv));
3070     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3071 }
3072
3073
3074 /*
3075 =for apidoc sv_2bool
3076
3077 This macro is only used by sv_true() or its macro equivalent, and only if
3078 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3079 It calls sv_2bool_flags with the SV_GMAGIC flag.
3080
3081 =for apidoc sv_2bool_flags
3082
3083 This function is only used by sv_true() and friends,  and only if
3084 the latter's argument is neither SvPOK, SvIOK nor SvNOK.  If the flags
3085 contain SV_GMAGIC, then it does an mg_get() first.
3086
3087
3088 =cut
3089 */
3090
3091 bool
3092 Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
3093 {
3094     dVAR;
3095
3096     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3097
3098     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3099
3100     if (!SvOK(sv))
3101         return 0;
3102     if (SvROK(sv)) {
3103         if (SvAMAGIC(sv)) {
3104             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3105             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3106                 return cBOOL(SvTRUE(tmpsv));
3107         }
3108         return SvRV(sv) != 0;
3109     }
3110     if (SvPOKp(sv)) {
3111         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3112         if (Xpvtmp &&
3113                 (*sv->sv_u.svu_pv > '0' ||
3114                 Xpvtmp->xpv_cur > 1 ||
3115                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3116             return 1;
3117         else
3118             return 0;
3119     }
3120     else {
3121         if (SvIOKp(sv))
3122             return SvIVX(sv) != 0;
3123         else {
3124             if (SvNOKp(sv))
3125                 return SvNVX(sv) != 0.0;
3126             else {
3127                 if (isGV_with_GP(sv))
3128                     return TRUE;
3129                 else
3130                     return FALSE;
3131             }
3132         }
3133     }
3134 }
3135
3136 /*
3137 =for apidoc sv_utf8_upgrade
3138
3139 Converts the PV of an SV to its UTF-8-encoded form.
3140 Forces the SV to string form if it is not already.
3141 Will C<mg_get> on C<sv> if appropriate.
3142 Always sets the SvUTF8 flag to avoid future validity checks even
3143 if the whole string is the same in UTF-8 as not.
3144 Returns the number of bytes in the converted string
3145
3146 This is not as a general purpose byte encoding to Unicode interface:
3147 use the Encode extension for that.
3148
3149 =for apidoc sv_utf8_upgrade_nomg
3150
3151 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3152
3153 =for apidoc sv_utf8_upgrade_flags
3154
3155 Converts the PV of an SV to its UTF-8-encoded form.
3156 Forces the SV to string form if it is not already.
3157 Always sets the SvUTF8 flag to avoid future validity checks even
3158 if all the bytes are invariant in UTF-8.
3159 If C<flags> has C<SV_GMAGIC> bit set,
3160 will C<mg_get> on C<sv> if appropriate, else not.
3161 Returns the number of bytes in the converted string
3162 C<sv_utf8_upgrade> and
3163 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3164
3165 This is not as a general purpose byte encoding to Unicode interface:
3166 use the Encode extension for that.
3167
3168 =cut
3169
3170 The grow version is currently not externally documented.  It adds a parameter,
3171 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3172 have free after it upon return.  This allows the caller to reserve extra space
3173 that it intends to fill, to avoid extra grows.
3174
3175 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3176 which can be used to tell this function to not first check to see if there are
3177 any characters that are different in UTF-8 (variant characters) which would
3178 force it to allocate a new string to sv, but to assume there are.  Typically
3179 this flag is used by a routine that has already parsed the string to find that
3180 there are such characters, and passes this information on so that the work
3181 doesn't have to be repeated.
3182
3183 (One might think that the calling routine could pass in the position of the
3184 first such variant, so it wouldn't have to be found again.  But that is not the
3185 case, because typically when the caller is likely to use this flag, it won't be
3186 calling this routine unless it finds something that won't fit into a byte.
3187 Otherwise it tries to not upgrade and just use bytes.  But some things that
3188 do fit into a byte are variants in utf8, and the caller may not have been
3189 keeping track of these.)
3190
3191 If the routine itself changes the string, it adds a trailing NUL.  Such a NUL
3192 isn't guaranteed due to having other routines do the work in some input cases,
3193 or if the input is already flagged as being in utf8.
3194
3195 The speed of this could perhaps be improved for many cases if someone wanted to
3196 write a fast function that counts the number of variant characters in a string,
3197 especially if it could return the position of the first one.
3198
3199 */
3200
3201 STRLEN
3202 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3203 {
3204     dVAR;
3205
3206     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3207
3208     if (sv == &PL_sv_undef)
3209         return 0;
3210     if (!SvPOK(sv)) {
3211         STRLEN len = 0;
3212         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3213             (void) sv_2pv_flags(sv,&len, flags);
3214             if (SvUTF8(sv)) {
3215                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3216                 return len;
3217             }
3218         } else {
3219             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3220         }
3221     }
3222
3223     if (SvUTF8(sv)) {
3224         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3225         return SvCUR(sv);
3226     }
3227
3228     if (SvIsCOW(sv)) {
3229         sv_force_normal_flags(sv, 0);
3230     }
3231
3232     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3233         sv_recode_to_utf8(sv, PL_encoding);
3234         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3235         return SvCUR(sv);
3236     }
3237
3238     if (SvCUR(sv) == 0) {
3239         if (extra) SvGROW(sv, extra);
3240     } else { /* Assume Latin-1/EBCDIC */
3241         /* This function could be much more efficient if we
3242          * had a FLAG in SVs to signal if there are any variant
3243          * chars in the PV.  Given that there isn't such a flag
3244          * make the loop as fast as possible (although there are certainly ways
3245          * to speed this up, eg. through vectorization) */
3246         U8 * s = (U8 *) SvPVX_const(sv);
3247         U8 * e = (U8 *) SvEND(sv);
3248         U8 *t = s;
3249         STRLEN two_byte_count = 0;
3250
3251         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3252
3253         /* See if really will need to convert to utf8.  We mustn't rely on our
3254          * incoming SV being well formed and having a trailing '\0', as certain
3255          * code in pp_formline can send us partially built SVs. */
3256
3257         while (t < e) {
3258             const U8 ch = *t++;
3259             if (NATIVE_IS_INVARIANT(ch)) continue;
3260
3261             t--;    /* t already incremented; re-point to first variant */
3262             two_byte_count = 1;
3263             goto must_be_utf8;
3264         }
3265
3266         /* utf8 conversion not needed because all are invariants.  Mark as
3267          * UTF-8 even if no variant - saves scanning loop */
3268         SvUTF8_on(sv);
3269         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3270         return SvCUR(sv);
3271
3272 must_be_utf8:
3273
3274         /* Here, the string should be converted to utf8, either because of an
3275          * input flag (two_byte_count = 0), or because a character that
3276          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3277          * the beginning of the string (if we didn't examine anything), or to
3278          * the first variant.  In either case, everything from s to t - 1 will
3279          * occupy only 1 byte each on output.
3280          *
3281          * There are two main ways to convert.  One is to create a new string
3282          * and go through the input starting from the beginning, appending each
3283          * converted value onto the new string as we go along.  It's probably
3284          * best to allocate enough space in the string for the worst possible
3285          * case rather than possibly running out of space and having to
3286          * reallocate and then copy what we've done so far.  Since everything
3287          * from s to t - 1 is invariant, the destination can be initialized
3288          * with these using a fast memory copy
3289          *
3290          * The other way is to figure out exactly how big the string should be
3291          * by parsing the entire input.  Then you don't have to make it big
3292          * enough to handle the worst possible case, and more importantly, if
3293          * the string you already have is large enough, you don't have to
3294          * allocate a new string, you can copy the last character in the input
3295          * string to the final position(s) that will be occupied by the
3296          * converted string and go backwards, stopping at t, since everything
3297          * before that is invariant.
3298          *
3299          * There are advantages and disadvantages to each method.
3300          *
3301          * In the first method, we can allocate a new string, do the memory
3302          * copy from the s to t - 1, and then proceed through the rest of the
3303          * string byte-by-byte.
3304          *
3305          * In the second method, we proceed through the rest of the input
3306          * string just calculating how big the converted string will be.  Then
3307          * there are two cases:
3308          *  1)  if the string has enough extra space to handle the converted
3309          *      value.  We go backwards through the string, converting until we
3310          *      get to the position we are at now, and then stop.  If this
3311          *      position is far enough along in the string, this method is
3312          *      faster than the other method.  If the memory copy were the same
3313          *      speed as the byte-by-byte loop, that position would be about
3314          *      half-way, as at the half-way mark, parsing to the end and back
3315          *      is one complete string's parse, the same amount as starting
3316          *      over and going all the way through.  Actually, it would be
3317          *      somewhat less than half-way, as it's faster to just count bytes
3318          *      than to also copy, and we don't have the overhead of allocating
3319          *      a new string, changing the scalar to use it, and freeing the
3320          *      existing one.  But if the memory copy is fast, the break-even
3321          *      point is somewhere after half way.  The counting loop could be
3322          *      sped up by vectorization, etc, to move the break-even point
3323          *      further towards the beginning.
3324          *  2)  if the string doesn't have enough space to handle the converted
3325          *      value.  A new string will have to be allocated, and one might
3326          *      as well, given that, start from the beginning doing the first
3327          *      method.  We've spent extra time parsing the string and in
3328          *      exchange all we've gotten is that we know precisely how big to
3329          *      make the new one.  Perl is more optimized for time than space,
3330          *      so this case is a loser.
3331          * So what I've decided to do is not use the 2nd method unless it is
3332          * guaranteed that a new string won't have to be allocated, assuming
3333          * the worst case.  I also decided not to put any more conditions on it
3334          * than this, for now.  It seems likely that, since the worst case is
3335          * twice as big as the unknown portion of the string (plus 1), we won't
3336          * be guaranteed enough space, causing us to go to the first method,
3337          * unless the string is short, or the first variant character is near
3338          * the end of it.  In either of these cases, it seems best to use the
3339          * 2nd method.  The only circumstance I can think of where this would
3340          * be really slower is if the string had once had much more data in it
3341          * than it does now, but there is still a substantial amount in it  */
3342
3343         {
3344             STRLEN invariant_head = t - s;
3345             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3346             if (SvLEN(sv) < size) {
3347
3348                 /* Here, have decided to allocate a new string */
3349
3350                 U8 *dst;
3351                 U8 *d;
3352
3353                 Newx(dst, size, U8);
3354
3355                 /* If no known invariants at the beginning of the input string,
3356                  * set so starts from there.  Otherwise, can use memory copy to
3357                  * get up to where we are now, and then start from here */
3358
3359                 if (invariant_head <= 0) {
3360                     d = dst;
3361                 } else {
3362                     Copy(s, dst, invariant_head, char);
3363                     d = dst + invariant_head;
3364                 }
3365
3366                 while (t < e) {
3367                     const UV uv = NATIVE8_TO_UNI(*t++);
3368                     if (UNI_IS_INVARIANT(uv))
3369                         *d++ = (U8)UNI_TO_NATIVE(uv);
3370                     else {
3371                         *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3372                         *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3373                     }
3374                 }
3375                 *d = '\0';
3376                 SvPV_free(sv); /* No longer using pre-existing string */
3377                 SvPV_set(sv, (char*)dst);
3378                 SvCUR_set(sv, d - dst);
3379                 SvLEN_set(sv, size);
3380             } else {
3381
3382                 /* Here, have decided to get the exact size of the string.
3383                  * Currently this happens only when we know that there is
3384                  * guaranteed enough space to fit the converted string, so
3385                  * don't have to worry about growing.  If two_byte_count is 0,
3386                  * then t points to the first byte of the string which hasn't
3387                  * been examined yet.  Otherwise two_byte_count is 1, and t
3388                  * points to the first byte in the string that will expand to
3389                  * two.  Depending on this, start examining at t or 1 after t.
3390                  * */
3391
3392                 U8 *d = t + two_byte_count;
3393
3394
3395                 /* Count up the remaining bytes that expand to two */
3396
3397                 while (d < e) {
3398                     const U8 chr = *d++;
3399                     if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3400                 }
3401
3402                 /* The string will expand by just the number of bytes that
3403                  * occupy two positions.  But we are one afterwards because of
3404                  * the increment just above.  This is the place to put the
3405                  * trailing NUL, and to set the length before we decrement */
3406
3407                 d += two_byte_count;
3408                 SvCUR_set(sv, d - s);
3409                 *d-- = '\0';
3410
3411
3412                 /* Having decremented d, it points to the position to put the
3413                  * very last byte of the expanded string.  Go backwards through
3414                  * the string, copying and expanding as we go, stopping when we
3415                  * get to the part that is invariant the rest of the way down */
3416
3417                 e--;
3418                 while (e >= t) {
3419                     const U8 ch = NATIVE8_TO_UNI(*e--);
3420                     if (UNI_IS_INVARIANT(ch)) {
3421                         *d-- = UNI_TO_NATIVE(ch);
3422                     } else {
3423                         *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3424                         *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3425                     }
3426                 }
3427             }
3428
3429             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3430                 /* Update pos. We do it at the end rather than during
3431                  * the upgrade, to avoid slowing down the common case
3432                  * (upgrade without pos) */
3433                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3434                 if (mg) {
3435                     I32 pos = mg->mg_len;
3436                     if (pos > 0 && (U32)pos > invariant_head) {
3437                         U8 *d = (U8*) SvPVX(sv) + invariant_head;
3438                         STRLEN n = (U32)pos - invariant_head;
3439                         while (n > 0) {
3440                             if (UTF8_IS_START(*d))
3441                                 d++;
3442                             d++;
3443                             n--;
3444                         }
3445                         mg->mg_len  = d - (U8*)SvPVX(sv);
3446                     }
3447                 }
3448                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3449                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3450             }
3451         }
3452     }
3453
3454     /* Mark as UTF-8 even if no variant - saves scanning loop */
3455     SvUTF8_on(sv);
3456     return SvCUR(sv);
3457 }
3458
3459 /*
3460 =for apidoc sv_utf8_downgrade
3461
3462 Attempts to convert the PV of an SV from characters to bytes.
3463 If the PV contains a character that cannot fit
3464 in a byte, this conversion will fail;
3465 in this case, either returns false or, if C<fail_ok> is not
3466 true, croaks.
3467
3468 This is not as a general purpose Unicode to byte encoding interface:
3469 use the Encode extension for that.
3470
3471 =cut
3472 */
3473
3474 bool
3475 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3476 {
3477     dVAR;
3478
3479     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3480
3481     if (SvPOKp(sv) && SvUTF8(sv)) {
3482         if (SvCUR(sv)) {
3483             U8 *s;
3484             STRLEN len;
3485             int mg_flags = SV_GMAGIC;
3486
3487             if (SvIsCOW(sv)) {
3488                 sv_force_normal_flags(sv, 0);
3489             }
3490             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3491                 /* update pos */
3492                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3493                 if (mg) {
3494                     I32 pos = mg->mg_len;
3495                     if (pos > 0) {
3496                         sv_pos_b2u(sv, &pos);
3497                         mg_flags = 0; /* sv_pos_b2u does get magic */
3498                         mg->mg_len  = pos;
3499                     }
3500                 }
3501                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3502                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3503
3504             }
3505             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3506
3507             if (!utf8_to_bytes(s, &len)) {
3508                 if (fail_ok)
3509                     return FALSE;
3510                 else {
3511                     if (PL_op)
3512                         Perl_croak(aTHX_ "Wide character in %s",
3513                                    OP_DESC(PL_op));
3514                     else
3515                         Perl_croak(aTHX_ "Wide character");
3516                 }
3517             }
3518             SvCUR_set(sv, len);
3519         }
3520     }
3521     SvUTF8_off(sv);
3522     return TRUE;
3523 }
3524
3525 /*
3526 =for apidoc sv_utf8_encode
3527
3528 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3529 flag off so that it looks like octets again.
3530
3531 =cut
3532 */
3533
3534 void
3535 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3536 {
3537     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3538
3539     if (SvREADONLY(sv)) {
3540         sv_force_normal_flags(sv, 0);
3541     }
3542     (void) sv_utf8_upgrade(sv);
3543     SvUTF8_off(sv);
3544 }
3545
3546 /*
3547 =for apidoc sv_utf8_decode
3548
3549 If the PV of the SV is an octet sequence in UTF-8
3550 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3551 so that it looks like a character.  If the PV contains only single-byte
3552 characters, the C<SvUTF8> flag stays off.
3553 Scans PV for validity and returns false if the PV is invalid UTF-8.
3554
3555 =cut
3556 */
3557
3558 bool
3559 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3560 {
3561     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3562
3563     if (SvPOKp(sv)) {
3564         const U8 *start, *c;
3565         const U8 *e;
3566
3567         /* The octets may have got themselves encoded - get them back as
3568          * bytes
3569          */
3570         if (!sv_utf8_downgrade(sv, TRUE))
3571             return FALSE;
3572
3573         /* it is actually just a matter of turning the utf8 flag on, but
3574          * we want to make sure everything inside is valid utf8 first.
3575          */
3576         c = start = (const U8 *) SvPVX_const(sv);
3577         if (!is_utf8_string(c, SvCUR(sv)))
3578             return FALSE;
3579         e = (const U8 *) SvEND(sv);
3580         while (c < e) {
3581             const U8 ch = *c++;
3582             if (!UTF8_IS_INVARIANT(ch)) {
3583                 SvUTF8_on(sv);
3584                 break;
3585             }
3586         }
3587         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3588             /* adjust pos to the start of a UTF8 char sequence */
3589             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3590             if (mg) {
3591                 I32 pos = mg->mg_len;
3592                 if (pos > 0) {
3593                     for (c = start + pos; c > start; c--) {
3594                         if (UTF8_IS_START(*c))
3595                             break;
3596                     }
3597                     mg->mg_len  = c - start;
3598                 }
3599             }
3600             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3601                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3602         }
3603     }
3604     return TRUE;
3605 }
3606
3607 /*
3608 =for apidoc sv_setsv
3609
3610 Copies the contents of the source SV C<ssv> into the destination SV
3611 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3612 function if the source SV needs to be reused.  Does not handle 'set' magic.
3613 Loosely speaking, it performs a copy-by-value, obliterating any previous
3614 content of the destination.
3615
3616 You probably want to use one of the assortment of wrappers, such as
3617 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3618 C<SvSetMagicSV_nosteal>.
3619
3620 =for apidoc sv_setsv_flags
3621
3622 Copies the contents of the source SV C<ssv> into the destination SV
3623 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3624 function if the source SV needs to be reused.  Does not handle 'set' magic.
3625 Loosely speaking, it performs a copy-by-value, obliterating any previous
3626 content of the destination.
3627 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3628 C<ssv> if appropriate, else not.  If the C<flags>
3629 parameter has the C<NOSTEAL> bit set then the
3630 buffers of temps will not be stolen.  <sv_setsv>
3631 and C<sv_setsv_nomg> are implemented in terms of this function.
3632
3633 You probably want to use one of the assortment of wrappers, such as
3634 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3635 C<SvSetMagicSV_nosteal>.
3636
3637 This is the primary function for copying scalars, and most other
3638 copy-ish functions and macros use this underneath.
3639
3640 =cut
3641 */
3642
3643 static void
3644 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3645 {
3646     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3647     HV *old_stash = NULL;
3648
3649     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3650
3651     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3652         const char * const name = GvNAME(sstr);
3653         const STRLEN len = GvNAMELEN(sstr);
3654         {
3655             if (dtype >= SVt_PV) {
3656                 SvPV_free(dstr);
3657                 SvPV_set(dstr, 0);
3658                 SvLEN_set(dstr, 0);
3659                 SvCUR_set(dstr, 0);
3660             }
3661             SvUPGRADE(dstr, SVt_PVGV);
3662             (void)SvOK_off(dstr);
3663             /* We have to turn this on here, even though we turn it off
3664                below, as GvSTASH will fail an assertion otherwise. */
3665             isGV_with_GP_on(dstr);
3666         }
3667         GvSTASH(dstr) = GvSTASH(sstr);
3668         if (GvSTASH(dstr))
3669             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3670         gv_name_set(MUTABLE_GV(dstr), name, len,
3671                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3672         SvFAKE_on(dstr);        /* can coerce to non-glob */
3673     }
3674
3675     if(GvGP(MUTABLE_GV(sstr))) {
3676         /* If source has method cache entry, clear it */
3677         if(GvCVGEN(sstr)) {
3678             SvREFCNT_dec(GvCV(sstr));
3679             GvCV_set(sstr, NULL);
3680             GvCVGEN(sstr) = 0;
3681         }
3682         /* If source has a real method, then a method is
3683            going to change */
3684         else if(
3685          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3686         ) {
3687             mro_changes = 1;
3688         }
3689     }
3690
3691     /* If dest already had a real method, that's a change as well */
3692     if(
3693         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3694      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3695     ) {
3696         mro_changes = 1;
3697     }
3698
3699     /* We don't need to check the name of the destination if it was not a
3700        glob to begin with. */
3701     if(dtype == SVt_PVGV) {
3702         const char * const name = GvNAME((const GV *)dstr);
3703         if(
3704             strEQ(name,"ISA")
3705          /* The stash may have been detached from the symbol table, so
3706             check its name. */
3707          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3708          && GvAV((const GV *)sstr)
3709         )
3710             mro_changes = 2;
3711         else {
3712             const STRLEN len = GvNAMELEN(dstr);
3713             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3714              || (len == 1 && name[0] == ':')) {
3715                 mro_changes = 3;
3716
3717                 /* Set aside the old stash, so we can reset isa caches on
3718                    its subclasses. */
3719                 if((old_stash = GvHV(dstr)))
3720                     /* Make sure we do not lose it early. */
3721                     SvREFCNT_inc_simple_void_NN(
3722                      sv_2mortal((SV *)old_stash)
3723                     );
3724             }
3725         }
3726     }
3727
3728     gp_free(MUTABLE_GV(dstr));
3729     isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */
3730     (void)SvOK_off(dstr);
3731     isGV_with_GP_on(dstr);
3732     GvINTRO_off(dstr);          /* one-shot flag */
3733     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3734     if (SvTAINTED(sstr))
3735         SvTAINT(dstr);
3736     if (GvIMPORTED(dstr) != GVf_IMPORTED
3737         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3738         {
3739             GvIMPORTED_on(dstr);
3740         }
3741     GvMULTI_on(dstr);
3742     if(mro_changes == 2) {
3743         MAGIC *mg;
3744         SV * const sref = (SV *)GvAV((const GV *)dstr);
3745         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3746             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3747                 AV * const ary = newAV();
3748                 av_push(ary, mg->mg_obj); /* takes the refcount */
3749                 mg->mg_obj = (SV *)ary;
3750             }
3751             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3752         }
3753         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3754         mro_isa_changed_in(GvSTASH(dstr));
3755     }
3756     else if(mro_changes == 3) {
3757         HV * const stash = GvHV(dstr);
3758         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3759             mro_package_moved(
3760                 stash, old_stash,
3761                 (GV *)dstr, 0
3762             );
3763     }
3764     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3765     return;
3766 }
3767
3768 static void
3769 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3770 {
3771     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3772     SV *dref = NULL;
3773     const int intro = GvINTRO(dstr);
3774     SV **location;
3775     U8 import_flag = 0;
3776     const U32 stype = SvTYPE(sref);
3777
3778     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3779
3780     if (intro) {
3781         GvINTRO_off(dstr);      /* one-shot flag */
3782         GvLINE(dstr) = CopLINE(PL_curcop);
3783         GvEGV(dstr) = MUTABLE_GV(dstr);
3784     }
3785     GvMULTI_on(dstr);
3786     switch (stype) {
3787     case SVt_PVCV:
3788         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3789         import_flag = GVf_IMPORTED_CV;
3790         goto common;
3791     case SVt_PVHV:
3792         location = (SV **) &GvHV(dstr);
3793         import_flag = GVf_IMPORTED_HV;
3794         goto common;
3795     case SVt_PVAV:
3796         location = (SV **) &GvAV(dstr);
3797         import_flag = GVf_IMPORTED_AV;
3798         goto common;
3799     case SVt_PVIO:
3800         location = (SV **) &GvIOp(dstr);
3801         goto common;
3802     case SVt_PVFM:
3803         location = (SV **) &GvFORM(dstr);
3804         goto common;
3805     default:
3806         location = &GvSV(dstr);
3807         import_flag = GVf_IMPORTED_SV;
3808     common:
3809         if (intro) {
3810             if (stype == SVt_PVCV) {
3811                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3812                 if (GvCVGEN(dstr)) {
3813                     SvREFCNT_dec(GvCV(dstr));
3814                     GvCV_set(dstr, NULL);
3815                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3816                 }
3817             }
3818             SAVEGENERICSV(*location);
3819         }
3820         else
3821             dref = *location;
3822         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3823             CV* const cv = MUTABLE_CV(*location);
3824             if (cv) {
3825                 if (!GvCVGEN((const GV *)dstr) &&
3826                     (CvROOT(cv) || CvXSUB(cv)) &&
3827                     /* redundant check that avoids creating the extra SV
3828                        most of the time: */
3829                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3830                     {
3831                         SV * const new_const_sv =
3832                             CvCONST((const CV *)sref)
3833                                  ? cv_const_sv((const CV *)sref)
3834                                  : NULL;
3835                         report_redefined_cv(
3836                            sv_2mortal(Perl_newSVpvf(aTHX_
3837                                 "%"HEKf"::%"HEKf,
3838                                 HEKfARG(
3839                                  HvNAME_HEK(GvSTASH((const GV *)dstr))
3840                                 ),
3841                                 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
3842                            )),
3843                            cv,
3844                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
3845                         );
3846                     }
3847                 if (!intro)
3848                     cv_ckproto_len_flags(cv, (const GV *)dstr,
3849                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
3850                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3851                                    SvPOK(sref) ? SvUTF8(sref) : 0);
3852             }
3853             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3854             GvASSUMECV_on(dstr);
3855             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3856         }
3857         *location = sref;
3858         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3859             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3860             GvFLAGS(dstr) |= import_flag;
3861         }
3862         if (stype == SVt_PVHV) {
3863             const char * const name = GvNAME((GV*)dstr);
3864             const STRLEN len = GvNAMELEN(dstr);
3865             if (
3866                 (
3867                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3868                 || (len == 1 && name[0] == ':')
3869                 )
3870              && (!dref || HvENAME_get(dref))
3871             ) {
3872                 mro_package_moved(
3873                     (HV *)sref, (HV *)dref,
3874                     (GV *)dstr, 0
3875                 );
3876             }
3877         }
3878         else if (
3879             stype == SVt_PVAV && sref != dref
3880          && strEQ(GvNAME((GV*)dstr), "ISA")
3881          /* The stash may have been detached from the symbol table, so
3882             check its name before doing anything. */
3883          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3884         ) {
3885             MAGIC *mg;
3886             MAGIC * const omg = dref && SvSMAGICAL(dref)
3887                                  ? mg_find(dref, PERL_MAGIC_isa)
3888                                  : NULL;
3889             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3890                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3891                     AV * const ary = newAV();
3892                     av_push(ary, mg->mg_obj); /* takes the refcount */
3893                     mg->mg_obj = (SV *)ary;
3894                 }
3895                 if (omg) {
3896                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3897                         SV **svp = AvARRAY((AV *)omg->mg_obj);
3898                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3899                         while (items--)
3900                             av_push(
3901                              (AV *)mg->mg_obj,
3902                              SvREFCNT_inc_simple_NN(*svp++)
3903                             );
3904                     }
3905                     else
3906                         av_push(
3907                          (AV *)mg->mg_obj,
3908                          SvREFCNT_inc_simple_NN(omg->mg_obj)
3909                         );
3910                 }
3911                 else
3912                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3913             }
3914             else
3915             {
3916                 sv_magic(
3917                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3918                 );
3919                 mg = mg_find(sref, PERL_MAGIC_isa);
3920             }
3921             /* Since the *ISA assignment could have affected more than
3922                one stash, don't call mro_isa_changed_in directly, but let
3923                magic_clearisa do it for us, as it already has the logic for
3924                dealing with globs vs arrays of globs. */
3925             assert(mg);
3926             Perl_magic_clearisa(aTHX_ NULL, mg);
3927         }
3928         break;
3929     }
3930     SvREFCNT_dec(dref);
3931     if (SvTAINTED(sstr))
3932         SvTAINT(dstr);
3933     return;
3934 }
3935
3936 void
3937 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3938 {
3939     dVAR;
3940     register U32 sflags;
3941     register int dtype;
3942     register svtype stype;
3943
3944     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3945
3946     if (sstr == dstr)
3947         return;
3948
3949     if (SvIS_FREED(dstr)) {
3950         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3951                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3952     }
3953     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3954     if (!sstr)
3955         sstr = &PL_sv_undef;
3956     if (SvIS_FREED(sstr)) {
3957         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3958                    (void*)sstr, (void*)dstr);
3959     }
3960     stype = SvTYPE(sstr);
3961     dtype = SvTYPE(dstr);
3962
3963     (void)SvAMAGIC_off(dstr);
3964     if ( SvVOK(dstr) )
3965     {
3966         /* need to nuke the magic */
3967         sv_unmagic(dstr, PERL_MAGIC_vstring);
3968     }
3969
3970     /* There's a lot of redundancy below but we're going for speed here */
3971
3972     switch (stype) {
3973     case SVt_NULL:
3974       undef_sstr:
3975         if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3976             (void)SvOK_off(dstr);
3977             return;
3978         }
3979         break;
3980     case SVt_IV:
3981         if (SvIOK(sstr)) {
3982             switch (dtype) {
3983             case SVt_NULL:
3984                 sv_upgrade(dstr, SVt_IV);
3985                 break;
3986             case SVt_NV:
3987             case SVt_PV:
3988                 sv_upgrade(dstr, SVt_PVIV);
3989                 break;
3990             case SVt_PVGV:
3991             case SVt_PVLV:
3992                 goto end_of_first_switch;
3993             }
3994             (void)SvIOK_only(dstr);
3995             SvIV_set(dstr,  SvIVX(sstr));
3996             if (SvIsUV(sstr))
3997                 SvIsUV_on(dstr);
3998             /* SvTAINTED can only be true if the SV has taint magic, which in
3999                turn means that the SV type is PVMG (or greater). This is the
4000                case statement for SVt_IV, so this cannot be true (whatever gcov
4001                may say).  */
4002             assert(!SvTAINTED(sstr));
4003             return;
4004         }
4005         if (!SvROK(sstr))
4006             goto undef_sstr;
4007         if (dtype < SVt_PV && dtype != SVt_IV)
4008             sv_upgrade(dstr, SVt_IV);
4009         break;
4010
4011     case SVt_NV:
4012         if (SvNOK(sstr)) {
4013             switch (dtype) {
4014             case SVt_NULL:
4015             case SVt_IV:
4016                 sv_upgrade(dstr, SVt_NV);
4017                 break;
4018             case SVt_PV:
4019             case SVt_PVIV:
4020                 sv_upgrade(dstr, SVt_PVNV);
4021                 break;
4022             case SVt_PVGV:
4023             case SVt_PVLV:
4024                 goto end_of_first_switch;
4025             }
4026             SvNV_set(dstr, SvNVX(sstr));
4027             (void)SvNOK_only(dstr);
4028             /* SvTAINTED can only be true if the SV has taint magic, which in
4029                turn means that the SV type is PVMG (or greater). This is the
4030                case statement for SVt_NV, so this cannot be true (whatever gcov
4031                may say).  */
4032             assert(!SvTAINTED(sstr));
4033             return;
4034         }
4035         goto undef_sstr;
4036
4037     case SVt_PVFM:
4038 #ifdef PERL_OLD_COPY_ON_WRITE
4039         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4040             if (dtype < SVt_PVIV)
4041                 sv_upgrade(dstr, SVt_PVIV);
4042             break;
4043         }
4044         /* Fall through */
4045 #endif
4046     case SVt_PV:
4047         if (dtype < SVt_PV)
4048             sv_upgrade(dstr, SVt_PV);
4049         break;
4050     case SVt_PVIV:
4051         if (dtype < SVt_PVIV)
4052             sv_upgrade(dstr, SVt_PVIV);
4053         break;
4054     case SVt_PVNV:
4055         if (dtype < SVt_PVNV)
4056             sv_upgrade(dstr, SVt_PVNV);
4057         break;
4058     default:
4059         {
4060         const char * const type = sv_reftype(sstr,0);
4061         if (PL_op)
4062             /* diag_listed_as: Bizarre copy of %s */
4063             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4064         else
4065             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4066         }
4067         break;
4068
4069     case SVt_REGEXP:
4070         if (dtype < SVt_REGEXP)
4071             sv_upgrade(dstr, SVt_REGEXP);
4072         break;
4073
4074         /* case SVt_BIND: */
4075     case SVt_PVLV:
4076     case SVt_PVGV:
4077     case SVt_PVMG:
4078         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4079             mg_get(sstr);
4080             if (SvTYPE(sstr) != stype)
4081                 stype = SvTYPE(sstr);
4082         }
4083         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4084                     glob_assign_glob(dstr, sstr, dtype);
4085                     return;
4086         }
4087         if (stype == SVt_PVLV)
4088             SvUPGRADE(dstr, SVt_PVNV);
4089         else
4090             SvUPGRADE(dstr, (svtype)stype);
4091     }
4092  end_of_first_switch:
4093
4094     /* dstr may have been upgraded.  */
4095     dtype = SvTYPE(dstr);
4096     sflags = SvFLAGS(sstr);
4097
4098     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
4099         /* Assigning to a subroutine sets the prototype.  */
4100         if (SvOK(sstr)) {
4101             STRLEN len;
4102             const char *const ptr = SvPV_const(sstr, len);
4103
4104             SvGROW(dstr, len + 1);
4105             Copy(ptr, SvPVX(dstr), len + 1, char);
4106             SvCUR_set(dstr, len);
4107             SvPOK_only(dstr);
4108             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4109             CvAUTOLOAD_off(dstr);
4110         } else {
4111             SvOK_off(dstr);
4112         }
4113     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
4114         const char * const type = sv_reftype(dstr,0);
4115         if (PL_op)
4116             /* diag_listed_as: Cannot copy to %s */
4117             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4118         else
4119             Perl_croak(aTHX_ "Cannot copy to %s", type);
4120     } else if (sflags & SVf_ROK) {
4121         if (isGV_with_GP(dstr)
4122             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4123             sstr = SvRV(sstr);
4124             if (sstr == dstr) {
4125                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4126                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4127                 {
4128                     GvIMPORTED_on(dstr);
4129                 }
4130                 GvMULTI_on(dstr);
4131                 return;
4132             }
4133             glob_assign_glob(dstr, sstr, dtype);
4134             return;
4135         }
4136
4137         if (dtype >= SVt_PV) {
4138             if (isGV_with_GP(dstr)) {
4139                 glob_assign_ref(dstr, sstr);
4140                 return;
4141             }
4142             if (SvPVX_const(dstr)) {
4143                 SvPV_free(dstr);
4144                 SvLEN_set(dstr, 0);
4145                 SvCUR_set(dstr, 0);
4146             }
4147         }
4148         (void)SvOK_off(dstr);
4149         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4150         SvFLAGS(dstr) |= sflags & SVf_ROK;
4151         assert(!(sflags & SVp_NOK));
4152         assert(!(sflags & SVp_IOK));
4153         assert(!(sflags & SVf_NOK));
4154         assert(!(sflags & SVf_IOK));
4155     }
4156     else if (isGV_with_GP(dstr)) {
4157         if (!(sflags & SVf_OK)) {
4158             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4159                            "Undefined value assigned to typeglob");
4160         }
4161         else {
4162             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4163             if (dstr != (const SV *)gv) {
4164                 const char * const name = GvNAME((const GV *)dstr);
4165                 const STRLEN len = GvNAMELEN(dstr);
4166                 HV *old_stash = NULL;
4167                 bool reset_isa = FALSE;
4168                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4169                  || (len == 1 && name[0] == ':')) {
4170                     /* Set aside the old stash, so we can reset isa caches
4171                        on its subclasses. */
4172                     if((old_stash = GvHV(dstr))) {
4173                         /* Make sure we do not lose it early. */
4174                         SvREFCNT_inc_simple_void_NN(
4175                          sv_2mortal((SV *)old_stash)
4176                         );
4177                     }
4178                     reset_isa = TRUE;
4179                 }
4180
4181                 if (GvGP(dstr))
4182                     gp_free(MUTABLE_GV(dstr));
4183                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4184
4185                 if (reset_isa) {
4186                     HV * const stash = GvHV(dstr);
4187                     if(
4188                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4189                     )
4190                         mro_package_moved(
4191                          stash, old_stash,
4192                          (GV *)dstr, 0
4193                         );
4194                 }
4195             }
4196         }
4197     }
4198     else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4199         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4200     }
4201     else if (sflags & SVp_POK) {
4202         bool isSwipe = 0;
4203
4204         /*
4205          * Check to see if we can just swipe the string.  If so, it's a
4206          * possible small lose on short strings, but a big win on long ones.
4207          * It might even be a win on short strings if SvPVX_const(dstr)
4208          * has to be allocated and SvPVX_const(sstr) has to be freed.
4209          * Likewise if we can set up COW rather than doing an actual copy, we
4210          * drop to the else clause, as the swipe code and the COW setup code
4211          * have much in common.
4212          */
4213
4214         /* Whichever path we take through the next code, we want this true,
4215            and doing it now facilitates the COW check.  */
4216         (void)SvPOK_only(dstr);
4217
4218         if (
4219             /* If we're already COW then this clause is not true, and if COW
4220                is allowed then we drop down to the else and make dest COW
4221                with us.  If caller hasn't said that we're allowed to COW
4222                shared hash keys then we don't do the COW setup, even if the
4223                source scalar is a shared hash key scalar.  */
4224             (((flags & SV_COW_SHARED_HASH_KEYS)
4225                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4226                : 1 /* If making a COW copy is forbidden then the behaviour we
4227                        desire is as if the source SV isn't actually already
4228                        COW, even if it is.  So we act as if the source flags
4229                        are not COW, rather than actually testing them.  */
4230               )
4231 #ifndef PERL_OLD_COPY_ON_WRITE
4232              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4233                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4234                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4235                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4236                 but in turn, it's somewhat dead code, never expected to go
4237                 live, but more kept as a placeholder on how to do it better
4238                 in a newer implementation.  */
4239              /* If we are COW and dstr is a suitable target then we drop down
4240                 into the else and make dest a COW of us.  */
4241              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4242 #endif
4243              )
4244             &&
4245             !(isSwipe =
4246                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4247                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4248                  (!(flags & SV_NOSTEAL)) &&
4249                                         /* and we're allowed to steal temps */
4250                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4251                  SvLEN(sstr))             /* and really is a string */
4252 #ifdef PERL_OLD_COPY_ON_WRITE
4253             && ((flags & SV_COW_SHARED_HASH_KEYS)
4254                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4255                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4256                      && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4257                 : 1)
4258 #endif
4259             ) {
4260             /* Failed the swipe test, and it's not a shared hash key either.
4261                Have to copy the string.  */
4262             STRLEN len = SvCUR(sstr);
4263             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4264             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4265             SvCUR_set(dstr, len);
4266             *SvEND(dstr) = '\0';
4267         } else {
4268             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4269                be true in here.  */
4270             /* Either it's a shared hash key, or it's suitable for
4271                copy-on-write or we can swipe the string.  */
4272             if (DEBUG_C_TEST) {
4273                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4274                 sv_dump(sstr);
4275                 sv_dump(dstr);
4276             }
4277 #ifdef PERL_OLD_COPY_ON_WRITE
4278             if (!isSwipe) {
4279                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4280                     != (SVf_FAKE | SVf_READONLY)) {
4281                     SvREADONLY_on(sstr);
4282                     SvFAKE_on(sstr);
4283                     /* Make the source SV into a loop of 1.
4284                        (about to become 2) */
4285                     SV_COW_NEXT_SV_SET(sstr, sstr);
4286                 }
4287             }
4288 #endif
4289             /* Initial code is common.  */
4290             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4291                 SvPV_free(dstr);
4292             }
4293
4294             if (!isSwipe) {
4295                 /* making another shared SV.  */
4296                 STRLEN cur = SvCUR(sstr);
4297                 STRLEN len = SvLEN(sstr);
4298 #ifdef PERL_OLD_COPY_ON_WRITE
4299                 if (len) {
4300                     assert (SvTYPE(dstr) >= SVt_PVIV);
4301                     /* SvIsCOW_normal */
4302                     /* splice us in between source and next-after-source.  */
4303                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4304                     SV_COW_NEXT_SV_SET(sstr, dstr);
4305                     SvPV_set(dstr, SvPVX_mutable(sstr));
4306                 } else
4307 #endif
4308                 {
4309                     /* SvIsCOW_shared_hash */
4310                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4311                                           "Copy on write: Sharing hash\n"));
4312
4313                     assert (SvTYPE(dstr) >= SVt_PV);
4314                     SvPV_set(dstr,
4315                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4316                 }
4317                 SvLEN_set(dstr, len);
4318                 SvCUR_set(dstr, cur);
4319                 SvREADONLY_on(dstr);
4320                 SvFAKE_on(dstr);
4321             }
4322             else
4323                 {       /* Passes the swipe test.  */
4324                 SvPV_set(dstr, SvPVX_mutable(sstr));
4325                 SvLEN_set(dstr, SvLEN(sstr));
4326                 SvCUR_set(dstr, SvCUR(sstr));
4327
4328                 SvTEMP_off(dstr);
4329                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4330                 SvPV_set(sstr, NULL);
4331                 SvLEN_set(sstr, 0);
4332                 SvCUR_set(sstr, 0);
4333                 SvTEMP_off(sstr);
4334             }
4335         }
4336         if (sflags & SVp_NOK) {
4337             SvNV_set(dstr, SvNVX(sstr));
4338         }
4339         if (sflags & SVp_IOK) {
4340             SvIV_set(dstr, SvIVX(sstr));
4341             /* Must do this otherwise some other overloaded use of 0x80000000
4342                gets confused. I guess SVpbm_VALID */
4343             if (sflags & SVf_IVisUV)
4344                 SvIsUV_on(dstr);
4345         }
4346         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4347         {
4348             const MAGIC * const smg = SvVSTRING_mg(sstr);
4349             if (smg) {
4350                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4351                          smg->mg_ptr, smg->mg_len);
4352                 SvRMAGICAL_on(dstr);
4353             }
4354         }
4355     }
4356     else if (sflags & (SVp_IOK|SVp_NOK)) {
4357         (void)SvOK_off(dstr);
4358         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4359         if (sflags & SVp_IOK) {
4360             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4361             SvIV_set(dstr, SvIVX(sstr));
4362         }
4363         if (sflags & SVp_NOK) {
4364             SvNV_set(dstr, SvNVX(sstr));
4365         }
4366     }
4367     else {
4368         if (isGV_with_GP(sstr)) {
4369             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4370         }
4371         else
4372             (void)SvOK_off(dstr);
4373     }
4374     if (SvTAINTED(sstr))
4375         SvTAINT(dstr);
4376 }
4377
4378 /*
4379 =for apidoc sv_setsv_mg
4380
4381 Like C<sv_setsv>, but also handles 'set' magic.
4382
4383 =cut
4384 */
4385
4386 void
4387 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4388 {
4389     PERL_ARGS_ASSERT_SV_SETSV_MG;
4390
4391     sv_setsv(dstr,sstr);
4392     SvSETMAGIC(dstr);
4393 }
4394
4395 #ifdef PERL_OLD_COPY_ON_WRITE
4396 SV *
4397 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4398 {
4399     STRLEN cur = SvCUR(sstr);
4400     STRLEN len = SvLEN(sstr);
4401     register char *new_pv;
4402
4403     PERL_ARGS_ASSERT_SV_SETSV_COW;
4404
4405     if (DEBUG_C_TEST) {
4406         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4407                       (void*)sstr, (void*)dstr);
4408         sv_dump(sstr);
4409         if (dstr)
4410                     sv_dump(dstr);
4411     }
4412
4413     if (dstr) {
4414         if (SvTHINKFIRST(dstr))
4415             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4416         else if (SvPVX_const(dstr))
4417             Safefree(SvPVX_const(dstr));
4418     }
4419     else
4420         new_SV(dstr);
4421     SvUPGRADE(dstr, SVt_PVIV);
4422
4423     assert (SvPOK(sstr));
4424     assert (SvPOKp(sstr));
4425     assert (!SvIOK(sstr));
4426     assert (!SvIOKp(sstr));
4427     assert (!SvNOK(sstr));
4428     assert (!SvNOKp(sstr));
4429
4430     if (SvIsCOW(sstr)) {
4431
4432         if (SvLEN(sstr) == 0) {
4433             /* source is a COW shared hash key.  */
4434             DEBUG_C(PerlIO_printf(Perl_debug_log,
4435                                   "Fast copy on write: Sharing hash\n"));
4436             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4437             goto common_exit;
4438         }
4439         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4440     } else {
4441         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4442         SvUPGRADE(sstr, SVt_PVIV);
4443         SvREADONLY_on(sstr);
4444         SvFAKE_on(sstr);
4445         DEBUG_C(PerlIO_printf(Perl_debug_log,
4446                               "Fast copy on write: Converting sstr to COW\n"));
4447         SV_COW_NEXT_SV_SET(dstr, sstr);
4448     }
4449     SV_COW_NEXT_SV_SET(sstr, dstr);
4450     new_pv = SvPVX_mutable(sstr);
4451
4452   common_exit:
4453     SvPV_set(dstr, new_pv);
4454     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4455     if (SvUTF8(sstr))
4456         SvUTF8_on(dstr);
4457     SvLEN_set(dstr, len);
4458     SvCUR_set(dstr, cur);
4459     if (DEBUG_C_TEST) {
4460         sv_dump(dstr);
4461     }
4462     return dstr;
4463 }
4464 #endif
4465
4466 /*
4467 =for apidoc sv_setpvn
4468
4469 Copies a string into an SV.  The C<len> parameter indicates the number of
4470 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4471 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4472
4473 =cut
4474 */
4475
4476 void
4477 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4478 {
4479     dVAR;
4480     register char *dptr;
4481
4482     PERL_ARGS_ASSERT_SV_SETPVN;
4483
4484     SV_CHECK_THINKFIRST_COW_DROP(sv);
4485     if (!ptr) {
4486         (void)SvOK_off(sv);
4487         return;
4488     }
4489     else {
4490         /* len is STRLEN which is unsigned, need to copy to signed */
4491         const IV iv = len;
4492         if (iv < 0)
4493             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4494                        IVdf, iv);
4495     }
4496     SvUPGRADE(sv, SVt_PV);
4497
4498     dptr = SvGROW(sv, len + 1);
4499     Move(ptr,dptr,len,char);
4500     dptr[len] = '\0';
4501     SvCUR_set(sv, len);
4502     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4503     SvTAINT(sv);
4504     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4505 }
4506
4507 /*
4508 =for apidoc sv_setpvn_mg
4509
4510 Like C<sv_setpvn>, but also handles 'set' magic.
4511
4512 =cut
4513 */
4514
4515 void
4516 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4517 {
4518     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4519
4520     sv_setpvn(sv,ptr,len);
4521     SvSETMAGIC(sv);
4522 }
4523
4524 /*
4525 =for apidoc sv_setpv
4526
4527 Copies a string into an SV.  The string must be null-terminated.  Does not
4528 handle 'set' magic.  See C<sv_setpv_mg>.
4529
4530 =cut
4531 */
4532
4533 void
4534 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4535 {
4536     dVAR;
4537     register STRLEN len;
4538
4539     PERL_ARGS_ASSERT_SV_SETPV;
4540
4541     SV_CHECK_THINKFIRST_COW_DROP(sv);
4542     if (!ptr) {
4543         (void)SvOK_off(sv);
4544         return;
4545     }
4546     len = strlen(ptr);
4547     SvUPGRADE(sv, SVt_PV);
4548
4549     SvGROW(sv, len + 1);
4550     Move(ptr,SvPVX(sv),len+1,char);
4551     SvCUR_set(sv, len);
4552     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4553     SvTAINT(sv);
4554     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4555 }
4556
4557 /*
4558 =for apidoc sv_setpv_mg
4559
4560 Like C<sv_setpv>, but also handles 'set' magic.
4561
4562 =cut
4563 */
4564
4565 void
4566 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4567 {
4568     PERL_ARGS_ASSERT_SV_SETPV_MG;
4569
4570     sv_setpv(sv,ptr);
4571     SvSETMAGIC(sv);
4572 }
4573
4574 void
4575 Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek)
4576 {
4577     dVAR;
4578
4579     PERL_ARGS_ASSERT_SV_SETHEK;
4580
4581     if (!hek) {
4582         return;
4583     }
4584
4585     if (HEK_LEN(hek) == HEf_SVKEY) {
4586         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4587         return;
4588     } else {
4589         const int flags = HEK_FLAGS(hek);
4590         if (flags & HVhek_WASUTF8) {
4591             STRLEN utf8_len = HEK_LEN(hek);
4592             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4593             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4594             SvUTF8_on(sv);
4595             return;
4596         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
4597             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4598             if (HEK_UTF8(hek))
4599                 SvUTF8_on(sv);
4600             else SvUTF8_off(sv);
4601             return;
4602         }
4603         {
4604             SV_CHECK_THINKFIRST_COW_DROP(sv);
4605             SvUPGRADE(sv, SVt_PV);
4606             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4607             SvCUR_set(sv, HEK_LEN(hek));
4608             SvLEN_set(sv, 0);
4609             SvREADONLY_on(sv);
4610             SvFAKE_on(sv);
4611             SvPOK_on(sv);
4612             if (HEK_UTF8(hek))
4613                 SvUTF8_on(sv);
4614             else SvUTF8_off(sv);
4615             return;
4616         }
4617     }
4618 }
4619
4620
4621 /*
4622 =for apidoc sv_usepvn_flags
4623
4624 Tells an SV to use C<ptr> to find its string value.  Normally the
4625 string is stored inside the SV but sv_usepvn allows the SV to use an
4626 outside string.  The C<ptr> should point to memory that was allocated
4627 by C<malloc>.  It must be the start of a mallocked block
4628 of memory, and not a pointer to the middle of it.  The
4629 string length, C<len>, must be supplied.  By default
4630 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4631 so that pointer should not be freed or used by the programmer after
4632 giving it to sv_usepvn, and neither should any pointers from "behind"
4633 that pointer (e.g. ptr + 1) be used.
4634
4635 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC.  If C<flags> &
4636 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4637 will be skipped (i.e. the buffer is actually at least 1 byte longer than
4638 C<len>, and already meets the requirements for storing in C<SvPVX>).
4639
4640 =cut
4641 */
4642
4643 void
4644 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4645 {
4646     dVAR;
4647     STRLEN allocate;
4648
4649     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4650
4651     SV_CHECK_THINKFIRST_COW_DROP(sv);
4652     SvUPGRADE(sv, SVt_PV);
4653     if (!ptr) {
4654         (void)SvOK_off(sv);
4655         if (flags & SV_SMAGIC)
4656             SvSETMAGIC(sv);
4657         return;
4658     }
4659     if (SvPVX_const(sv))
4660         SvPV_free(sv);
4661
4662 #ifdef DEBUGGING
4663     if (flags & SV_HAS_TRAILING_NUL)
4664         assert(ptr[len] == '\0');
4665 #endif
4666
4667     allocate = (flags & SV_HAS_TRAILING_NUL)
4668         ? len + 1 :
4669 #ifdef Perl_safesysmalloc_size
4670         len + 1;
4671 #else
4672         PERL_STRLEN_ROUNDUP(len + 1);
4673 #endif
4674     if (flags & SV_HAS_TRAILING_NUL) {
4675         /* It's long enough - do nothing.
4676            Specifically Perl_newCONSTSUB is relying on this.  */
4677     } else {
4678 #ifdef DEBUGGING
4679         /* Force a move to shake out bugs in callers.  */
4680         char *new_ptr = (char*)safemalloc(allocate);
4681         Copy(ptr, new_ptr, len, char);
4682         PoisonFree(ptr,len,char);
4683         Safefree(ptr);
4684         ptr = new_ptr;
4685 #else
4686         ptr = (char*) saferealloc (ptr, allocate);
4687 #endif
4688     }
4689 #ifdef Perl_safesysmalloc_size
4690     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4691 #else
4692     SvLEN_set(sv, allocate);
4693 #endif
4694     SvCUR_set(sv, len);
4695     SvPV_set(sv, ptr);
4696     if (!(flags & SV_HAS_TRAILING_NUL)) {
4697         ptr[len] = '\0';
4698     }
4699     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4700     SvTAINT(sv);
4701     if (flags & SV_SMAGIC)
4702         SvSETMAGIC(sv);
4703 }
4704
4705 #ifdef PERL_OLD_COPY_ON_WRITE
4706 /* Need to do this *after* making the SV normal, as we need the buffer
4707    pointer to remain valid until after we've copied it.  If we let go too early,
4708    another thread could invalidate it by unsharing last of the same hash key
4709    (which it can do by means other than releasing copy-on-write Svs)
4710    or by changing the other copy-on-write SVs in the loop.  */
4711 STATIC void
4712 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4713 {
4714     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4715
4716     { /* this SV was SvIsCOW_normal(sv) */
4717          /* we need to find the SV pointing to us.  */
4718         SV *current = SV_COW_NEXT_SV(after);
4719
4720         if (current == sv) {
4721             /* The SV we point to points back to us (there were only two of us
4722                in the loop.)
4723                Hence other SV is no longer copy on write either.  */
4724             SvFAKE_off(after);
4725             SvREADONLY_off(after);
4726         } else {
4727             /* We need to follow the pointers around the loop.  */
4728             SV *next;
4729             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4730                 assert (next);
4731                 current = next;
4732                  /* don't loop forever if the structure is bust, and we have
4733                     a pointer into a closed loop.  */
4734                 assert (current != after);
4735                 assert (SvPVX_const(current) == pvx);
4736             }
4737             /* Make the SV before us point to the SV after us.  */
4738             SV_COW_NEXT_SV_SET(current, after);
4739         }
4740     }
4741 }
4742 #endif
4743 /*
4744 =for apidoc sv_force_normal_flags
4745
4746 Undo various types of fakery on an SV: if the PV is a shared string, make
4747 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4748 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4749 we do the copy, and is also used locally.  If C<SV_COW_DROP_PV> is set
4750 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4751 SvPOK_off rather than making a copy.  (Used where this
4752 scalar is about to be set to some other value.)  In addition,
4753 the C<flags> parameter gets passed to C<sv_unref_flags()>
4754 when unreffing.  C<sv_force_normal> calls this function
4755 with flags set to 0.
4756
4757 =cut
4758 */
4759
4760 void
4761 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4762 {
4763     dVAR;
4764
4765     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4766
4767 #ifdef PERL_OLD_COPY_ON_WRITE
4768     if (SvREADONLY(sv)) {
4769         if (SvFAKE(sv)) {
4770             const char * const pvx = SvPVX_const(sv);
4771             const STRLEN len = SvLEN(sv);
4772             const STRLEN cur = SvCUR(sv);
4773             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4774                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4775                we'll fail an assertion.  */
4776             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4777
4778             if (DEBUG_C_TEST) {
4779                 PerlIO_printf(Perl_debug_log,
4780                               "Copy on write: Force normal %ld\n",
4781                               (long) flags);
4782                 sv_dump(sv);
4783             }
4784             SvFAKE_off(sv);
4785             SvREADONLY_off(sv);
4786             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4787             SvPV_set(sv, NULL);
4788             SvLEN_set(sv, 0);
4789             if (flags & SV_COW_DROP_PV) {
4790                 /* OK, so we don't need to copy our buffer.  */
4791                 SvPOK_off(sv);
4792             } else {
4793                 SvGROW(sv, cur + 1);
4794                 Move(pvx,SvPVX(sv),cur,char);
4795                 SvCUR_set(sv, cur);
4796                 *SvEND(sv) = '\0';
4797             }
4798             if (len) {
4799                 sv_release_COW(sv, pvx, next);
4800             } else {
4801                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4802             }
4803             if (DEBUG_C_TEST) {
4804                 sv_dump(sv);
4805             }
4806         }
4807         else if (IN_PERL_RUNTIME)
4808             Perl_croak_no_modify(aTHX);
4809     }
4810 #else
4811     if (SvREADONLY(sv)) {
4812         if (SvIsCOW(sv)) {
4813             const char * const pvx = SvPVX_const(sv);
4814             const STRLEN len = SvCUR(sv);
4815             SvFAKE_off(sv);
4816             SvREADONLY_off(sv);
4817             SvPV_set(sv, NULL);
4818             SvLEN_set(sv, 0);
4819             if (flags & SV_COW_DROP_PV) {
4820                 /* OK, so we don't need to copy our buffer.  */
4821                 SvPOK_off(sv);
4822             } else {
4823                 SvGROW(sv, len + 1);
4824                 Move(pvx,SvPVX(sv),len,char);
4825                 *SvEND(sv) = '\0';
4826             }
4827             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4828         }
4829         else if (IN_PERL_RUNTIME)
4830             Perl_croak_no_modify(aTHX);
4831     }
4832 #endif
4833     if (SvROK(sv))
4834         sv_unref_flags(sv, flags);
4835     else if (SvFAKE(sv) && isGV_with_GP(sv))
4836         sv_unglob(sv, flags);
4837     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4838         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
4839            to sv_unglob. We only need it here, so inline it.  */
4840         const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4841         SV *const temp = newSV_type(new_type);
4842         void *const temp_p = SvANY(sv);
4843
4844         if (new_type == SVt_PVMG) {
4845             SvMAGIC_set(temp, SvMAGIC(sv));
4846             SvMAGIC_set(sv, NULL);
4847             SvSTASH_set(temp, SvSTASH(sv));
4848             SvSTASH_set(sv, NULL);
4849         }
4850         SvCUR_set(temp, SvCUR(sv));
4851         /* Remember that SvPVX is in the head, not the body. */
4852         if (SvLEN(temp)) {
4853             SvLEN_set(temp, SvLEN(sv));
4854             /* This signals "buffer is owned by someone else" in sv_clear,
4855                which is the least effort way to stop it freeing the buffer.
4856             */
4857             SvLEN_set(sv, SvLEN(sv)+1);
4858         } else {
4859             /* Their buffer is already owned by someone else. */
4860             SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4861             SvLEN_set(temp, SvCUR(sv)+1);
4862         }
4863
4864         /* Now swap the rest of the bodies. */
4865
4866         SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4867         SvFLAGS(sv) |= new_type;
4868         SvANY(sv) = SvANY(temp);
4869
4870         SvFLAGS(temp) &= ~(SVTYPEMASK);
4871         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4872         SvANY(temp) = temp_p;
4873
4874         SvREFCNT_dec(temp);
4875     }
4876 }
4877
4878 /*
4879 =for apidoc sv_chop
4880
4881 Efficient removal of characters from the beginning of the string buffer.
4882 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4883 the string buffer.  The C<ptr> becomes the first character of the adjusted
4884 string.  Uses the "OOK hack".
4885
4886 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4887 refer to the same chunk of data.
4888
4889 The unfortunate similarity of this function's name to that of Perl's C<chop>
4890 operator is strictly coincidental.  This function works from the left;
4891 C<chop> works from the right.
4892
4893 =cut
4894 */
4895
4896 void
4897 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4898 {
4899     STRLEN delta;
4900     STRLEN old_delta;
4901     U8 *p;
4902 #ifdef DEBUGGING
4903     const U8 *evacp;
4904     STRLEN evacn;
4905 #endif
4906     STRLEN max_delta;
4907
4908     PERL_ARGS_ASSERT_SV_CHOP;
4909
4910     if (!ptr || !SvPOKp(sv))
4911         return;
4912     delta = ptr - SvPVX_const(sv);
4913     if (!delta) {
4914         /* Nothing to do.  */
4915         return;
4916     }
4917     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4918     if (delta > max_delta)
4919         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4920                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4921     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
4922     SV_CHECK_THINKFIRST(sv);
4923
4924     if (!SvOOK(sv)) {
4925         if (!SvLEN(sv)) { /* make copy of shared string */
4926             const char *pvx = SvPVX_const(sv);
4927             const STRLEN len = SvCUR(sv);
4928             SvGROW(sv, len + 1);
4929             Move(pvx,SvPVX(sv),len,char);
4930             *SvEND(sv) = '\0';
4931         }
4932         SvOOK_on(sv);
4933         old_delta = 0;
4934     } else {
4935         SvOOK_offset(sv, old_delta);
4936     }
4937     SvLEN_set(sv, SvLEN(sv) - delta);
4938     SvCUR_set(sv, SvCUR(sv) - delta);
4939     SvPV_set(sv, SvPVX(sv) + delta);
4940
4941     p = (U8 *)SvPVX_const(sv);
4942
4943 #ifdef DEBUGGING
4944     /* how many bytes were evacuated?  we will fill them with sentinel
4945        bytes, except for the part holding the new offset of course. */
4946     evacn = delta;
4947     if (old_delta)
4948         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
4949     assert(evacn);
4950     assert(evacn <= delta + old_delta);
4951     evacp = p - evacn;
4952 #endif
4953
4954     delta += old_delta;
4955     assert(delta);
4956     if (delta < 0x100) {
4957         *--p = (U8) delta;
4958     } else {
4959         *--p = 0;
4960         p -= sizeof(STRLEN);
4961         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4962     }
4963
4964 #ifdef DEBUGGING
4965     /* Fill the preceding buffer with sentinals to verify that no-one is
4966        using it.  */
4967     while (p > evacp) {
4968         --p;
4969         *p = (U8)PTR2UV(p);
4970     }
4971 #endif
4972 }
4973
4974 /*
4975 =for apidoc sv_catpvn
4976
4977 Concatenates the string onto the end of the string which is in the SV.  The
4978 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4979 status set, then the bytes appended should be valid UTF-8.
4980 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4981
4982 =for apidoc sv_catpvn_flags
4983
4984 Concatenates the string onto the end of the string which is in the SV.  The
4985 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4986 status set, then the bytes appended should be valid UTF-8.
4987 If C<flags> has the C<SV_SMAGIC> bit set, will
4988 C<mg_set> on C<dsv> afterwards if appropriate.
4989 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4990 in terms of this function.
4991
4992 =cut
4993 */
4994
4995 void
4996 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4997 {
4998     dVAR;
4999     STRLEN dlen;
5000     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5001
5002     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5003     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5004
5005     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5006       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5007          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5008          dlen = SvCUR(dsv);
5009       }
5010       else SvGROW(dsv, dlen + slen + 1);
5011       if (sstr == dstr)
5012         sstr = SvPVX_const(dsv);
5013       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5014       SvCUR_set(dsv, SvCUR(dsv) + slen);
5015     }
5016     else {
5017         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5018         const char * const send = sstr + slen;
5019         U8 *d;
5020
5021         /* Something this code does not account for, which I think is
5022            impossible; it would require the same pv to be treated as
5023            bytes *and* utf8, which would indicate a bug elsewhere. */
5024         assert(sstr != dstr);
5025
5026         SvGROW(dsv, dlen + slen * 2 + 1);
5027         d = (U8 *)SvPVX(dsv) + dlen;
5028
5029         while (sstr < send) {
5030             const UV uv = NATIVE_TO_ASCII((U8)*sstr++);
5031             if (UNI_IS_INVARIANT(uv))
5032                 *d++ = (U8)UTF_TO_NATIVE(uv);
5033             else {
5034                 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
5035                 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
5036             }
5037         }
5038         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5039     }
5040     *SvEND(dsv) = '\0';
5041     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5042     SvTAINT(dsv);
5043     if (flags & SV_SMAGIC)
5044         SvSETMAGIC(dsv);
5045 }
5046
5047 /*
5048 =for apidoc sv_catsv
5049
5050 Concatenates the string from SV C<ssv> onto the end of the string in
5051 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
5052 not 'set' magic.  See C<sv_catsv_mg>.
5053
5054 =for apidoc sv_catsv_flags
5055
5056 Concatenates the string from SV C<ssv> onto the end of the string in
5057 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
5058 bit set, will C<mg_get> on the C<ssv>, if appropriate, before
5059 reading it.  If the C<flags> contain C<SV_SMAGIC>, C<mg_set> will be
5060 called on the modified SV afterward, if appropriate.  C<sv_catsv>
5061 and C<sv_catsv_nomg> are implemented in terms of this function.
5062
5063 =cut */
5064
5065 void
5066 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
5067 {
5068     dVAR;
5069
5070     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5071
5072    if (ssv) {
5073         STRLEN slen;
5074         const char *spv = SvPV_flags_const(ssv, slen, flags);
5075         if (spv) {
5076             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5077                 mg_get(dsv);
5078             sv_catpvn_flags(dsv, spv, slen,
5079                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5080         }
5081     }
5082     if (flags & SV_SMAGIC)
5083         SvSETMAGIC(dsv);
5084 }
5085
5086 /*
5087 =for apidoc sv_catpv
5088
5089 Concatenates the string onto the end of the string which is in the SV.
5090 If the SV has the UTF-8 status set, then the bytes appended should be
5091 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
5092
5093 =cut */
5094
5095 void
5096 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
5097 {
5098     dVAR;
5099     register STRLEN len;
5100     STRLEN tlen;
5101     char *junk;
5102
5103     PERL_ARGS_ASSERT_SV_CATPV;
5104
5105     if (!ptr)
5106         return;
5107     junk = SvPV_force(sv, tlen);
5108     len = strlen(ptr);
5109     SvGROW(sv, tlen + len + 1);
5110     if (ptr == junk)
5111         ptr = SvPVX_const(sv);
5112     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5113     SvCUR_set(sv, SvCUR(sv) + len);
5114     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5115     SvTAINT(sv);
5116 }
5117
5118 /*
5119 =for apidoc sv_catpv_flags
5120
5121 Concatenates the string onto the end of the string which is in the SV.
5122 If the SV has the UTF-8 status set, then the bytes appended should
5123 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5124 on the modified SV if appropriate.
5125
5126 =cut
5127 */
5128
5129 void
5130 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5131 {
5132     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5133     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5134 }
5135
5136 /*
5137 =for apidoc sv_catpv_mg
5138
5139 Like C<sv_catpv>, but also handles 'set' magic.
5140
5141 =cut
5142 */
5143
5144 void
5145 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
5146 {
5147     PERL_ARGS_ASSERT_SV_CATPV_MG;
5148
5149     sv_catpv(sv,ptr);
5150     SvSETMAGIC(sv);
5151 }
5152
5153 /*
5154 =for apidoc newSV
5155
5156 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5157 bytes of preallocated string space the SV should have.  An extra byte for a
5158 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
5159 space is allocated.)  The reference count for the new SV is set to 1.
5160
5161 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5162 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5163 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5164 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5165 modules supporting older perls.
5166
5167 =cut
5168 */
5169
5170 SV *
5171 Perl_newSV(pTHX_ const STRLEN len)
5172 {
5173     dVAR;
5174     register SV *sv;
5175
5176     new_SV(sv);
5177     if (len) {
5178         sv_upgrade(sv, SVt_PV);
5179         SvGROW(sv, len + 1);
5180     }
5181     return sv;
5182 }
5183 /*
5184 =for apidoc sv_magicext
5185
5186 Adds magic to an SV, upgrading it if necessary.  Applies the
5187 supplied vtable and returns a pointer to the magic added.
5188
5189 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5190 In particular, you can add magic to SvREADONLY SVs, and add more than
5191 one instance of the same 'how'.
5192
5193 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5194 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5195 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5196 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5197
5198 (This is now used as a subroutine by C<sv_magic>.)
5199
5200 =cut
5201 */
5202 MAGIC *
5203 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5204                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5205 {
5206     dVAR;
5207     MAGIC* mg;
5208
5209     PERL_ARGS_ASSERT_SV_MAGICEXT;
5210
5211     SvUPGRADE(sv, SVt_PVMG);
5212     Newxz(mg, 1, MAGIC);
5213     mg->mg_moremagic = SvMAGIC(sv);
5214     SvMAGIC_set(sv, mg);
5215
5216     /* Sometimes a magic contains a reference loop, where the sv and
5217        object refer to each other.  To prevent a reference loop that
5218        would prevent such objects being freed, we look for such loops
5219        and if we find one we avoid incrementing the object refcount.
5220
5221        Note we cannot do this to avoid self-tie loops as intervening RV must
5222        have its REFCNT incremented to keep it in existence.
5223
5224     */
5225     if (!obj || obj == sv ||
5226         how == PERL_MAGIC_arylen ||
5227         how == PERL_MAGIC_symtab ||
5228         (SvTYPE(obj) == SVt_PVGV &&
5229             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5230              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5231              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5232     {
5233         mg->mg_obj = obj;
5234     }
5235     else {
5236         mg->mg_obj = SvREFCNT_inc_simple(obj);
5237         mg->mg_flags |= MGf_REFCOUNTED;
5238     }
5239
5240     /* Normal self-ties simply pass a null object, and instead of
5241        using mg_obj directly, use the SvTIED_obj macro to produce a
5242        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5243        with an RV obj pointing to the glob containing the PVIO.  In
5244        this case, to avoid a reference loop, we need to weaken the
5245        reference.
5246     */
5247
5248     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5249         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5250     {
5251       sv_rvweaken(obj);
5252     }
5253
5254     mg->mg_type = how;
5255     mg->mg_len = namlen;
5256     if (name) {
5257         if (namlen > 0)
5258             mg->mg_ptr = savepvn(name, namlen);
5259         else if (namlen == HEf_SVKEY) {
5260             /* Yes, this is casting away const. This is only for the case of
5261                HEf_SVKEY. I think we need to document this aberation of the
5262                constness of the API, rather than making name non-const, as
5263                that change propagating outwards a long way.  */
5264             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5265         } else
5266             mg->mg_ptr = (char *) name;
5267     }
5268     mg->mg_virtual = (MGVTBL *) vtable;
5269
5270     mg_magical(sv);
5271     if (SvGMAGICAL(sv))
5272         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5273     return mg;
5274 }
5275
5276 /*
5277 =for apidoc sv_magic
5278
5279 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5280 necessary, then adds a new magic item of type C<how> to the head of the
5281 magic list.
5282
5283 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5284 handling of the C<name> and C<namlen> arguments.
5285
5286 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5287 to add more than one instance of the same 'how'.
5288
5289 =cut
5290 */
5291
5292 void
5293 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5294              const char *const name, const I32 namlen)
5295 {
5296     dVAR;
5297     const MGVTBL *vtable;
5298     MAGIC* mg;
5299     unsigned int flags;
5300     unsigned int vtable_index;
5301
5302     PERL_ARGS_ASSERT_SV_MAGIC;
5303
5304     if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
5305         || ((flags = PL_magic_data[how]),
5306             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5307             > magic_vtable_max))
5308         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5309
5310     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5311        Useful for attaching extension internal data to perl vars.
5312        Note that multiple extensions may clash if magical scalars
5313        etc holding private data from one are passed to another. */
5314
5315     vtable = (vtable_index == magic_vtable_max)
5316         ? NULL : PL_magic_vtables + vtable_index;
5317
5318 #ifdef PERL_OLD_COPY_ON_WRITE
5319     if (SvIsCOW(sv))
5320         sv_force_normal_flags(sv, 0);
5321 #endif
5322     if (SvREADONLY(sv)) {
5323         if (
5324             /* its okay to attach magic to shared strings */
5325             !SvIsCOW(sv)
5326
5327             && IN_PERL_RUNTIME
5328             && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5329            )
5330         {
5331             Perl_croak_no_modify(aTHX);
5332         }
5333     }
5334     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5335         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5336             /* sv_magic() refuses to add a magic of the same 'how' as an
5337                existing one
5338              */
5339             if (how == PERL_MAGIC_taint) {
5340                 mg->mg_len |= 1;
5341                 /* Any scalar which already had taint magic on which someone
5342                    (erroneously?) did SvIOK_on() or similar will now be
5343                    incorrectly sporting public "OK" flags.  */
5344                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5345             }
5346             return;
5347         }
5348     }
5349
5350     /* Rest of work is done else where */
5351     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5352
5353     switch (how) {
5354     case PERL_MAGIC_taint:
5355         mg->mg_len = 1;
5356         break;
5357     case PERL_MAGIC_ext:
5358     case PERL_MAGIC_dbfile:
5359         SvRMAGICAL_on(sv);
5360         break;
5361     }
5362 }
5363
5364 static int
5365 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5366 {
5367     MAGIC* mg;
5368     MAGIC** mgp;
5369
5370     assert(flags <= 1);
5371
5372     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5373         return 0;
5374     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5375     for (mg = *mgp; mg; mg = *mgp) {
5376         const MGVTBL* const virt = mg->mg_virtual;
5377         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5378             *mgp = mg->mg_moremagic;
5379             if (virt && virt->svt_free)
5380                 virt->svt_free(aTHX_ sv, mg);
5381             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5382                 if (mg->mg_len > 0)
5383                     Safefree(mg->mg_ptr);
5384                 else if (mg->mg_len == HEf_SVKEY)
5385                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5386                 else if (mg->mg_type == PERL_MAGIC_utf8)
5387                     Safefree(mg->mg_ptr);
5388             }
5389             if (mg->mg_flags & MGf_REFCOUNTED)
5390                 SvREFCNT_dec(mg->mg_obj);
5391             Safefree(mg);
5392         }
5393         else
5394             mgp = &mg->mg_moremagic;
5395     }
5396     if (SvMAGIC(sv)) {
5397         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5398             mg_magical(sv);     /*    else fix the flags now */
5399     }
5400     else {
5401         SvMAGICAL_off(sv);
5402         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5403     }
5404     return 0;
5405 }
5406
5407 /*
5408 =for apidoc sv_unmagic
5409
5410 Removes all magic of type C<type> from an SV.
5411
5412 =cut
5413 */
5414
5415 int
5416 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5417 {
5418     PERL_ARGS_ASSERT_SV_UNMAGIC;
5419     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5420 }
5421
5422 /*
5423 =for apidoc sv_unmagicext
5424
5425 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5426
5427 =cut
5428 */
5429
5430 int
5431 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5432 {
5433     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5434     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5435 }
5436
5437 /*
5438 =for apidoc sv_rvweaken
5439
5440 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5441 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5442 push a back-reference to this RV onto the array of backreferences
5443 associated with that magic.  If the RV is magical, set magic will be
5444 called after the RV is cleared.
5445
5446 =cut
5447 */
5448
5449 SV *
5450 Perl_sv_rvweaken(pTHX_ SV *const sv)
5451 {
5452     SV *tsv;
5453
5454     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5455
5456     if (!SvOK(sv))  /* let undefs pass */
5457         return sv;
5458     if (!SvROK(sv))
5459         Perl_croak(aTHX_ "Can't weaken a nonreference");
5460     else if (SvWEAKREF(sv)) {
5461         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5462         return sv;
5463     }
5464     else if (SvREADONLY(sv)) croak_no_modify();
5465     tsv = SvRV(sv);
5466     Perl_sv_add_backref(aTHX_ tsv, sv);
5467     SvWEAKREF_on(sv);
5468     SvREFCNT_dec(tsv);
5469     return sv;
5470 }
5471
5472 /* Give tsv backref magic if it hasn't already got it, then push a
5473  * back-reference to sv onto the array associated with the backref magic.
5474  *
5475  * As an optimisation, if there's only one backref and it's not an AV,
5476  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5477  * allocate an AV. (Whether the slot holds an AV tells us whether this is
5478  * active.)
5479  */
5480
5481 /* A discussion about the backreferences array and its refcount:
5482  *
5483  * The AV holding the backreferences is pointed to either as the mg_obj of
5484  * PERL_MAGIC_backref, or in the specific case of a HV, from the
5485  * xhv_backreferences field. The array is created with a refcount
5486  * of 2. This means that if during global destruction the array gets
5487  * picked on before its parent to have its refcount decremented by the
5488  * random zapper, it won't actually be freed, meaning it's still there for
5489  * when its parent gets freed.
5490  *
5491  * When the parent SV is freed, the extra ref is killed by
5492  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
5493  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5494  *
5495  * When a single backref SV is stored directly, it is not reference
5496  * counted.
5497  */
5498
5499 void
5500 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5501 {
5502     dVAR;
5503     SV **svp;
5504     AV *av = NULL;
5505     MAGIC *mg = NULL;
5506
5507     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5508
5509     /* find slot to store array or singleton backref */
5510
5511     if (SvTYPE(tsv) == SVt_PVHV) {
5512         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5513     } else {
5514         if (! ((mg =
5515             (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5516         {
5517             sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5518             mg = mg_find(tsv, PERL_MAGIC_backref);
5519         }
5520         svp = &(mg->mg_obj);
5521     }
5522
5523     /* create or retrieve the array */
5524
5525     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
5526         || (*svp && SvTYPE(*svp) != SVt_PVAV)
5527     ) {
5528         /* create array */
5529         av = newAV();
5530         AvREAL_off(av);
5531         SvREFCNT_inc_simple_void(av);
5532         /* av now has a refcnt of 2; see discussion above */
5533         if (*svp) {
5534             /* move single existing backref to the array */
5535             av_extend(av, 1);
5536             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5537         }
5538         *svp = (SV*)av;
5539         if (mg)
5540             mg->mg_flags |= MGf_REFCOUNTED;
5541     }
5542     else
5543         av = MUTABLE_AV(*svp);
5544
5545     if (!av) {
5546         /* optimisation: store single backref directly in HvAUX or mg_obj */
5547         *svp = sv;
5548         return;
5549     }
5550     /* push new backref */
5551     assert(SvTYPE(av) == SVt_PVAV);
5552     if (AvFILLp(av) >= AvMAX(av)) {
5553         av_extend(av, AvFILLp(av)+1);
5554     }
5555     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5556 }
5557
5558 /* delete a back-reference to ourselves from the backref magic associated
5559  * with the SV we point to.
5560  */
5561
5562 void
5563 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5564 {
5565     dVAR;
5566     SV **svp = NULL;
5567
5568     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5569
5570     if (SvTYPE(tsv) == SVt_PVHV) {
5571         if (SvOOK(tsv))
5572             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5573     }
5574     else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
5575         /* It's possible for the the last (strong) reference to tsv to have
5576            become freed *before* the last thing holding a weak reference.
5577            If both survive longer than the backreferences array, then when
5578            the referent's reference count drops to 0 and it is freed, it's
5579            not able to chase the backreferences, so they aren't NULLed.
5580
5581            For example, a CV holds a weak reference to its stash. If both the
5582            CV and the stash survive longer than the backreferences array,
5583            and the CV gets picked for the SvBREAK() treatment first,
5584            *and* it turns out that the stash is only being kept alive because
5585            of an our variable in the pad of the CV, then midway during CV
5586            destruction the stash gets freed, but CvSTASH() isn't set to NULL.
5587            It ends up pointing to the freed HV. Hence it's chased in here, and
5588            if this block wasn't here, it would hit the !svp panic just below.
5589
5590            I don't believe that "better" destruction ordering is going to help
5591            here - during global destruction there's always going to be the
5592            chance that something goes out of order. We've tried to make it
5593            foolproof before, and it only resulted in evolutionary pressure on
5594            fools. Which made us look foolish for our hubris. :-(
5595         */
5596         return;
5597     }
5598     else {
5599         MAGIC *const mg
5600             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5601         svp =  mg ? &(mg->mg_obj) : NULL;
5602     }
5603
5604     if (!svp)
5605         Perl_croak(aTHX_ "panic: del_backref, svp=0");
5606     if (!*svp) {
5607         /* It's possible that sv is being freed recursively part way through the
5608            freeing of tsv. If this happens, the backreferences array of tsv has
5609            already been freed, and so svp will be NULL. If this is the case,
5610            we should not panic. Instead, nothing needs doing, so return.  */
5611         if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
5612             return;
5613         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
5614                    *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
5615     }
5616
5617     if (SvTYPE(*svp) == SVt_PVAV) {
5618 #ifdef DEBUGGING
5619         int count = 1;
5620 #endif
5621         AV * const av = (AV*)*svp;
5622         SSize_t fill;
5623         assert(!SvIS_FREED(av));
5624         fill = AvFILLp(av);
5625         assert(fill > -1);
5626         svp = AvARRAY(av);
5627         /* for an SV with N weak references to it, if all those
5628          * weak refs are deleted, then sv_del_backref will be called
5629          * N times and O(N^2) compares will be done within the backref
5630          * array. To ameliorate this potential slowness, we:
5631          * 1) make sure this code is as tight as possible;
5632          * 2) when looking for SV, look for it at both the head and tail of the
5633          *    array first before searching the rest, since some create/destroy
5634          *    patterns will cause the backrefs to be freed in order.
5635          */
5636         if (*svp == sv) {
5637             AvARRAY(av)++;
5638             AvMAX(av)--;
5639         }
5640         else {
5641             SV **p = &svp[fill];
5642             SV *const topsv = *p;
5643             if (topsv != sv) {
5644 #ifdef DEBUGGING
5645                 count = 0;
5646 #endif
5647                 while (--p > svp) {
5648                     if (*p == sv) {
5649                         /* We weren't the last entry.
5650                            An unordered list has this property that you
5651                            can take the last element off the end to fill
5652                            the hole, and it's still an unordered list :-)
5653                         */
5654                         *p = topsv;
5655 #ifdef DEBUGGING
5656                         count++;
5657 #else
5658                         break; /* should only be one */
5659 #endif
5660                     }
5661                 }
5662             }
5663         }
5664         assert(count ==1);
5665         AvFILLp(av) = fill-1;
5666     }
5667     else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
5668         /* freed AV; skip */
5669     }
5670     else {
5671         /* optimisation: only a single backref, stored directly */
5672         if (*svp != sv)
5673             Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
5674         *svp = NULL;
5675     }
5676
5677 }
5678
5679 void
5680 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5681 {
5682     SV **svp;
5683     SV **last;
5684     bool is_array;
5685
5686     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5687
5688     if (!av)
5689         return;
5690
5691     /* after multiple passes through Perl_sv_clean_all() for a thinngy
5692      * that has badly leaked, the backref array may have gotten freed,
5693      * since we only protect it against 1 round of cleanup */
5694     if (SvIS_FREED(av)) {
5695         if (PL_in_clean_all) /* All is fair */
5696             return;
5697         Perl_croak(aTHX_
5698                    "panic: magic_killbackrefs (freed backref AV/SV)");
5699     }
5700
5701
5702     is_array = (SvTYPE(av) == SVt_PVAV);
5703     if (is_array) {
5704         assert(!SvIS_FREED(av));
5705         svp = AvARRAY(av);
5706         if (svp)
5707             last = svp + AvFILLp(av);
5708     }
5709     else {
5710         /* optimisation: only a single backref, stored directly */
5711         svp = (SV**)&av;
5712         last = svp;
5713     }
5714
5715     if (svp) {
5716         while (svp <= last) {
5717             if (*svp) {
5718                 SV *const referrer = *svp;
5719                 if (SvWEAKREF(referrer)) {
5720                     /* XXX Should we check that it hasn't changed? */
5721                     assert(SvROK(referrer));
5722                     SvRV_set(referrer, 0);
5723                     SvOK_off(referrer);
5724                     SvWEAKREF_off(referrer);
5725                     SvSETMAGIC(referrer);
5726                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5727                            SvTYPE(referrer) == SVt_PVLV) {
5728                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5729                     /* You lookin' at me?  */
5730                     assert(GvSTASH(referrer));
5731                     assert(GvSTASH(referrer) == (const HV *)sv);
5732                     GvSTASH(referrer) = 0;
5733                 } else if (SvTYPE(referrer) == SVt_PVCV ||
5734                            SvTYPE(referrer) == SVt_PVFM) {
5735                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5736                         /* You lookin' at me?  */
5737                         assert(CvSTASH(referrer));
5738                         assert(CvSTASH(referrer) == (const HV *)sv);
5739                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5740                     }
5741                     else {
5742                         assert(SvTYPE(sv) == SVt_PVGV);
5743                         /* You lookin' at me?  */
5744                         assert(CvGV(referrer));
5745                         assert(CvGV(referrer) == (const GV *)sv);
5746                         anonymise_cv_maybe(MUTABLE_GV(sv),
5747                                                 MUTABLE_CV(referrer));
5748                     }
5749
5750                 } else {
5751                     Perl_croak(aTHX_
5752                                "panic: magic_killbackrefs (flags=%"UVxf")",
5753                                (UV)SvFLAGS(referrer));
5754                 }
5755
5756                 if (is_array)
5757                     *svp = NULL;
5758             }
5759             svp++;
5760         }
5761     }
5762     if (is_array) {
5763         AvFILLp(av) = -1;
5764         SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5765     }
5766     return;
5767 }
5768
5769 /*
5770 =for apidoc sv_insert
5771
5772 Inserts a string at the specified offset/length within the SV.  Similar to
5773 the Perl substr() function.  Handles get magic.
5774
5775 =for apidoc sv_insert_flags
5776
5777 Same as C<sv_insert>, but the extra C<flags> are passed to the
5778 C<SvPV_force_flags> that applies to C<bigstr>.
5779
5780 =cut
5781 */
5782
5783 void
5784 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5785 {
5786     dVAR;
5787     register char *big;
5788     register char *mid;
5789     register char *midend;
5790     register char *bigend;
5791     register SSize_t i;         /* better be sizeof(STRLEN) or bad things happen */
5792     STRLEN curlen;
5793
5794     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5795
5796     if (!bigstr)
5797         Perl_croak(aTHX_ "Can't modify nonexistent substring");
5798     SvPV_force_flags(bigstr, curlen, flags);
5799     (void)SvPOK_only_UTF8(bigstr);
5800     if (offset + len > curlen) {
5801         SvGROW(bigstr, offset+len+1);
5802         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5803         SvCUR_set(bigstr, offset+len);
5804     }
5805
5806     SvTAINT(bigstr);
5807     i = littlelen - len;
5808     if (i > 0) {                        /* string might grow */
5809         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5810         mid = big + offset + len;
5811         midend = bigend = big + SvCUR(bigstr);
5812         bigend += i;
5813         *bigend = '\0';
5814         while (midend > mid)            /* shove everything down */
5815             *--bigend = *--midend;
5816         Move(little,big+offset,littlelen,char);
5817         SvCUR_set(bigstr, SvCUR(bigstr) + i);
5818         SvSETMAGIC(bigstr);
5819         return;
5820     }
5821     else if (i == 0) {
5822         Move(little,SvPVX(bigstr)+offset,len,char);
5823         SvSETMAGIC(bigstr);
5824         return;
5825     }
5826
5827     big = SvPVX(bigstr);
5828     mid = big + offset;
5829     midend = mid + len;
5830     bigend = big + SvCUR(bigstr);
5831
5832     if (midend > bigend)
5833         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
5834                    midend, bigend);
5835
5836     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5837         if (littlelen) {
5838             Move(little, mid, littlelen,char);
5839             mid += littlelen;
5840         }
5841         i = bigend - midend;
5842         if (i > 0) {
5843             Move(midend, mid, i,char);
5844             mid += i;
5845         }
5846         *mid = '\0';
5847         SvCUR_set(bigstr, mid - big);
5848     }
5849     else if ((i = mid - big)) { /* faster from front */
5850         midend -= littlelen;
5851         mid = midend;
5852         Move(big, midend - i, i, char);
5853         sv_chop(bigstr,midend-i);
5854         if (littlelen)
5855             Move(little, mid, littlelen,char);
5856     }
5857     else if (littlelen) {
5858         midend -= littlelen;
5859         sv_chop(bigstr,midend);
5860         Move(little,midend,littlelen,char);
5861     }
5862     else {
5863         sv_chop(bigstr,midend);
5864     }
5865     SvSETMAGIC(bigstr);
5866 }
5867
5868 /*
5869 =for apidoc sv_replace
5870
5871 Make the first argument a copy of the second, then delete the original.
5872 The target SV physically takes over ownership of the body of the source SV
5873 and inherits its flags; however, the target keeps any magic it owns,
5874 and any magic in the source is discarded.
5875 Note that this is a rather specialist SV copying operation; most of the
5876 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5877
5878 =cut
5879 */
5880
5881 void
5882 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5883 {
5884     dVAR;
5885     const U32 refcnt = SvREFCNT(sv);
5886
5887     PERL_ARGS_ASSERT_SV_REPLACE;
5888
5889     SV_CHECK_THINKFIRST_COW_DROP(sv);
5890     if (SvREFCNT(nsv) != 1) {
5891         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5892                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5893     }
5894     if (SvMAGICAL(sv)) {
5895         if (SvMAGICAL(nsv))
5896             mg_free(nsv);
5897         else
5898             sv_upgrade(nsv, SVt_PVMG);
5899         SvMAGIC_set(nsv, SvMAGIC(sv));
5900         SvFLAGS(nsv) |= SvMAGICAL(sv);
5901         SvMAGICAL_off(sv);
5902         SvMAGIC_set(sv, NULL);
5903     }
5904     SvREFCNT(sv) = 0;
5905     sv_clear(sv);
5906     assert(!SvREFCNT(sv));
5907 #ifdef DEBUG_LEAKING_SCALARS
5908     sv->sv_flags  = nsv->sv_flags;
5909     sv->sv_any    = nsv->sv_any;
5910     sv->sv_refcnt = nsv->sv_refcnt;
5911     sv->sv_u      = nsv->sv_u;
5912 #else
5913     StructCopy(nsv,sv,SV);
5914 #endif
5915     if(SvTYPE(sv) == SVt_IV) {
5916         SvANY(sv)
5917             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5918     }
5919
5920
5921 #ifdef PERL_OLD_COPY_ON_WRITE
5922     if (SvIsCOW_normal(nsv)) {
5923         /* We need to follow the pointers around the loop to make the
5924            previous SV point to sv, rather than nsv.  */
5925         SV *next;
5926         SV *current = nsv;
5927         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5928             assert(next);
5929             current = next;
5930             assert(SvPVX_const(current) == SvPVX_const(nsv));
5931         }
5932         /* Make the SV before us point to the SV after us.  */
5933         if (DEBUG_C_TEST) {
5934             PerlIO_printf(Perl_debug_log, "previous is\n");
5935             sv_dump(current);
5936             PerlIO_printf(Perl_debug_log,
5937                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5938                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5939         }
5940         SV_COW_NEXT_SV_SET(current, sv);
5941     }
5942 #endif
5943     SvREFCNT(sv) = refcnt;
5944     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5945     SvREFCNT(nsv) = 0;
5946     del_SV(nsv);
5947 }
5948
5949 /* We're about to free a GV which has a CV that refers back to us.
5950  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5951  * field) */
5952
5953 STATIC void
5954 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5955 {
5956     SV *gvname;
5957     GV *anongv;
5958
5959     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5960
5961     /* be assertive! */
5962     assert(SvREFCNT(gv) == 0);
5963     assert(isGV(gv) && isGV_with_GP(gv));
5964     assert(GvGP(gv));
5965     assert(!CvANON(cv));
5966     assert(CvGV(cv) == gv);
5967
5968     /* will the CV shortly be freed by gp_free() ? */
5969     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
5970         SvANY(cv)->xcv_gv = NULL;
5971         return;
5972     }
5973
5974     /* if not, anonymise: */
5975     gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
5976                     ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
5977                     : newSVpvn_flags( "__ANON__", 8, 0 );
5978     sv_catpvs(gvname, "::__ANON__");
5979     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
5980     SvREFCNT_dec(gvname);
5981
5982     CvANON_on(cv);
5983     CvCVGV_RC_on(cv);
5984     SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
5985 }
5986
5987
5988 /*
5989 =for apidoc sv_clear
5990
5991 Clear an SV: call any destructors, free up any memory used by the body,
5992 and free the body itself.  The SV's head is I<not> freed, although
5993 its type is set to all 1's so that it won't inadvertently be assumed
5994 to be live during global destruction etc.
5995 This function should only be called when REFCNT is zero.  Most of the time
5996 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5997 instead.
5998
5999 =cut
6000 */
6001
6002 void
6003 Perl_sv_clear(pTHX_ SV *const orig_sv)
6004 {
6005     dVAR;
6006     HV *stash;
6007     U32 type;
6008     const struct body_details *sv_type_details;
6009     SV* iter_sv = NULL;
6010     SV* next_sv = NULL;
6011     register SV *sv = orig_sv;
6012     STRLEN hash_index;
6013
6014     PERL_ARGS_ASSERT_SV_CLEAR;
6015
6016     /* within this loop, sv is the SV currently being freed, and
6017      * iter_sv is the most recent AV or whatever that's being iterated
6018      * over to provide more SVs */
6019
6020     while (sv) {
6021
6022         type = SvTYPE(sv);
6023
6024         assert(SvREFCNT(sv) == 0);
6025         assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6026
6027         if (type <= SVt_IV) {
6028             /* See the comment in sv.h about the collusion between this
6029              * early return and the overloading of the NULL slots in the
6030              * size table.  */
6031             if (SvROK(sv))
6032                 goto free_rv;
6033             SvFLAGS(sv) &= SVf_BREAK;
6034             SvFLAGS(sv) |= SVTYPEMASK;
6035             goto free_head;
6036         }
6037
6038         assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6039
6040         if (type >= SVt_PVMG) {
6041             if (SvOBJECT(sv)) {
6042                 if (!curse(sv, 1)) goto get_next_sv;
6043                 type = SvTYPE(sv); /* destructor may have changed it */
6044             }
6045             /* Free back-references before magic, in case the magic calls
6046              * Perl code that has weak references to sv. */
6047             if (type == SVt_PVHV) {
6048                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6049                 if (SvMAGIC(sv))
6050                     mg_free(sv);
6051             }
6052             else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6053                 SvREFCNT_dec(SvOURSTASH(sv));
6054             } else if (SvMAGIC(sv)) {
6055                 /* Free back-references before other types of magic. */
6056                 sv_unmagic(sv, PERL_MAGIC_backref);
6057                 mg_free(sv);
6058             }
6059             if (type == SVt_PVMG && SvPAD_TYPED(sv))
6060                 SvREFCNT_dec(SvSTASH(sv));
6061         }
6062         switch (type) {
6063             /* case SVt_BIND: */
6064         case SVt_PVIO:
6065             if (IoIFP(sv) &&
6066                 IoIFP(sv) != PerlIO_stdin() &&
6067                 IoIFP(sv) != PerlIO_stdout() &&
6068                 IoIFP(sv) != PerlIO_stderr() &&
6069                 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6070             {
6071                 io_close(MUTABLE_IO(sv), FALSE);
6072             }
6073             if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6074                 PerlDir_close(IoDIRP(sv));
6075             IoDIRP(sv) = (DIR*)NULL;
6076             Safefree(IoTOP_NAME(sv));
6077             Safefree(IoFMT_NAME(sv));
6078             Safefree(IoBOTTOM_NAME(sv));
6079             if ((const GV *)sv == PL_statgv)
6080                 PL_statgv = NULL;
6081             goto freescalar;
6082         case SVt_REGEXP:
6083             /* FIXME for plugins */
6084             pregfree2((REGEXP*) sv);
6085             goto freescalar;
6086         case SVt_PVCV:
6087         case SVt_PVFM:
6088             cv_undef(MUTABLE_CV(sv));
6089             /* If we're in a stash, we don't own a reference to it.
6090              * However it does have a back reference to us, which needs to
6091              * be cleared.  */
6092             if ((stash = CvSTASH(sv)))
6093                 sv_del_backref(MUTABLE_SV(stash), sv);
6094             goto freescalar;
6095         case SVt_PVHV:
6096             if (PL_last_swash_hv == (const HV *)sv) {
6097                 PL_last_swash_hv = NULL;
6098             }
6099             if (HvTOTALKEYS((HV*)sv) > 0) {
6100                 const char *name;
6101                 /* this statement should match the one at the beginning of
6102                  * hv_undef_flags() */
6103                 if (   PL_phase != PERL_PHASE_DESTRUCT
6104                     && (name = HvNAME((HV*)sv)))
6105                 {
6106                     if (PL_stashcache)
6107                         (void)hv_delete(PL_stashcache, name,
6108                             HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD);
6109                     hv_name_set((HV*)sv, NULL, 0, 0);
6110                 }
6111
6112                 /* save old iter_sv in unused SvSTASH field */
6113                 assert(!SvOBJECT(sv));
6114                 SvSTASH(sv) = (HV*)iter_sv;
6115                 iter_sv = sv;
6116
6117                 /* XXX ideally we should save the old value of hash_index
6118                  * too, but I can't think of any place to hide it. The
6119                  * effect of not saving it is that for freeing hashes of
6120                  * hashes, we become quadratic in scanning the HvARRAY of
6121                  * the top hash looking for new entries to free; but
6122                  * hopefully this will be dwarfed by the freeing of all
6123                  * the nested hashes. */
6124                 hash_index = 0;
6125                 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6126                 goto get_next_sv; /* process this new sv */
6127             }
6128             /* free empty hash */
6129             Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6130             assert(!HvARRAY((HV*)sv));
6131             break;
6132         case SVt_PVAV:
6133             {
6134                 AV* av = MUTABLE_AV(sv);
6135                 if (PL_comppad == av) {
6136                     PL_comppad = NULL;
6137                     PL_curpad = NULL;
6138                 }
6139                 if (AvREAL(av) && AvFILLp(av) > -1) {
6140                     next_sv = AvARRAY(av)[AvFILLp(av)--];
6141                     /* save old iter_sv in top-most slot of AV,
6142                      * and pray that it doesn't get wiped in the meantime */
6143                     AvARRAY(av)[AvMAX(av)] = iter_sv;
6144                     iter_sv = sv;
6145                     goto get_next_sv; /* process this new sv */
6146                 }
6147                 Safefree(AvALLOC(av));
6148             }
6149
6150             break;
6151         case SVt_PVLV:
6152             if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6153                 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6154                 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6155                 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6156             }
6157             else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
6158                 SvREFCNT_dec(LvTARG(sv));
6159         case SVt_PVGV:
6160             if (isGV_with_GP(sv)) {
6161                 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6162                    && HvENAME_get(stash))
6163                     mro_method_changed_in(stash);
6164                 gp_free(MUTABLE_GV(sv));
6165                 if (GvNAME_HEK(sv))
6166                     unshare_hek(GvNAME_HEK(sv));
6167                 /* If we're in a stash, we don't own a reference to it.
6168                  * However it does have a back reference to us, which
6169                  * needs to be cleared.  */
6170                 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6171                         sv_del_backref(MUTABLE_SV(stash), sv);
6172             }
6173             /* FIXME. There are probably more unreferenced pointers to SVs
6174              * in the interpreter struct that we should check and tidy in
6175              * a similar fashion to this:  */
6176             /* See also S_sv_unglob, which does the same thing. */
6177             if ((const GV *)sv == PL_last_in_gv)
6178                 PL_last_in_gv = NULL;
6179             else if ((const GV *)sv == PL_statgv)
6180                 PL_statgv = NULL;
6181         case SVt_PVMG:
6182         case SVt_PVNV:
6183         case SVt_PVIV:
6184         case SVt_PV:
6185           freescalar:
6186             /* Don't bother with SvOOK_off(sv); as we're only going to
6187              * free it.  */
6188             if (SvOOK(sv)) {
6189                 STRLEN offset;
6190                 SvOOK_offset(sv, offset);
6191                 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6192                 /* Don't even bother with turning off the OOK flag.  */
6193             }
6194             if (SvROK(sv)) {
6195             free_rv:
6196                 {
6197                     SV * const target = SvRV(sv);
6198                     if (SvWEAKREF(sv))
6199                         sv_del_backref(target, sv);
6200                     else
6201                         next_sv = target;
6202                 }
6203             }
6204 #ifdef PERL_OLD_COPY_ON_WRITE
6205             else if (SvPVX_const(sv)
6206                      && !(SvTYPE(sv) == SVt_PVIO
6207                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6208             {
6209                 if (SvIsCOW(sv)) {
6210                     if (DEBUG_C_TEST) {
6211                         PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6212                         sv_dump(sv);
6213                     }
6214                     if (SvLEN(sv)) {
6215                         sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6216                     } else {
6217                         unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6218                     }
6219
6220                     SvFAKE_off(sv);
6221                 } else if (SvLEN(sv)) {
6222                     Safefree(SvPVX_const(sv));
6223                 }
6224             }
6225 #else
6226             else if (SvPVX_const(sv) && SvLEN(sv)
6227                      && !(SvTYPE(sv) == SVt_PVIO
6228                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6229                 Safefree(SvPVX_mutable(sv));
6230             else if (SvPVX_const(sv) && SvIsCOW(sv)) {
6231                 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6232                 SvFAKE_off(sv);
6233             }
6234 #endif
6235             break;
6236         case SVt_NV:
6237             break;
6238         }
6239
6240       free_body:
6241
6242         SvFLAGS(sv) &= SVf_BREAK;
6243         SvFLAGS(sv) |= SVTYPEMASK;
6244
6245         sv_type_details = bodies_by_type + type;
6246         if (sv_type_details->arena) {
6247             del_body(((char *)SvANY(sv) + sv_type_details->offset),
6248                      &PL_body_roots[type]);
6249         }
6250         else if (sv_type_details->body_size) {
6251             safefree(SvANY(sv));
6252         }
6253
6254       free_head:
6255         /* caller is responsible for freeing the head of the original sv */
6256         if (sv != orig_sv && !SvREFCNT(sv))
6257             del_SV(sv);
6258
6259         /* grab and free next sv, if any */
6260       get_next_sv:
6261         while (1) {
6262             sv = NULL;
6263             if (next_sv) {
6264                 sv = next_sv;
6265                 next_sv = NULL;
6266             }
6267             else if (!iter_sv) {
6268                 break;
6269             } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6270                 AV *const av = (AV*)iter_sv;
6271                 if (AvFILLp(av) > -1) {
6272                     sv = AvARRAY(av)[AvFILLp(av)--];
6273                 }
6274                 else { /* no more elements of current AV to free */
6275                     sv = iter_sv;
6276                     type = SvTYPE(sv);
6277                     /* restore previous value, squirrelled away */
6278                     iter_sv = AvARRAY(av)[AvMAX(av)];
6279                     Safefree(AvALLOC(av));
6280                     goto free_body;
6281                 }
6282             } else if (SvTYPE(iter_sv) == SVt_PVHV) {
6283                 sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
6284                 if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
6285                     /* no more elements of current HV to free */
6286                     sv = iter_sv;
6287                     type = SvTYPE(sv);
6288                     /* Restore previous value of iter_sv, squirrelled away */
6289                     assert(!SvOBJECT(sv));
6290                     iter_sv = (SV*)SvSTASH(sv);
6291
6292                     /* ideally we should restore the old hash_index here,
6293                      * but we don't currently save the old value */
6294                     hash_index = 0;
6295
6296                     /* free any remaining detritus from the hash struct */
6297                     Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6298                     assert(!HvARRAY((HV*)sv));
6299                     goto free_body;
6300                 }
6301             }
6302
6303             /* unrolled SvREFCNT_dec and sv_free2 follows: */
6304
6305             if (!sv)
6306                 continue;
6307             if (!SvREFCNT(sv)) {
6308                 sv_free(sv);
6309                 continue;
6310             }
6311             if (--(SvREFCNT(sv)))
6312                 continue;
6313 #ifdef DEBUGGING
6314             if (SvTEMP(sv)) {
6315                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6316                          "Attempt to free temp prematurely: SV 0x%"UVxf
6317                          pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6318                 continue;
6319             }
6320 #endif
6321             if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6322                 /* make sure SvREFCNT(sv)==0 happens very seldom */
6323                 SvREFCNT(sv) = (~(U32)0)/2;
6324                 continue;
6325             }
6326             break;
6327         } /* while 1 */
6328
6329     } /* while sv */
6330 }
6331
6332 /* This routine curses the sv itself, not the object referenced by sv. So
6333    sv does not have to be ROK. */
6334
6335 static bool
6336 S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
6337     dVAR;
6338
6339     PERL_ARGS_ASSERT_CURSE;
6340     assert(SvOBJECT(sv));
6341
6342     if (PL_defstash &&  /* Still have a symbol table? */
6343         SvDESTROYABLE(sv))
6344     {
6345         dSP;
6346         HV* stash;
6347         do {
6348             CV* destructor;
6349             stash = SvSTASH(sv);
6350             destructor = StashHANDLER(stash,DESTROY);
6351             if (destructor
6352                 /* A constant subroutine can have no side effects, so
6353                    don't bother calling it.  */
6354                 && !CvCONST(destructor)
6355                 /* Don't bother calling an empty destructor or one that
6356                    returns immediately. */
6357                 && (CvISXSUB(destructor)
6358                 || (CvSTART(destructor)
6359                     && (CvSTART(destructor)->op_next->op_type
6360                                         != OP_LEAVESUB)
6361                     && (CvSTART(destructor)->op_next->op_type
6362                                         != OP_PUSHMARK
6363                         || CvSTART(destructor)->op_next->op_next->op_type
6364                                         != OP_RETURN
6365                        )
6366                    ))
6367                )
6368             {
6369                 SV* const tmpref = newRV(sv);
6370                 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
6371                 ENTER;
6372                 PUSHSTACKi(PERLSI_DESTROY);
6373                 EXTEND(SP, 2);
6374                 PUSHMARK(SP);
6375                 PUSHs(tmpref);
6376                 PUTBACK;
6377                 call_sv(MUTABLE_SV(destructor),
6378                             G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6379                 POPSTACK;
6380                 SPAGAIN;
6381                 LEAVE;
6382                 if(SvREFCNT(tmpref) < 2) {
6383                     /* tmpref is not kept alive! */
6384                     SvREFCNT(sv)--;
6385                     SvRV_set(tmpref, NULL);
6386                     SvROK_off(tmpref);
6387                 }
6388                 SvREFCNT_dec(tmpref);
6389             }
6390         } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
6391
6392
6393         if (check_refcnt && SvREFCNT(sv)) {
6394             if (PL_in_clean_objs)
6395                 Perl_croak(aTHX_
6396                   "DESTROY created new reference to dead object '%"HEKf"'",
6397                    HEKfARG(HvNAME_HEK(stash)));
6398             /* DESTROY gave object new lease on life */
6399             return FALSE;
6400         }
6401     }
6402
6403     if (SvOBJECT(sv)) {
6404         SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
6405         SvOBJECT_off(sv);       /* Curse the object. */
6406         if (SvTYPE(sv) != SVt_PVIO)
6407             --PL_sv_objcount;/* XXX Might want something more general */
6408     }
6409     return TRUE;
6410 }
6411
6412 /*
6413 =for apidoc sv_newref
6414
6415 Increment an SV's reference count.  Use the C<SvREFCNT_inc()> wrapper
6416 instead.
6417
6418 =cut
6419 */
6420
6421 SV *
6422 Perl_sv_newref(pTHX_ SV *const sv)
6423 {
6424     PERL_UNUSED_CONTEXT;
6425     if (sv)
6426         (SvREFCNT(sv))++;
6427     return sv;
6428 }
6429
6430 /*
6431 =for apidoc sv_free
6432
6433 Decrement an SV's reference count, and if it drops to zero, call
6434 C<sv_clear> to invoke destructors and free up any memory used by
6435 the body; finally, deallocate the SV's head itself.
6436 Normally called via a wrapper macro C<SvREFCNT_dec>.
6437
6438 =cut
6439 */
6440
6441 void
6442 Perl_sv_free(pTHX_ SV *const sv)
6443 {
6444     dVAR;
6445     if (!sv)
6446         return;
6447     if (SvREFCNT(sv) == 0) {
6448         if (SvFLAGS(sv) & SVf_BREAK)
6449             /* this SV's refcnt has been artificially decremented to
6450              * trigger cleanup */
6451             return;
6452         if (PL_in_clean_all) /* All is fair */
6453             return;
6454         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6455             /* make sure SvREFCNT(sv)==0 happens very seldom */
6456             SvREFCNT(sv) = (~(U32)0)/2;
6457             return;
6458         }
6459         if (ckWARN_d(WARN_INTERNAL)) {
6460 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6461             Perl_dump_sv_child(aTHX_ sv);
6462 #else
6463   #ifdef DEBUG_LEAKING_SCALARS
6464             sv_dump(sv);
6465   #endif
6466 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6467             if (PL_warnhook == PERL_WARNHOOK_FATAL
6468                 || ckDEAD(packWARN(WARN_INTERNAL))) {
6469                 /* Don't let Perl_warner cause us to escape our fate:  */
6470                 abort();
6471             }
6472 #endif
6473             /* This may not return:  */
6474             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6475                         "Attempt to free unreferenced scalar: SV 0x%"UVxf
6476                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6477 #endif
6478         }
6479 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6480         abort();
6481 #endif
6482         return;
6483     }
6484     if (--(SvREFCNT(sv)) > 0)
6485         return;
6486     Perl_sv_free2(aTHX_ sv);
6487 }
6488
6489 void
6490 Perl_sv_free2(pTHX_ SV *const sv)
6491 {
6492     dVAR;
6493
6494     PERL_ARGS_ASSERT_SV_FREE2;
6495
6496 #ifdef DEBUGGING
6497     if (SvTEMP(sv)) {
6498         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6499                          "Attempt to free temp prematurely: SV 0x%"UVxf
6500                          pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6501         return;
6502     }
6503 #endif
6504     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6505         /* make sure SvREFCNT(sv)==0 happens very seldom */
6506         SvREFCNT(sv) = (~(U32)0)/2;
6507         return;
6508     }
6509     sv_clear(sv);
6510     if (! SvREFCNT(sv))
6511         del_SV(sv);
6512 }
6513
6514 /*
6515 =for apidoc sv_len
6516
6517 Returns the length of the string in the SV.  Handles magic and type
6518 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6519
6520 =cut
6521 */
6522
6523 STRLEN
6524 Perl_sv_len(pTHX_ register SV *const sv)
6525 {
6526     STRLEN len;
6527
6528     if (!sv)
6529         return 0;
6530
6531     if (SvGMAGICAL(sv))
6532         len = mg_length(sv);
6533     else
6534         (void)SvPV_const(sv, len);
6535     return len;
6536 }
6537
6538 /*
6539 =for apidoc sv_len_utf8
6540
6541 Returns the number of characters in the string in an SV, counting wide
6542 UTF-8 bytes as a single character.  Handles magic and type coercion.
6543
6544 =cut
6545 */
6546
6547 /*
6548  * The length is cached in PERL_MAGIC_utf8, in the mg_len field.  Also the
6549  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6550  * (Note that the mg_len is not the length of the mg_ptr field.
6551  * This allows the cache to store the character length of the string without
6552  * needing to malloc() extra storage to attach to the mg_ptr.)
6553  *
6554  */
6555
6556 STRLEN
6557 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6558 {
6559     if (!sv)
6560         return 0;
6561
6562     if (SvGMAGICAL(sv))
6563         return mg_length(sv);
6564     else
6565     {
6566         STRLEN len;
6567         const U8 *s = (U8*)SvPV_const(sv, len);
6568
6569         if (PL_utf8cache) {
6570             STRLEN ulen;
6571             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6572
6573             if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6574                 if (mg->mg_len != -1)
6575                     ulen = mg->mg_len;
6576                 else {
6577                     /* We can use the offset cache for a headstart.
6578                        The longer value is stored in the first pair.  */
6579                     STRLEN *cache = (STRLEN *) mg->mg_ptr;
6580
6581                     ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6582                                                        s + len);
6583                 }
6584
6585                 if (PL_utf8cache < 0) {
6586                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6587                     assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6588                 }
6589             }
6590             else {
6591                 ulen = Perl_utf8_length(aTHX_ s, s + len);
6592                 utf8_mg_len_cache_update(sv, &mg, ulen);
6593             }
6594             return ulen;
6595         }
6596         return Perl_utf8_length(aTHX_ s, s + len);
6597     }
6598 }
6599
6600 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6601    offset.  */
6602 static STRLEN
6603 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6604                       STRLEN *const uoffset_p, bool *const at_end)
6605 {
6606     const U8 *s = start;
6607     STRLEN uoffset = *uoffset_p;
6608
6609     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6610
6611     while (s < send && uoffset) {
6612         --uoffset;
6613         s += UTF8SKIP(s);
6614     }
6615     if (s == send) {
6616         *at_end = TRUE;
6617     }
6618     else if (s > send) {
6619         *at_end = TRUE;
6620         /* This is the existing behaviour. Possibly it should be a croak, as
6621            it's actually a bounds error  */
6622         s = send;
6623     }
6624     *uoffset_p -= uoffset;
6625     return s - start;
6626 }
6627
6628 /* Given the length of the string in both bytes and UTF-8 characters, decide
6629    whether to walk forwards or backwards to find the byte corresponding to
6630    the passed in UTF-8 offset.  */
6631 static STRLEN
6632 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6633                     STRLEN uoffset, const STRLEN uend)
6634 {
6635     STRLEN backw = uend - uoffset;
6636
6637     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6638
6639     if (uoffset < 2 * backw) {
6640         /* The assumption is that going forwards is twice the speed of going
6641            forward (that's where the 2 * backw comes from).
6642            (The real figure of course depends on the UTF-8 data.)  */
6643         const U8 *s = start;
6644
6645         while (s < send && uoffset--)
6646             s += UTF8SKIP(s);
6647         assert (s <= send);
6648         if (s > send)
6649             s = send;
6650         return s - start;
6651     }
6652
6653     while (backw--) {
6654         send--;
6655         while (UTF8_IS_CONTINUATION(*send))
6656             send--;
6657     }
6658     return send - start;
6659 }
6660
6661 /* For the string representation of the given scalar, find the byte
6662    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
6663    give another position in the string, *before* the sought offset, which
6664    (which is always true, as 0, 0 is a valid pair of positions), which should
6665    help reduce the amount of linear searching.
6666    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6667    will be used to reduce the amount of linear searching. The cache will be
6668    created if necessary, and the found value offered to it for update.  */
6669 static STRLEN
6670 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6671                     const U8 *const send, STRLEN uoffset,
6672                     STRLEN uoffset0, STRLEN boffset0)
6673 {
6674     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
6675     bool found = FALSE;
6676     bool at_end = FALSE;
6677
6678     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6679
6680     assert (uoffset >= uoffset0);
6681
6682     if (!uoffset)
6683         return 0;
6684
6685     if (!SvREADONLY(sv)
6686         && PL_utf8cache
6687         && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6688                      (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6689         if ((*mgp)->mg_ptr) {
6690             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6691             if (cache[0] == uoffset) {
6692                 /* An exact match. */
6693                 return cache[1];
6694             }
6695             if (cache[2] == uoffset) {
6696                 /* An exact match. */
6697                 return cache[3];
6698             }
6699
6700             if (cache[0] < uoffset) {
6701                 /* The cache already knows part of the way.   */
6702                 if (cache[0] > uoffset0) {
6703                     /* The cache knows more than the passed in pair  */
6704                     uoffset0 = cache[0];
6705                     boffset0 = cache[1];
6706                 }
6707                 if ((*mgp)->mg_len != -1) {
6708                     /* And we know the end too.  */
6709                     boffset = boffset0
6710                         + sv_pos_u2b_midway(start + boffset0, send,
6711                                               uoffset - uoffset0,
6712                                               (*mgp)->mg_len - uoffset0);
6713                 } else {
6714                     uoffset -= uoffset0;
6715                     boffset = boffset0
6716                         + sv_pos_u2b_forwards(start + boffset0,
6717                                               send, &uoffset, &at_end);
6718                     uoffset += uoffset0;
6719                 }
6720             }
6721             else if (cache[2] < uoffset) {
6722                 /* We're between the two cache entries.  */
6723                 if (cache[2] > uoffset0) {
6724                     /* and the cache knows more than the passed in pair  */
6725                     uoffset0 = cache[2];
6726                     boffset0 = cache[3];
6727                 }
6728
6729                 boffset = boffset0
6730                     + sv_pos_u2b_midway(start + boffset0,
6731                                           start + cache[1],
6732                                           uoffset - uoffset0,
6733                                           cache[0] - uoffset0);
6734             } else {
6735                 boffset = boffset0
6736                     + sv_pos_u2b_midway(start + boffset0,
6737                                           start + cache[3],
6738                                           uoffset - uoffset0,
6739                                           cache[2] - uoffset0);
6740             }
6741             found = TRUE;
6742         }
6743         else if ((*mgp)->mg_len != -1) {
6744             /* If we can take advantage of a passed in offset, do so.  */
6745             /* In fact, offset0 is either 0, or less than offset, so don't
6746                need to worry about the other possibility.  */
6747             boffset = boffset0
6748                 + sv_pos_u2b_midway(start + boffset0, send,
6749                                       uoffset - uoffset0,
6750                                       (*mgp)->mg_len - uoffset0);
6751             found = TRUE;
6752         }
6753     }
6754
6755     if (!found || PL_utf8cache < 0) {
6756         STRLEN real_boffset;
6757         uoffset -= uoffset0;
6758         real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6759                                                       send, &uoffset, &at_end);
6760         uoffset += uoffset0;
6761
6762         if (found && PL_utf8cache < 0)
6763             assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6764                                        real_boffset, sv);
6765         boffset = real_boffset;
6766     }
6767
6768     if (PL_utf8cache) {
6769         if (at_end)
6770             utf8_mg_len_cache_update(sv, mgp, uoffset);
6771         else
6772             utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6773     }
6774     return boffset;
6775 }
6776
6777
6778 /*
6779 =for apidoc sv_pos_u2b_flags
6780
6781 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6782 the start of the string, to a count of the equivalent number of bytes; if
6783 lenp is non-zero, it does the same to lenp, but this time starting from
6784 the offset, rather than from the start
6785 of the string.  Handles type coercion.
6786 I<flags> is passed to C<SvPV_flags>, and usually should be
6787 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6788
6789 =cut
6790 */
6791
6792 /*
6793  * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6794  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6795  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6796  *
6797  */
6798
6799 STRLEN
6800 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6801                       U32 flags)
6802 {
6803     const U8 *start;
6804     STRLEN len;
6805     STRLEN boffset;
6806
6807     PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6808
6809     start = (U8*)SvPV_flags(sv, len, flags);
6810     if (len) {
6811         const U8 * const send = start + len;
6812         MAGIC *mg = NULL;
6813         boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6814
6815         if (lenp
6816             && *lenp /* don't bother doing work for 0, as its bytes equivalent
6817                         is 0, and *lenp is already set to that.  */) {
6818             /* Convert the relative offset to absolute.  */
6819             const STRLEN uoffset2 = uoffset + *lenp;
6820             const STRLEN boffset2
6821                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6822                                       uoffset, boffset) - boffset;
6823
6824             *lenp = boffset2;
6825         }
6826     } else {
6827         if (lenp)
6828             *lenp = 0;
6829         boffset = 0;
6830     }
6831
6832     return boffset;
6833 }
6834
6835 /*
6836 =for apidoc sv_pos_u2b
6837
6838 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6839 the start of the string, to a count of the equivalent number of bytes; if
6840 lenp is non-zero, it does the same to lenp, but this time starting from
6841 the offset, rather than from the start of the string.  Handles magic and
6842 type coercion.
6843
6844 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6845 than 2Gb.
6846
6847 =cut
6848 */
6849
6850 /*
6851  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6852  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6853  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6854  *
6855  */
6856
6857 /* This function is subject to size and sign problems */
6858
6859 void
6860 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6861 {
6862     PERL_ARGS_ASSERT_SV_POS_U2B;
6863
6864     if (lenp) {
6865         STRLEN ulen = (STRLEN)*lenp;
6866         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6867                                          SV_GMAGIC|SV_CONST_RETURN);
6868         *lenp = (I32)ulen;
6869     } else {
6870         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6871                                          SV_GMAGIC|SV_CONST_RETURN);
6872     }
6873 }
6874
6875 static void
6876 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6877                            const STRLEN ulen)
6878 {
6879     PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6880     if (SvREADONLY(sv))
6881         return;
6882
6883     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6884                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6885         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6886     }
6887     assert(*mgp);
6888
6889     (*mgp)->mg_len = ulen;
6890     /* For now, treat "overflowed" as "still unknown". See RT #72924.  */
6891     if (ulen != (STRLEN) (*mgp)->mg_len)
6892         (*mgp)->mg_len = -1;
6893 }
6894
6895 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6896    byte length pairing. The (byte) length of the total SV is passed in too,
6897    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6898    may not have updated SvCUR, so we can't rely on reading it directly.
6899
6900    The proffered utf8/byte length pairing isn't used if the cache already has
6901    two pairs, and swapping either for the proffered pair would increase the
6902    RMS of the intervals between known byte offsets.
6903
6904    The cache itself consists of 4 STRLEN values
6905    0: larger UTF-8 offset
6906    1: corresponding byte offset
6907    2: smaller UTF-8 offset
6908    3: corresponding byte offset
6909
6910    Unused cache pairs have the value 0, 0.
6911    Keeping the cache "backwards" means that the invariant of
6912    cache[0] >= cache[2] is maintained even with empty slots, which means that
6913    the code that uses it doesn't need to worry if only 1 entry has actually
6914    been set to non-zero.  It also makes the "position beyond the end of the
6915    cache" logic much simpler, as the first slot is always the one to start
6916    from.
6917 */
6918 static void
6919 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6920                            const STRLEN utf8, const STRLEN blen)
6921 {
6922     STRLEN *cache;
6923
6924     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6925
6926     if (SvREADONLY(sv))
6927         return;
6928
6929     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6930                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6931         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6932                            0);
6933         (*mgp)->mg_len = -1;
6934     }
6935     assert(*mgp);
6936
6937     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6938         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6939         (*mgp)->mg_ptr = (char *) cache;
6940     }
6941     assert(cache);
6942
6943     if (PL_utf8cache < 0 && SvPOKp(sv)) {
6944         /* SvPOKp() because it's possible that sv has string overloading, and
6945            therefore is a reference, hence SvPVX() is actually a pointer.
6946            This cures the (very real) symptoms of RT 69422, but I'm not actually
6947            sure whether we should even be caching the results of UTF-8
6948            operations on overloading, given that nothing stops overloading
6949            returning a different value every time it's called.  */
6950         const U8 *start = (const U8 *) SvPVX_const(sv);
6951         const STRLEN realutf8 = utf8_length(start, start + byte);
6952
6953         assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6954                                    sv);
6955     }
6956
6957     /* Cache is held with the later position first, to simplify the code
6958        that deals with unbounded ends.  */
6959
6960     ASSERT_UTF8_CACHE(cache);
6961     if (cache[1] == 0) {
6962         /* Cache is totally empty  */
6963         cache[0] = utf8;
6964         cache[1] = byte;
6965     } else if (cache[3] == 0) {
6966         if (byte > cache[1]) {
6967             /* New one is larger, so goes first.  */
6968             cache[2] = cache[0];
6969             cache[3] = cache[1];
6970             cache[0] = utf8;
6971             cache[1] = byte;
6972         } else {
6973             cache[2] = utf8;
6974             cache[3] = byte;
6975         }
6976     } else {
6977 #define THREEWAY_SQUARE(a,b,c,d) \
6978             ((float)((d) - (c))) * ((float)((d) - (c))) \
6979             + ((float)((c) - (b))) * ((float)((c) - (b))) \
6980                + ((float)((b) - (a))) * ((float)((b) - (a)))
6981
6982         /* Cache has 2 slots in use, and we know three potential pairs.
6983            Keep the two that give the lowest RMS distance. Do the
6984            calculation in bytes simply because we always know the byte
6985            length.  squareroot has the same ordering as the positive value,
6986            so don't bother with the actual square root.  */
6987         const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6988         if (byte > cache[1]) {
6989             /* New position is after the existing pair of pairs.  */
6990             const float keep_earlier
6991                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6992             const float keep_later
6993                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6994
6995             if (keep_later < keep_earlier) {
6996                 if (keep_later < existing) {
6997                     cache[2] = cache[0];
6998                     cache[3] = cache[1];
6999                     cache[0] = utf8;
7000                     cache[1] = byte;
7001                 }
7002             }
7003             else {
7004                 if (keep_earlier < existing) {
7005                     cache[0] = utf8;
7006                     cache[1] = byte;
7007                 }
7008             }
7009         }
7010         else if (byte > cache[3]) {
7011             /* New position is between the existing pair of pairs.  */
7012             const float keep_earlier
7013                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
7014             const float keep_later
7015                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7016
7017             if (keep_later < keep_earlier) {
7018                 if (keep_later < existing) {
7019                     cache[2] = utf8;
7020                     cache[3] = byte;
7021                 }
7022             }
7023             else {
7024                 if (keep_earlier < existing) {
7025                     cache[0] = utf8;
7026                     cache[1] = byte;
7027                 }
7028             }
7029         }
7030         else {
7031             /* New position is before the existing pair of pairs.  */
7032             const float keep_earlier
7033                 = THREEWAY_SQUARE(0, byte, cache[3], blen);
7034             const float keep_later
7035                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7036
7037             if (keep_later < keep_earlier) {
7038                 if (keep_later < existing) {
7039                     cache[2] = utf8;
7040                     cache[3] = byte;
7041                 }
7042             }
7043             else {
7044                 if (keep_earlier < existing) {
7045                     cache[0] = cache[2];
7046                     cache[1] = cache[3];
7047                     cache[2] = utf8;
7048                     cache[3] = byte;
7049                 }
7050             }
7051         }
7052     }
7053     ASSERT_UTF8_CACHE(cache);
7054 }
7055
7056 /* We already know all of the way, now we may be able to walk back.  The same
7057    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
7058    backward is half the speed of walking forward. */
7059 static STRLEN
7060 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
7061                     const U8 *end, STRLEN endu)
7062 {
7063     const STRLEN forw = target - s;
7064     STRLEN backw = end - target;
7065
7066     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
7067
7068     if (forw < 2 * backw) {
7069         return utf8_length(s, target);
7070     }
7071
7072     while (end > target) {
7073         end--;
7074         while (UTF8_IS_CONTINUATION(*end)) {
7075             end--;
7076         }
7077         endu--;
7078     }
7079     return endu;
7080 }
7081
7082 /*
7083 =for apidoc sv_pos_b2u
7084
7085 Converts the value pointed to by offsetp from a count of bytes from the
7086 start of the string, to a count of the equivalent number of UTF-8 chars.
7087 Handles magic and type coercion.
7088
7089 =cut
7090 */
7091
7092 /*
7093  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
7094  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7095  * byte offsets.
7096  *
7097  */
7098 void
7099 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
7100 {
7101     const U8* s;
7102     const STRLEN byte = *offsetp;
7103     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
7104     STRLEN blen;
7105     MAGIC* mg = NULL;
7106     const U8* send;
7107     bool found = FALSE;
7108
7109     PERL_ARGS_ASSERT_SV_POS_B2U;
7110
7111     if (!sv)
7112         return;
7113
7114     s = (const U8*)SvPV_const(sv, blen);
7115
7116     if (blen < byte)
7117         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
7118                    ", byte=%"UVuf, (UV)blen, (UV)byte);
7119
7120     send = s + byte;
7121
7122     if (!SvREADONLY(sv)
7123         && PL_utf8cache
7124         && SvTYPE(sv) >= SVt_PVMG
7125         && (mg = mg_find(sv, PERL_MAGIC_utf8)))
7126     {
7127         if (mg->mg_ptr) {
7128             STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7129             if (cache[1] == byte) {
7130                 /* An exact match. */
7131                 *offsetp = cache[0];
7132                 return;
7133             }
7134             if (cache[3] == byte) {
7135                 /* An exact match. */
7136                 *offsetp = cache[2];
7137                 return;
7138             }
7139
7140             if (cache[1] < byte) {
7141                 /* We already know part of the way. */
7142                 if (mg->mg_len != -1) {
7143                     /* Actually, we know the end too.  */
7144                     len = cache[0]
7145                         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
7146                                               s + blen, mg->mg_len - cache[0]);
7147                 } else {
7148                     len = cache[0] + utf8_length(s + cache[1], send);
7149                 }
7150             }
7151             else if (cache[3] < byte) {
7152                 /* We're between the two cached pairs, so we do the calculation
7153                    offset by the byte/utf-8 positions for the earlier pair,
7154                    then add the utf-8 characters from the string start to
7155                    there.  */
7156                 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7157                                           s + cache[1], cache[0] - cache[2])
7158                     + cache[2];
7159
7160             }
7161             else { /* cache[3] > byte */
7162                 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7163                                           cache[2]);
7164
7165             }
7166             ASSERT_UTF8_CACHE(cache);
7167             found = TRUE;
7168         } else if (mg->mg_len != -1) {
7169             len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7170             found = TRUE;
7171         }
7172     }
7173     if (!found || PL_utf8cache < 0) {
7174         const STRLEN real_len = utf8_length(s, send);
7175
7176         if (found && PL_utf8cache < 0)
7177             assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7178         len = real_len;
7179     }
7180     *offsetp = len;
7181
7182     if (PL_utf8cache) {
7183         if (blen == byte)
7184             utf8_mg_len_cache_update(sv, &mg, len);
7185         else
7186             utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
7187     }
7188 }
7189
7190 static void
7191 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7192                              STRLEN real, SV *const sv)
7193 {
7194     PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7195
7196     /* As this is debugging only code, save space by keeping this test here,
7197        rather than inlining it in all the callers.  */
7198     if (from_cache == real)
7199         return;
7200
7201     /* Need to turn the assertions off otherwise we may recurse infinitely
7202        while printing error messages.  */
7203     SAVEI8(PL_utf8cache);
7204     PL_utf8cache = 0;
7205     Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7206                func, (UV) from_cache, (UV) real, SVfARG(sv));
7207 }
7208
7209 /*
7210 =for apidoc sv_eq
7211
7212 Returns a boolean indicating whether the strings in the two SVs are
7213 identical.  Is UTF-8 and 'use bytes' aware, handles get magic, and will
7214 coerce its args to strings if necessary.
7215
7216 =for apidoc sv_eq_flags
7217
7218 Returns a boolean indicating whether the strings in the two SVs are
7219 identical.  Is UTF-8 and 'use bytes' aware and coerces its args to strings
7220 if necessary.  If the flags include SV_GMAGIC, it handles get-magic, too.
7221
7222 =cut
7223 */
7224
7225 I32
7226 Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
7227 {
7228     dVAR;
7229     const char *pv1;
7230     STRLEN cur1;
7231     const char *pv2;
7232     STRLEN cur2;
7233     I32  eq     = 0;
7234     SV* svrecode = NULL;
7235
7236     if (!sv1) {
7237         pv1 = "";
7238         cur1 = 0;
7239     }
7240     else {
7241         /* if pv1 and pv2 are the same, second SvPV_const call may
7242          * invalidate pv1 (if we are handling magic), so we may need to
7243          * make a copy */
7244         if (sv1 == sv2 && flags & SV_GMAGIC
7245          && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7246             pv1 = SvPV_const(sv1, cur1);
7247             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7248         }
7249         pv1 = SvPV_flags_const(sv1, cur1, flags);
7250     }
7251
7252     if (!sv2){
7253         pv2 = "";
7254         cur2 = 0;
7255     }
7256     else
7257         pv2 = SvPV_flags_const(sv2, cur2, flags);
7258
7259     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7260         /* Differing utf8ness.
7261          * Do not UTF8size the comparands as a side-effect. */
7262          if (PL_encoding) {
7263               if (SvUTF8(sv1)) {
7264                    svrecode = newSVpvn(pv2, cur2);
7265                    sv_recode_to_utf8(svrecode, PL_encoding);
7266                    pv2 = SvPV_const(svrecode, cur2);
7267               }
7268               else {
7269                    svrecode = newSVpvn(pv1, cur1);
7270                    sv_recode_to_utf8(svrecode, PL_encoding);
7271                    pv1 = SvPV_const(svrecode, cur1);
7272               }
7273               /* Now both are in UTF-8. */
7274               if (cur1 != cur2) {
7275                    SvREFCNT_dec(svrecode);
7276                    return FALSE;
7277               }
7278          }
7279          else {
7280               if (SvUTF8(sv1)) {
7281                   /* sv1 is the UTF-8 one  */
7282                   return bytes_cmp_utf8((const U8*)pv2, cur2,
7283                                         (const U8*)pv1, cur1) == 0;
7284               }
7285               else {
7286                   /* sv2 is the UTF-8 one  */
7287                   return bytes_cmp_utf8((const U8*)pv1, cur1,
7288                                         (const U8*)pv2, cur2) == 0;
7289               }
7290          }
7291     }
7292
7293     if (cur1 == cur2)
7294         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7295
7296     SvREFCNT_dec(svrecode);
7297
7298     return eq;
7299 }
7300
7301 /*
7302 =for apidoc sv_cmp
7303
7304 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
7305 string in C<sv1> is less than, equal to, or greater than the string in
7306 C<sv2>.  Is UTF-8 and 'use bytes' aware, handles get magic, and will
7307 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
7308
7309 =for apidoc sv_cmp_flags
7310
7311 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
7312 string in C<sv1> is less than, equal to, or greater than the string in
7313 C<sv2>.  Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7314 if necessary.  If the flags include SV_GMAGIC, it handles get magic.  See
7315 also C<sv_cmp_locale_flags>.
7316
7317 =cut
7318 */
7319
7320 I32
7321 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
7322 {
7323     return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7324 }
7325
7326 I32
7327 Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7328                   const U32 flags)
7329 {
7330     dVAR;
7331     STRLEN cur1, cur2;
7332     const char *pv1, *pv2;
7333     char *tpv = NULL;
7334     I32  cmp;
7335     SV *svrecode = NULL;
7336
7337     if (!sv1) {
7338         pv1 = "";
7339         cur1 = 0;
7340     }
7341     else
7342         pv1 = SvPV_flags_const(sv1, cur1, flags);
7343
7344     if (!sv2) {
7345         pv2 = "";
7346         cur2 = 0;
7347     }
7348     else
7349         pv2 = SvPV_flags_const(sv2, cur2, flags);
7350
7351     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7352         /* Differing utf8ness.
7353          * Do not UTF8size the comparands as a side-effect. */
7354         if (SvUTF8(sv1)) {
7355             if (PL_encoding) {
7356                  svrecode = newSVpvn(pv2, cur2);
7357                  sv_recode_to_utf8(svrecode, PL_encoding);
7358                  pv2 = SvPV_const(svrecode, cur2);
7359             }
7360             else {
7361                 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7362                                                    (const U8*)pv1, cur1);
7363                 return retval ? retval < 0 ? -1 : +1 : 0;
7364             }
7365         }
7366         else {
7367             if (PL_encoding) {
7368                  svrecode = newSVpvn(pv1, cur1);
7369                  sv_recode_to_utf8(svrecode, PL_encoding);
7370                  pv1 = SvPV_const(svrecode, cur1);
7371             }
7372             else {
7373                 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7374                                                   (const U8*)pv2, cur2);
7375                 return retval ? retval < 0 ? -1 : +1 : 0;
7376             }
7377         }
7378     }
7379
7380     if (!cur1) {
7381         cmp = cur2 ? -1 : 0;
7382     } else if (!cur2) {
7383         cmp = 1;
7384     } else {
7385         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7386
7387         if (retval) {
7388             cmp = retval < 0 ? -1 : 1;
7389         } else if (cur1 == cur2) {
7390             cmp = 0;
7391         } else {
7392             cmp = cur1 < cur2 ? -1 : 1;
7393         }
7394     }
7395
7396     SvREFCNT_dec(svrecode);
7397     if (tpv)
7398         Safefree(tpv);
7399
7400     return cmp;
7401 }
7402
7403 /*
7404 =for apidoc sv_cmp_locale
7405
7406 Compares the strings in two SVs in a locale-aware manner.  Is UTF-8 and
7407 'use bytes' aware, handles get magic, and will coerce its args to strings
7408 if necessary.  See also C<sv_cmp>.
7409
7410 =for apidoc sv_cmp_locale_flags
7411
7412 Compares the strings in two SVs in a locale-aware manner.  Is UTF-8 and
7413 'use bytes' aware and will coerce its args to strings if necessary.  If the
7414 flags contain SV_GMAGIC, it handles get magic.  See also C<sv_cmp_flags>.
7415
7416 =cut
7417 */
7418
7419 I32
7420 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
7421 {
7422     return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7423 }
7424
7425 I32
7426 Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7427                          const U32 flags)
7428 {
7429     dVAR;
7430 #ifdef USE_LOCALE_COLLATE
7431
7432     char *pv1, *pv2;
7433     STRLEN len1, len2;
7434     I32 retval;
7435
7436     if (PL_collation_standard)
7437         goto raw_compare;
7438
7439     len1 = 0;
7440     pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7441     len2 = 0;
7442     pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7443
7444     if (!pv1 || !len1) {
7445         if (pv2 && len2)
7446             return -1;
7447         else
7448             goto raw_compare;
7449     }
7450     else {
7451         if (!pv2 || !len2)
7452             return 1;
7453     }
7454
7455     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7456
7457     if (retval)
7458         return retval < 0 ? -1 : 1;
7459
7460     /*
7461      * When the result of collation is equality, that doesn't mean
7462      * that there are no differences -- some locales exclude some
7463      * characters from consideration.  So to avoid false equalities,
7464      * we use the raw string as a tiebreaker.
7465      */
7466
7467   raw_compare:
7468     /*FALLTHROUGH*/
7469
7470 #endif /* USE_LOCALE_COLLATE */
7471
7472     return sv_cmp(sv1, sv2);
7473 }
7474
7475
7476 #ifdef USE_LOCALE_COLLATE
7477
7478 /*
7479 =for apidoc sv_collxfrm
7480
7481 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag.  See
7482 C<sv_collxfrm_flags>.
7483
7484 =for apidoc sv_collxfrm_flags
7485
7486 Add Collate Transform magic to an SV if it doesn't already have it.  If the
7487 flags contain SV_GMAGIC, it handles get-magic.
7488
7489 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7490 scalar data of the variable, but transformed to such a format that a normal
7491 memory comparison can be used to compare the data according to the locale
7492 settings.
7493
7494 =cut
7495 */
7496
7497 char *
7498 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7499 {
7500     dVAR;
7501     MAGIC *mg;
7502
7503     PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7504
7505     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7506     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7507         const char *s;
7508         char *xf;
7509         STRLEN len, xlen;
7510
7511         if (mg)
7512             Safefree(mg->mg_ptr);
7513         s = SvPV_flags_const(sv, len, flags);
7514         if ((xf = mem_collxfrm(s, len, &xlen))) {
7515             if (! mg) {
7516 #ifdef PERL_OLD_COPY_ON_WRITE
7517                 if (SvIsCOW(sv))
7518                     sv_force_normal_flags(sv, 0);
7519 #endif
7520                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7521                                  0, 0);
7522                 assert(mg);
7523             }
7524             mg->mg_ptr = xf;
7525             mg->mg_len = xlen;
7526         }
7527         else {
7528             if (mg) {
7529                 mg->mg_ptr = NULL;
7530                 mg->mg_len = -1;
7531             }
7532         }
7533     }
7534     if (mg && mg->mg_ptr) {
7535         *nxp = mg->mg_len;
7536         return mg->mg_ptr + sizeof(PL_collation_ix);
7537     }
7538     else {
7539         *nxp = 0;
7540         return NULL;
7541     }
7542 }
7543
7544 #endif /* USE_LOCALE_COLLATE */
7545
7546 static char *
7547 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7548 {
7549     SV * const tsv = newSV(0);
7550     ENTER;
7551     SAVEFREESV(tsv);
7552     sv_gets(tsv, fp, 0);
7553     sv_utf8_upgrade_nomg(tsv);
7554     SvCUR_set(sv,append);
7555     sv_catsv(sv,tsv);
7556     LEAVE;
7557     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7558 }
7559
7560 static char *
7561 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7562 {
7563     I32 bytesread;
7564     const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7565       /* Grab the size of the record we're getting */
7566     char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7567 #ifdef VMS
7568     int fd;
7569 #endif
7570
7571     /* Go yank in */
7572 #ifdef VMS
7573     /* VMS wants read instead of fread, because fread doesn't respect */
7574     /* RMS record boundaries. This is not necessarily a good thing to be */
7575     /* doing, but we've got no other real choice - except avoid stdio
7576        as implementation - perhaps write a :vms layer ?
7577     */
7578     fd = PerlIO_fileno(fp);
7579     if (fd != -1) {
7580         bytesread = PerlLIO_read(fd, buffer, recsize);
7581     }
7582     else /* in-memory file from PerlIO::Scalar */
7583 #endif
7584     {
7585         bytesread = PerlIO_read(fp, buffer, recsize);
7586     }
7587
7588     if (bytesread < 0)
7589         bytesread = 0;
7590     SvCUR_set(sv, bytesread + append);
7591     buffer[bytesread] = '\0';
7592     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7593 }
7594
7595 /*
7596 =for apidoc sv_gets
7597
7598 Get a line from the filehandle and store it into the SV, optionally
7599 appending to the currently-stored string.
7600
7601 =cut
7602 */
7603
7604 char *
7605 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7606 {
7607     dVAR;
7608     const char *rsptr;
7609     STRLEN rslen;
7610     register STDCHAR rslast;
7611     register STDCHAR *bp;
7612     register I32 cnt;
7613     I32 i = 0;
7614     I32 rspara = 0;
7615
7616     PERL_ARGS_ASSERT_SV_GETS;
7617
7618     if (SvTHINKFIRST(sv))
7619         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7620     /* XXX. If you make this PVIV, then copy on write can copy scalars read
7621        from <>.
7622        However, perlbench says it's slower, because the existing swipe code
7623        is faster than copy on write.
7624        Swings and roundabouts.  */
7625     SvUPGRADE(sv, SVt_PV);
7626
7627     SvSCREAM_off(sv);
7628
7629     if (append) {
7630         if (PerlIO_isutf8(fp)) {
7631             if (!SvUTF8(sv)) {
7632                 sv_utf8_upgrade_nomg(sv);
7633                 sv_pos_u2b(sv,&append,0);
7634             }
7635         } else if (SvUTF8(sv)) {
7636             return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
7637         }
7638     }
7639
7640     SvPOK_only(sv);
7641     if (!append) {
7642         SvCUR_set(sv,0);
7643     }
7644     if (PerlIO_isutf8(fp))
7645         SvUTF8_on(sv);
7646
7647     if (IN_PERL_COMPILETIME) {
7648         /* we always read code in line mode */
7649         rsptr = "\n";
7650         rslen = 1;
7651     }
7652     else if (RsSNARF(PL_rs)) {
7653         /* If it is a regular disk file use size from stat() as estimate
7654            of amount we are going to read -- may result in mallocing
7655            more memory than we really need if the layers below reduce
7656            the size we read (e.g. CRLF or a gzip layer).
7657          */
7658         Stat_t st;
7659         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
7660             const Off_t offset = PerlIO_tell(fp);
7661             if (offset != (Off_t) -1 && st.st_size + append > offset) {
7662                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7663             }
7664         }
7665         rsptr = NULL;
7666         rslen = 0;
7667     }
7668     else if (RsRECORD(PL_rs)) {
7669         return S_sv_gets_read_record(aTHX_ sv, fp, append);
7670     }
7671     else if (RsPARA(PL_rs)) {
7672         rsptr = "\n\n";
7673         rslen = 2;
7674         rspara = 1;
7675     }
7676     else {
7677         /* Get $/ i.e. PL_rs into same encoding as stream wants */
7678         if (PerlIO_isutf8(fp)) {
7679             rsptr = SvPVutf8(PL_rs, rslen);
7680         }
7681         else {
7682             if (SvUTF8(PL_rs)) {
7683                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7684                     Perl_croak(aTHX_ "Wide character in $/");
7685                 }
7686             }
7687             rsptr = SvPV_const(PL_rs, rslen);
7688         }
7689     }
7690
7691     rslast = rslen ? rsptr[rslen - 1] : '\0';
7692
7693     if (rspara) {               /* have to do this both before and after */
7694         do {                    /* to make sure file boundaries work right */
7695             if (PerlIO_eof(fp))
7696                 return 0;
7697             i = PerlIO_getc(fp);
7698             if (i != '\n') {
7699                 if (i == -1)
7700                     return 0;
7701                 PerlIO_ungetc(fp,i);
7702                 break;
7703             }
7704         } while (i != EOF);
7705     }
7706
7707     /* See if we know enough about I/O mechanism to cheat it ! */
7708
7709     /* This used to be #ifdef test - it is made run-time test for ease
7710        of abstracting out stdio interface. One call should be cheap
7711        enough here - and may even be a macro allowing compile
7712        time optimization.
7713      */
7714
7715     if (PerlIO_fast_gets(fp)) {
7716
7717     /*
7718      * We're going to steal some values from the stdio struct
7719      * and put EVERYTHING in the innermost loop into registers.
7720      */
7721     register STDCHAR *ptr;
7722     STRLEN bpx;
7723     I32 shortbuffered;
7724
7725 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7726     /* An ungetc()d char is handled separately from the regular
7727      * buffer, so we getc() it back out and stuff it in the buffer.
7728      */
7729     i = PerlIO_getc(fp);
7730     if (i == EOF) return 0;
7731     *(--((*fp)->_ptr)) = (unsigned char) i;
7732     (*fp)->_cnt++;
7733 #endif
7734
7735     /* Here is some breathtakingly efficient cheating */
7736
7737     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
7738     /* make sure we have the room */
7739     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7740         /* Not room for all of it
7741            if we are looking for a separator and room for some
7742          */
7743         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7744             /* just process what we have room for */
7745             shortbuffered = cnt - SvLEN(sv) + append + 1;
7746             cnt -= shortbuffered;
7747         }
7748         else {
7749             shortbuffered = 0;
7750             /* remember that cnt can be negative */
7751             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7752         }
7753     }
7754     else
7755         shortbuffered = 0;
7756     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
7757     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7758     DEBUG_P(PerlIO_printf(Perl_debug_log,
7759         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7760     DEBUG_P(PerlIO_printf(Perl_debug_log,
7761         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7762                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7763                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7764     for (;;) {
7765       screamer:
7766         if (cnt > 0) {
7767             if (rslen) {
7768                 while (cnt > 0) {                    /* this     |  eat */
7769                     cnt--;
7770                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
7771                         goto thats_all_folks;        /* screams  |  sed :-) */
7772                 }
7773             }
7774             else {
7775                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
7776                 bp += cnt;                           /* screams  |  dust */
7777                 ptr += cnt;                          /* louder   |  sed :-) */
7778                 cnt = 0;
7779                 assert (!shortbuffered);
7780                 goto cannot_be_shortbuffered;
7781             }
7782         }
7783
7784         if (shortbuffered) {            /* oh well, must extend */
7785             cnt = shortbuffered;
7786             shortbuffered = 0;
7787             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7788             SvCUR_set(sv, bpx);
7789             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7790             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7791             continue;
7792         }
7793
7794     cannot_be_shortbuffered:
7795         DEBUG_P(PerlIO_printf(Perl_debug_log,
7796                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7797                               PTR2UV(ptr),(long)cnt));
7798         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7799
7800         DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7801             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7802             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7803             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7804
7805         /* This used to call 'filbuf' in stdio form, but as that behaves like
7806            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7807            another abstraction.  */
7808         i   = PerlIO_getc(fp);          /* get more characters */
7809
7810         DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7811             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7812             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7813             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7814
7815         cnt = PerlIO_get_cnt(fp);
7816         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
7817         DEBUG_P(PerlIO_printf(Perl_debug_log,
7818             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7819
7820         if (i == EOF)                   /* all done for ever? */
7821             goto thats_really_all_folks;
7822
7823         bpx = bp - (STDCHAR*)SvPVX_const(sv);   /* box up before relocation */
7824         SvCUR_set(sv, bpx);
7825         SvGROW(sv, bpx + cnt + 2);
7826         bp = (STDCHAR*)SvPVX_const(sv) + bpx;   /* unbox after relocation */
7827
7828         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
7829
7830         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
7831             goto thats_all_folks;
7832     }
7833
7834 thats_all_folks:
7835     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7836           memNE((char*)bp - rslen, rsptr, rslen))
7837         goto screamer;                          /* go back to the fray */
7838 thats_really_all_folks:
7839     if (shortbuffered)
7840         cnt += shortbuffered;
7841         DEBUG_P(PerlIO_printf(Perl_debug_log,
7842             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7843     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
7844     DEBUG_P(PerlIO_printf(Perl_debug_log,
7845         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7846         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7847         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7848     *bp = '\0';
7849     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));      /* set length */
7850     DEBUG_P(PerlIO_printf(Perl_debug_log,
7851         "Screamer: done, len=%ld, string=|%.*s|\n",
7852         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7853     }
7854    else
7855     {
7856        /*The big, slow, and stupid way. */
7857 #ifdef USE_HEAP_INSTEAD_OF_STACK        /* Even slower way. */
7858         STDCHAR *buf = NULL;
7859         Newx(buf, 8192, STDCHAR);
7860         assert(buf);
7861 #else
7862         STDCHAR buf[8192];
7863 #endif
7864
7865 screamer2:
7866         if (rslen) {
7867             register const STDCHAR * const bpe = buf + sizeof(buf);
7868             bp = buf;
7869             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7870                 ; /* keep reading */
7871             cnt = bp - buf;
7872         }
7873         else {
7874             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7875             /* Accommodate broken VAXC compiler, which applies U8 cast to
7876              * both args of ?: operator, causing EOF to change into 255
7877              */
7878             if (cnt > 0)
7879                  i = (U8)buf[cnt - 1];
7880             else
7881                  i = EOF;
7882         }
7883
7884         if (cnt < 0)
7885             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
7886         if (append)
7887              sv_catpvn(sv, (char *) buf, cnt);
7888         else
7889              sv_setpvn(sv, (char *) buf, cnt);
7890
7891         if (i != EOF &&                 /* joy */
7892             (!rslen ||
7893              SvCUR(sv) < rslen ||
7894              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7895         {
7896             append = -1;
7897             /*
7898              * If we're reading from a TTY and we get a short read,
7899              * indicating that the user hit his EOF character, we need
7900              * to notice it now, because if we try to read from the TTY
7901              * again, the EOF condition will disappear.
7902              *
7903              * The comparison of cnt to sizeof(buf) is an optimization
7904              * that prevents unnecessary calls to feof().
7905              *
7906              * - jik 9/25/96
7907              */
7908             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7909                 goto screamer2;
7910         }
7911
7912 #ifdef USE_HEAP_INSTEAD_OF_STACK
7913         Safefree(buf);
7914 #endif
7915     }
7916
7917     if (rspara) {               /* have to do this both before and after */
7918         while (i != EOF) {      /* to make sure file boundaries work right */
7919             i = PerlIO_getc(fp);
7920             if (i != '\n') {
7921                 PerlIO_ungetc(fp,i);
7922                 break;
7923             }
7924         }
7925     }
7926
7927     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7928 }
7929
7930 /*
7931 =for apidoc sv_inc
7932
7933 Auto-increment of the value in the SV, doing string to numeric conversion
7934 if necessary.  Handles 'get' magic and operator overloading.
7935
7936 =cut
7937 */
7938
7939 void
7940 Perl_sv_inc(pTHX_ register SV *const sv)
7941 {
7942     if (!sv)
7943         return;
7944     SvGETMAGIC(sv);
7945     sv_inc_nomg(sv);
7946 }
7947
7948 /*
7949 =for apidoc sv_inc_nomg
7950
7951 Auto-increment of the value in the SV, doing string to numeric conversion
7952 if necessary.  Handles operator overloading.  Skips handling 'get' magic.
7953
7954 =cut
7955 */
7956
7957 void
7958 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7959 {
7960     dVAR;
7961     register char *d;
7962     int flags;
7963
7964     if (!sv)
7965         return;
7966     if (SvTHINKFIRST(sv)) {
7967         if (SvIsCOW(sv) || isGV_with_GP(sv))
7968             sv_force_normal_flags(sv, 0);
7969         if (SvREADONLY(sv)) {
7970             if (IN_PERL_RUNTIME)
7971                 Perl_croak_no_modify(aTHX);
7972         }
7973         if (SvROK(sv)) {
7974             IV i;
7975             if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
7976                 return;
7977             i = PTR2IV(SvRV(sv));
7978             sv_unref(sv);
7979             sv_setiv(sv, i);
7980         }
7981     }
7982     flags = SvFLAGS(sv);
7983     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7984         /* It's (privately or publicly) a float, but not tested as an
7985            integer, so test it to see. */
7986         (void) SvIV(sv);
7987         flags = SvFLAGS(sv);
7988     }
7989     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7990         /* It's publicly an integer, or privately an integer-not-float */
7991 #ifdef PERL_PRESERVE_IVUV
7992       oops_its_int:
7993 #endif
7994         if (SvIsUV(sv)) {
7995             if (SvUVX(sv) == UV_MAX)
7996                 sv_setnv(sv, UV_MAX_P1);
7997             else
7998                 (void)SvIOK_only_UV(sv);
7999                 SvUV_set(sv, SvUVX(sv) + 1);
8000         } else {
8001             if (SvIVX(sv) == IV_MAX)
8002                 sv_setuv(sv, (UV)IV_MAX + 1);
8003             else {
8004                 (void)SvIOK_only(sv);
8005                 SvIV_set(sv, SvIVX(sv) + 1);
8006             }
8007         }
8008         return;
8009     }
8010     if (flags & SVp_NOK) {
8011         const NV was = SvNVX(sv);
8012         if (NV_OVERFLOWS_INTEGERS_AT &&
8013             was >= NV_OVERFLOWS_INTEGERS_AT) {
8014             /* diag_listed_as: Lost precision when %s %f by 1 */
8015             Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8016                            "Lost precision when incrementing %" NVff " by 1",
8017                            was);
8018         }
8019         (void)SvNOK_only(sv);
8020         SvNV_set(sv, was + 1.0);
8021         return;
8022     }
8023
8024     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
8025         if ((flags & SVTYPEMASK) < SVt_PVIV)
8026             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
8027         (void)SvIOK_only(sv);
8028         SvIV_set(sv, 1);
8029         return;
8030     }
8031     d = SvPVX(sv);
8032     while (isALPHA(*d)) d++;
8033     while (isDIGIT(*d)) d++;
8034     if (d < SvEND(sv)) {
8035 #ifdef PERL_PRESERVE_IVUV
8036         /* Got to punt this as an integer if needs be, but we don't issue
8037            warnings. Probably ought to make the sv_iv_please() that does
8038            the conversion if possible, and silently.  */
8039         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8040         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8041             /* Need to try really hard to see if it's an integer.
8042                9.22337203685478e+18 is an integer.
8043                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8044                so $a="9.22337203685478e+18"; $a+0; $a++
8045                needs to be the same as $a="9.22337203685478e+18"; $a++
8046                or we go insane. */
8047
8048             (void) sv_2iv(sv);
8049             if (SvIOK(sv))
8050                 goto oops_its_int;
8051
8052             /* sv_2iv *should* have made this an NV */
8053             if (flags & SVp_NOK) {
8054                 (void)SvNOK_only(sv);
8055                 SvNV_set(sv, SvNVX(sv) + 1.0);
8056                 return;
8057             }
8058             /* I don't think we can get here. Maybe I should assert this
8059                And if we do get here I suspect that sv_setnv will croak. NWC
8060                Fall through. */
8061 #if defined(USE_LONG_DOUBLE)
8062             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",
8063                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8064 #else
8065             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8066                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8067 #endif
8068         }
8069 #endif /* PERL_PRESERVE_IVUV */
8070         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
8071         return;
8072     }
8073     d--;
8074     while (d >= SvPVX_const(sv)) {
8075         if (isDIGIT(*d)) {
8076             if (++*d <= '9')
8077                 return;
8078             *(d--) = '0';
8079         }
8080         else {
8081 #ifdef EBCDIC
8082             /* MKS: The original code here died if letters weren't consecutive.
8083              * at least it didn't have to worry about non-C locales.  The
8084              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
8085              * arranged in order (although not consecutively) and that only
8086              * [A-Za-z] are accepted by isALPHA in the C locale.
8087              */
8088             if (*d != 'z' && *d != 'Z') {
8089                 do { ++*d; } while (!isALPHA(*d));
8090                 return;
8091             }
8092             *(d--) -= 'z' - 'a';
8093 #else
8094             ++*d;
8095             if (isALPHA(*d))
8096                 return;
8097             *(d--) -= 'z' - 'a' + 1;
8098 #endif
8099         }
8100     }
8101     /* oh,oh, the number grew */
8102     SvGROW(sv, SvCUR(sv) + 2);
8103     SvCUR_set(sv, SvCUR(sv) + 1);
8104     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
8105         *d = d[-1];
8106     if (isDIGIT(d[1]))
8107         *d = '1';
8108     else
8109         *d = d[1];
8110 }
8111
8112 /*
8113 =for apidoc sv_dec
8114
8115 Auto-decrement of the value in the SV, doing string to numeric conversion
8116 if necessary.  Handles 'get' magic and operator overloading.
8117
8118 =cut
8119 */
8120
8121 void
8122 Perl_sv_dec(pTHX_ register SV *const sv)
8123 {
8124     dVAR;
8125     if (!sv)
8126         return;
8127     SvGETMAGIC(sv);
8128     sv_dec_nomg(sv);
8129 }
8130
8131 /*
8132 =for apidoc sv_dec_nomg
8133
8134 Auto-decrement of the value in the SV, doing string to numeric conversion
8135 if necessary.  Handles operator overloading.  Skips handling 'get' magic.
8136
8137 =cut
8138 */
8139
8140 void
8141 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
8142 {
8143     dVAR;
8144     int flags;
8145
8146     if (!sv)
8147         return;
8148     if (SvTHINKFIRST(sv)) {
8149         if (SvIsCOW(sv) || isGV_with_GP(sv))
8150             sv_force_normal_flags(sv, 0);
8151         if (SvREADONLY(sv)) {
8152             if (IN_PERL_RUNTIME)
8153                 Perl_croak_no_modify(aTHX);
8154         }
8155         if (SvROK(sv)) {
8156             IV i;
8157             if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
8158                 return;
8159             i = PTR2IV(SvRV(sv));
8160             sv_unref(sv);
8161             sv_setiv(sv, i);
8162         }
8163     }
8164     /* Unlike sv_inc we don't have to worry about string-never-numbers
8165        and keeping them magic. But we mustn't warn on punting */
8166     flags = SvFLAGS(sv);
8167     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8168         /* It's publicly an integer, or privately an integer-not-float */
8169 #ifdef PERL_PRESERVE_IVUV
8170       oops_its_int:
8171 #endif
8172         if (SvIsUV(sv)) {
8173             if (SvUVX(sv) == 0) {
8174                 (void)SvIOK_only(sv);
8175                 SvIV_set(sv, -1);
8176             }
8177             else {
8178                 (void)SvIOK_only_UV(sv);
8179                 SvUV_set(sv, SvUVX(sv) - 1);
8180             }
8181         } else {
8182             if (SvIVX(sv) == IV_MIN) {
8183                 sv_setnv(sv, (NV)IV_MIN);
8184                 goto oops_its_num;
8185             }
8186             else {
8187                 (void)SvIOK_only(sv);
8188                 SvIV_set(sv, SvIVX(sv) - 1);
8189             }
8190         }
8191         return;
8192     }
8193     if (flags & SVp_NOK) {
8194     oops_its_num:
8195         {
8196             const NV was = SvNVX(sv);
8197             if (NV_OVERFLOWS_INTEGERS_AT &&
8198                 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8199                 /* diag_listed_as: Lost precision when %s %f by 1 */
8200                 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8201                                "Lost precision when decrementing %" NVff " by 1",
8202                                was);
8203             }
8204             (void)SvNOK_only(sv);
8205             SvNV_set(sv, was - 1.0);
8206             return;
8207         }
8208     }
8209     if (!(flags & SVp_POK)) {
8210         if ((flags & SVTYPEMASK) < SVt_PVIV)
8211             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8212         SvIV_set(sv, -1);
8213         (void)SvIOK_only(sv);
8214         return;
8215     }
8216 #ifdef PERL_PRESERVE_IVUV
8217     {
8218         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8219         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8220             /* Need to try really hard to see if it's an integer.
8221                9.22337203685478e+18 is an integer.
8222                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8223                so $a="9.22337203685478e+18"; $a+0; $a--
8224                needs to be the same as $a="9.22337203685478e+18"; $a--
8225                or we go insane. */
8226
8227             (void) sv_2iv(sv);
8228             if (SvIOK(sv))
8229                 goto oops_its_int;
8230
8231             /* sv_2iv *should* have made this an NV */
8232             if (flags & SVp_NOK) {
8233                 (void)SvNOK_only(sv);
8234                 SvNV_set(sv, SvNVX(sv) - 1.0);
8235                 return;
8236             }
8237             /* I don't think we can get here. Maybe I should assert this
8238                And if we do get here I suspect that sv_setnv will croak. NWC
8239                Fall through. */
8240 #if defined(USE_LONG_DOUBLE)
8241             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",
8242                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8243 #else
8244             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8245                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8246 #endif
8247         }
8248     }
8249 #endif /* PERL_PRESERVE_IVUV */
8250     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);   /* punt */
8251 }
8252
8253 /* this define is used to eliminate a chunk of duplicated but shared logic
8254  * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8255  * used anywhere but here - yves
8256  */
8257 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8258     STMT_START {      \
8259         EXTEND_MORTAL(1); \
8260         PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8261     } STMT_END
8262
8263 /*
8264 =for apidoc sv_mortalcopy
8265
8266 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8267 The new SV is marked as mortal.  It will be destroyed "soon", either by an
8268 explicit call to FREETMPS, or by an implicit call at places such as
8269 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
8270
8271 =cut
8272 */
8273
8274 /* Make a string that will exist for the duration of the expression
8275  * evaluation.  Actually, it may have to last longer than that, but
8276  * hopefully we won't free it until it has been assigned to a
8277  * permanent location. */
8278
8279 SV *
8280 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
8281 {
8282     dVAR;
8283     register SV *sv;
8284
8285     new_SV(sv);
8286     sv_setsv(sv,oldstr);
8287     PUSH_EXTEND_MORTAL__SV_C(sv);
8288     SvTEMP_on(sv);
8289     return sv;
8290 }
8291
8292 /*
8293 =for apidoc sv_newmortal
8294
8295 Creates a new null SV which is mortal.  The reference count of the SV is
8296 set to 1.  It will be destroyed "soon", either by an explicit call to
8297 FREETMPS, or by an implicit call at places such as statement boundaries.
8298 See also C<sv_mortalcopy> and C<sv_2mortal>.
8299
8300 =cut
8301 */
8302
8303 SV *
8304 Perl_sv_newmortal(pTHX)
8305 {
8306     dVAR;
8307     register SV *sv;
8308
8309     new_SV(sv);
8310     SvFLAGS(sv) = SVs_TEMP;
8311     PUSH_EXTEND_MORTAL__SV_C(sv);
8312     return sv;
8313 }
8314
8315
8316 /*
8317 =for apidoc newSVpvn_flags
8318
8319 Creates a new SV and copies a string into it.  The reference count for the
8320 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
8321 string.  You are responsible for ensuring that the source string is at least
8322 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
8323 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8324 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8325 returning.  If C<SVf_UTF8> is set, C<s>
8326 is considered to be in UTF-8 and the
8327 C<SVf_UTF8> flag will be set on the new SV.
8328 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8329
8330     #define newSVpvn_utf8(s, len, u)                    \
8331         newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8332
8333 =cut
8334 */
8335
8336 SV *
8337 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8338 {
8339     dVAR;
8340     register SV *sv;
8341
8342     /* All the flags we don't support must be zero.
8343        And we're new code so I'm going to assert this from the start.  */
8344     assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8345     new_SV(sv);
8346     sv_setpvn(sv,s,len);
8347
8348     /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
8349      * and do what it does ourselves here.
8350      * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
8351      * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8352      * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
8353      * eliminate quite a few steps than it looks - Yves (explaining patch by gfx)
8354      */
8355
8356     SvFLAGS(sv) |= flags;
8357
8358     if(flags & SVs_TEMP){
8359         PUSH_EXTEND_MORTAL__SV_C(sv);
8360     }
8361
8362     return sv;
8363 }
8364
8365 /*
8366 =for apidoc sv_2mortal
8367
8368 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
8369 by an explicit call to FREETMPS, or by an implicit call at places such as
8370 statement boundaries.  SvTEMP() is turned on which means that the SV's
8371 string buffer can be "stolen" if this SV is copied.  See also C<sv_newmortal>
8372 and C<sv_mortalcopy>.
8373
8374 =cut
8375 */
8376
8377 SV *
8378 Perl_sv_2mortal(pTHX_ register SV *const sv)
8379 {
8380     dVAR;
8381     if (!sv)
8382         return NULL;
8383     if (SvREADONLY(sv) && SvIMMORTAL(sv))
8384         return sv;
8385     PUSH_EXTEND_MORTAL__SV_C(sv);
8386     SvTEMP_on(sv);
8387     return sv;
8388 }
8389
8390 /*
8391 =for apidoc newSVpv
8392
8393 Creates a new SV and copies a string into it.  The reference count for the
8394 SV is set to 1.  If C<len> is zero, Perl will compute the length using
8395 strlen().  For efficiency, consider using C<newSVpvn> instead.
8396
8397 =cut
8398 */
8399
8400 SV *
8401 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8402 {
8403     dVAR;
8404     register SV *sv;
8405
8406     new_SV(sv);
8407     sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8408     return sv;
8409 }
8410
8411 /*
8412 =for apidoc newSVpvn
8413
8414 Creates a new SV and copies a buffer into it, which may contain NUL characters
8415 (C<\0>) and other binary data.  The reference count for the SV is set to 1.
8416 Note that if C<len> is zero, Perl will create a zero length (Perl) string.  You
8417 are responsible for ensuring that the source buffer is at least
8418 C<len> bytes long.  If the C<buffer> argument is NULL the new SV will be
8419 undefined.
8420
8421 =cut
8422 */
8423
8424 SV *
8425 Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
8426 {
8427     dVAR;
8428     register SV *sv;
8429
8430     new_SV(sv);
8431     sv_setpvn(sv,buffer,len);
8432     return sv;
8433 }
8434
8435 /*
8436 =for apidoc newSVhek
8437
8438 Creates a new SV from the hash key structure.  It will generate scalars that
8439 point to the shared string table where possible.  Returns a new (undefined)
8440 SV if the hek is NULL.
8441
8442 =cut
8443 */
8444
8445 SV *
8446 Perl_newSVhek(pTHX_ const HEK *const hek)
8447 {
8448     dVAR;
8449     if (!hek) {
8450         SV *sv;
8451
8452         new_SV(sv);
8453         return sv;
8454     }
8455
8456     if (HEK_LEN(hek) == HEf_SVKEY) {
8457         return newSVsv(*(SV**)HEK_KEY(hek));
8458     } else {
8459         const int flags = HEK_FLAGS(hek);
8460         if (flags & HVhek_WASUTF8) {
8461             /* Trouble :-)
8462                Andreas would like keys he put in as utf8 to come back as utf8
8463             */
8464             STRLEN utf8_len = HEK_LEN(hek);
8465             SV * const sv = newSV_type(SVt_PV);
8466             char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8467             /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8468             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8469             SvUTF8_on (sv);
8470             return sv;
8471         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
8472             /* We don't have a pointer to the hv, so we have to replicate the
8473                flag into every HEK. This hv is using custom a hasing
8474                algorithm. Hence we can't return a shared string scalar, as
8475                that would contain the (wrong) hash value, and might get passed
8476                into an hv routine with a regular hash.
8477                Similarly, a hash that isn't using shared hash keys has to have
8478                the flag in every key so that we know not to try to call
8479                share_hek_hek on it.  */
8480
8481             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8482             if (HEK_UTF8(hek))
8483                 SvUTF8_on (sv);
8484             return sv;
8485         }
8486         /* This will be overwhelminly the most common case.  */
8487         {
8488             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8489                more efficient than sharepvn().  */
8490             SV *sv;
8491
8492             new_SV(sv);
8493             sv_upgrade(sv, SVt_PV);
8494             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8495             SvCUR_set(sv, HEK_LEN(hek));
8496             SvLEN_set(sv, 0);
8497             SvREADONLY_on(sv);
8498             SvFAKE_on(sv);
8499             SvPOK_on(sv);
8500             if (HEK_UTF8(hek))
8501                 SvUTF8_on(sv);
8502             return sv;
8503         }
8504     }
8505 }
8506
8507 /*
8508 =for apidoc newSVpvn_share
8509
8510 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8511 table.  If the string does not already exist in the table, it is
8512 created first.  Turns on READONLY and FAKE.  If the C<hash> parameter
8513 is non-zero, that value is used; otherwise the hash is computed.
8514 The string's hash can later be retrieved from the SV
8515 with the C<SvSHARED_HASH()> macro.  The idea here is
8516 that as the string table is used for shared hash keys these strings will have
8517 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8518
8519 =cut
8520 */
8521
8522 SV *
8523 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8524 {
8525     dVAR;
8526     register SV *sv;
8527     bool is_utf8 = FALSE;
8528     const char *const orig_src = src;
8529
8530     if (len < 0) {
8531         STRLEN tmplen = -len;
8532         is_utf8 = TRUE;
8533         /* See the note in hv.c:hv_fetch() --jhi */
8534         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8535         len = tmplen;
8536     }
8537     if (!hash)
8538         PERL_HASH(hash, src, len);
8539     new_SV(sv);
8540     /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8541        changes here, update it there too.  */
8542     sv_upgrade(sv, SVt_PV);
8543     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8544     SvCUR_set(sv, len);
8545     SvLEN_set(sv, 0);
8546     SvREADONLY_on(sv);
8547     SvFAKE_on(sv);
8548     SvPOK_on(sv);
8549     if (is_utf8)
8550         SvUTF8_on(sv);
8551     if (src != orig_src)
8552         Safefree(src);
8553     return sv;
8554 }
8555
8556 /*
8557 =for apidoc newSVpv_share
8558
8559 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8560 string/length pair.
8561
8562 =cut
8563 */
8564
8565 SV *
8566 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8567 {
8568     return newSVpvn_share(src, strlen(src), hash);
8569 }
8570
8571 #if defined(PERL_IMPLICIT_CONTEXT)
8572
8573 /* pTHX_ magic can't cope with varargs, so this is a no-context
8574  * version of the main function, (which may itself be aliased to us).
8575  * Don't access this version directly.
8576  */
8577
8578 SV *
8579 Perl_newSVpvf_nocontext(const char *const pat, ...)
8580 {
8581     dTHX;
8582     register SV *sv;
8583     va_list args;
8584
8585     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8586
8587     va_start(args, pat);
8588     sv = vnewSVpvf(pat, &args);
8589     va_end(args);
8590     return sv;
8591 }
8592 #endif
8593
8594 /*
8595 =for apidoc newSVpvf
8596
8597 Creates a new SV and initializes it with the string formatted like
8598 C<sprintf>.
8599
8600 =cut
8601 */
8602
8603 SV *
8604 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8605 {
8606     register SV *sv;
8607     va_list args;
8608
8609     PERL_ARGS_ASSERT_NEWSVPVF;
8610
8611     va_start(args, pat);
8612     sv = vnewSVpvf(pat, &args);
8613     va_end(args);
8614     return sv;
8615 }
8616
8617 /* backend for newSVpvf() and newSVpvf_nocontext() */
8618
8619 SV *
8620 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8621 {
8622     dVAR;
8623     register SV *sv;
8624
8625     PERL_ARGS_ASSERT_VNEWSVPVF;
8626
8627     new_SV(sv);
8628     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8629     return sv;
8630 }
8631
8632 /*
8633 =for apidoc newSVnv
8634
8635 Creates a new SV and copies a floating point value into it.
8636 The reference count for the SV is set to 1.
8637
8638 =cut
8639 */
8640
8641 SV *
8642 Perl_newSVnv(pTHX_ const NV n)
8643 {
8644     dVAR;
8645     register SV *sv;
8646
8647     new_SV(sv);
8648     sv_setnv(sv,n);
8649     return sv;
8650 }
8651
8652 /*
8653 =for apidoc newSViv
8654
8655 Creates a new SV and copies an integer into it.  The reference count for the
8656 SV is set to 1.
8657
8658 =cut
8659 */
8660
8661 SV *
8662 Perl_newSViv(pTHX_ const IV i)
8663 {
8664     dVAR;
8665     register SV *sv;
8666
8667     new_SV(sv);
8668     sv_setiv(sv,i);
8669     return sv;
8670 }
8671
8672 /*
8673 =for apidoc newSVuv
8674
8675 Creates a new SV and copies an unsigned integer into it.
8676 The reference count for the SV is set to 1.
8677
8678 =cut
8679 */
8680
8681 SV *
8682 Perl_newSVuv(pTHX_ const UV u)
8683 {
8684     dVAR;
8685     register SV *sv;
8686
8687     new_SV(sv);
8688     sv_setuv(sv,u);
8689     return sv;
8690 }
8691
8692 /*
8693 =for apidoc newSV_type
8694
8695 Creates a new SV, of the type specified.  The reference count for the new SV
8696 is set to 1.
8697
8698 =cut
8699 */
8700
8701 SV *
8702 Perl_newSV_type(pTHX_ const svtype type)
8703 {
8704     register SV *sv;
8705
8706     new_SV(sv);
8707     sv_upgrade(sv, type);
8708     return sv;
8709 }
8710
8711 /*
8712 =for apidoc newRV_noinc
8713
8714 Creates an RV wrapper for an SV.  The reference count for the original
8715 SV is B<not> incremented.
8716
8717 =cut
8718 */
8719
8720 SV *
8721 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8722 {
8723     dVAR;
8724     register SV *sv = newSV_type(SVt_IV);
8725
8726     PERL_ARGS_ASSERT_NEWRV_NOINC;
8727
8728     SvTEMP_off(tmpRef);
8729     SvRV_set(sv, tmpRef);
8730     SvROK_on(sv);
8731     return sv;
8732 }
8733
8734 /* newRV_inc is the official function name to use now.
8735  * newRV_inc is in fact #defined to newRV in sv.h
8736  */
8737
8738 SV *
8739 Perl_newRV(pTHX_ SV *const sv)
8740 {
8741     dVAR;
8742
8743     PERL_ARGS_ASSERT_NEWRV;
8744
8745     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8746 }
8747
8748 /*
8749 =for apidoc newSVsv
8750
8751 Creates a new SV which is an exact duplicate of the original SV.
8752 (Uses C<sv_setsv>.)
8753
8754 =cut
8755 */
8756
8757 SV *
8758 Perl_newSVsv(pTHX_ register SV *const old)
8759 {
8760     dVAR;
8761     register SV *sv;
8762
8763     if (!old)
8764         return NULL;
8765     if (SvTYPE(old) == (svtype)SVTYPEMASK) {
8766         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8767         return NULL;
8768     }
8769     new_SV(sv);
8770     /* SV_GMAGIC is the default for sv_setv()
8771        SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8772        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
8773     sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8774     return sv;
8775 }
8776
8777 /*
8778 =for apidoc sv_reset
8779
8780 Underlying implementation for the C<reset> Perl function.
8781 Note that the perl-level function is vaguely deprecated.
8782
8783 =cut
8784 */
8785
8786 void
8787 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8788 {
8789     dVAR;
8790     char todo[PERL_UCHAR_MAX+1];
8791
8792     PERL_ARGS_ASSERT_SV_RESET;
8793
8794     if (!stash)
8795         return;
8796
8797     if (!*s) {          /* reset ?? searches */
8798         MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8799         if (mg) {
8800             const U32 count = mg->mg_len / sizeof(PMOP**);
8801             PMOP **pmp = (PMOP**) mg->mg_ptr;
8802             PMOP *const *const end = pmp + count;
8803
8804             while (pmp < end) {
8805 #ifdef USE_ITHREADS
8806                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8807 #else
8808                 (*pmp)->op_pmflags &= ~PMf_USED;
8809 #endif
8810                 ++pmp;
8811             }
8812         }
8813         return;
8814     }
8815
8816     /* reset variables */
8817
8818     if (!HvARRAY(stash))
8819         return;
8820
8821     Zero(todo, 256, char);
8822     while (*s) {
8823         I32 max;
8824         I32 i = (unsigned char)*s;
8825         if (s[1] == '-') {
8826             s += 2;
8827         }
8828         max = (unsigned char)*s++;
8829         for ( ; i <= max; i++) {
8830             todo[i] = 1;
8831         }
8832         for (i = 0; i <= (I32) HvMAX(stash); i++) {
8833             HE *entry;
8834             for (entry = HvARRAY(stash)[i];
8835                  entry;
8836                  entry = HeNEXT(entry))
8837             {
8838                 register GV *gv;
8839                 register SV *sv;
8840
8841                 if (!todo[(U8)*HeKEY(entry)])
8842                     continue;
8843                 gv = MUTABLE_GV(HeVAL(entry));
8844                 sv = GvSV(gv);
8845                 if (sv) {
8846                     if (SvTHINKFIRST(sv)) {
8847                         if (!SvREADONLY(sv) && SvROK(sv))
8848                             sv_unref(sv);
8849                         /* XXX Is this continue a bug? Why should THINKFIRST
8850                            exempt us from resetting arrays and hashes?  */
8851                         continue;
8852                     }
8853                     SvOK_off(sv);
8854                     if (SvTYPE(sv) >= SVt_PV) {
8855                         SvCUR_set(sv, 0);
8856                         if (SvPVX_const(sv) != NULL)
8857                             *SvPVX(sv) = '\0';
8858                         SvTAINT(sv);
8859                     }
8860                 }
8861                 if (GvAV(gv)) {
8862                     av_clear(GvAV(gv));
8863                 }
8864                 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8865 #if defined(VMS)
8866                     Perl_die(aTHX_ "Can't reset %%ENV on this system");
8867 #else /* ! VMS */
8868                     hv_clear(GvHV(gv));
8869 #  if defined(USE_ENVIRON_ARRAY)
8870                     if (gv == PL_envgv)
8871                         my_clearenv();
8872 #  endif /* USE_ENVIRON_ARRAY */
8873 #endif /* VMS */
8874                 }
8875             }
8876         }
8877     }
8878 }
8879
8880 /*
8881 =for apidoc sv_2io
8882
8883 Using various gambits, try to get an IO from an SV: the IO slot if its a
8884 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8885 named after the PV if we're a string.
8886
8887 'Get' magic is ignored on the sv passed in, but will be called on
8888 C<SvRV(sv)> if sv is an RV.
8889
8890 =cut
8891 */
8892
8893 IO*
8894 Perl_sv_2io(pTHX_ SV *const sv)
8895 {
8896     IO* io;
8897     GV* gv;
8898
8899     PERL_ARGS_ASSERT_SV_2IO;
8900
8901     switch (SvTYPE(sv)) {
8902     case SVt_PVIO:
8903         io = MUTABLE_IO(sv);
8904         break;
8905     case SVt_PVGV:
8906     case SVt_PVLV:
8907         if (isGV_with_GP(sv)) {
8908             gv = MUTABLE_GV(sv);
8909             io = GvIO(gv);
8910             if (!io)
8911                 Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
8912                                     HEKfARG(GvNAME_HEK(gv)));
8913             break;
8914         }
8915         /* FALL THROUGH */
8916     default:
8917         if (!SvOK(sv))
8918             Perl_croak(aTHX_ PL_no_usym, "filehandle");
8919         if (SvROK(sv)) {
8920             SvGETMAGIC(SvRV(sv));
8921             return sv_2io(SvRV(sv));
8922         }
8923         gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
8924         if (gv)
8925             io = GvIO(gv);
8926         else
8927             io = 0;
8928         if (!io) {
8929             SV *newsv = sv;
8930             if (SvGMAGICAL(sv)) {
8931                 newsv = sv_newmortal();
8932                 sv_setsv_nomg(newsv, sv);
8933             }
8934             Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv));
8935         }
8936         break;
8937     }
8938     return io;
8939 }
8940
8941 /*
8942 =for apidoc sv_2cv
8943
8944 Using various gambits, try to get a CV from an SV; in addition, try if
8945 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8946 The flags in C<lref> are passed to gv_fetchsv.
8947
8948 =cut
8949 */
8950
8951 CV *
8952 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8953 {
8954     dVAR;
8955     GV *gv = NULL;
8956     CV *cv = NULL;
8957
8958     PERL_ARGS_ASSERT_SV_2CV;
8959
8960     if (!sv) {
8961         *st = NULL;
8962         *gvp = NULL;
8963         return NULL;
8964     }
8965     switch (SvTYPE(sv)) {
8966     case SVt_PVCV:
8967         *st = CvSTASH(sv);
8968         *gvp = NULL;
8969         return MUTABLE_CV(sv);
8970     case SVt_PVHV:
8971     case SVt_PVAV:
8972         *st = NULL;
8973         *gvp = NULL;
8974         return NULL;
8975     default:
8976         SvGETMAGIC(sv);
8977         if (SvROK(sv)) {
8978             if (SvAMAGIC(sv))
8979                 sv = amagic_deref_call(sv, to_cv_amg);
8980
8981             sv = SvRV(sv);
8982             if (SvTYPE(sv) == SVt_PVCV) {
8983                 cv = MUTABLE_CV(sv);
8984                 *gvp = NULL;
8985                 *st = CvSTASH(cv);
8986                 return cv;
8987             }
8988             else if(SvGETMAGIC(sv), isGV_with_GP(sv))
8989                 gv = MUTABLE_GV(sv);
8990             else
8991                 Perl_croak(aTHX_ "Not a subroutine reference");
8992         }
8993         else if (isGV_with_GP(sv)) {
8994             gv = MUTABLE_GV(sv);
8995         }
8996         else {
8997             gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
8998         }
8999         *gvp = gv;
9000         if (!gv) {
9001             *st = NULL;
9002             return NULL;
9003         }
9004         /* Some flags to gv_fetchsv mean don't really create the GV  */
9005         if (!isGV_with_GP(gv)) {
9006             *st = NULL;
9007             return NULL;
9008         }
9009         *st = GvESTASH(gv);
9010         if (lref & ~GV_ADDMG && !GvCVu(gv)) {
9011             SV *tmpsv;
9012             ENTER;
9013             tmpsv = newSV(0);
9014             gv_efullname3(tmpsv, gv, NULL);
9015             /* XXX this is probably not what they think they're getting.
9016              * It has the same effect as "sub name;", i.e. just a forward
9017              * declaration! */
9018             newSUB(start_subparse(FALSE, 0),
9019                    newSVOP(OP_CONST, 0, tmpsv),
9020                    NULL, NULL);
9021             LEAVE;
9022             if (!GvCVu(gv))
9023                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
9024                            SVfARG(SvOK(sv) ? sv : &PL_sv_no));
9025         }
9026         return GvCVu(gv);
9027     }
9028 }
9029
9030 /*
9031 =for apidoc sv_true
9032
9033 Returns true if the SV has a true value by Perl's rules.
9034 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
9035 instead use an in-line version.
9036
9037 =cut
9038 */
9039
9040 I32
9041 Perl_sv_true(pTHX_ register SV *const sv)
9042 {
9043     if (!sv)
9044         return 0;
9045     if (SvPOK(sv)) {
9046         register const XPV* const tXpv = (XPV*)SvANY(sv);
9047         if (tXpv &&
9048                 (tXpv->xpv_cur > 1 ||
9049                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
9050             return 1;
9051         else
9052             return 0;
9053     }
9054     else {
9055         if (SvIOK(sv))
9056             return SvIVX(sv) != 0;
9057         else {
9058             if (SvNOK(sv))
9059                 return SvNVX(sv) != 0.0;
9060             else
9061                 return sv_2bool(sv);
9062         }
9063     }
9064 }
9065
9066 /*
9067 =for apidoc sv_pvn_force
9068
9069 Get a sensible string out of the SV somehow.
9070 A private implementation of the C<SvPV_force> macro for compilers which
9071 can't cope with complex macro expressions.  Always use the macro instead.
9072
9073 =for apidoc sv_pvn_force_flags
9074
9075 Get a sensible string out of the SV somehow.
9076 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
9077 appropriate, else not.  C<sv_pvn_force> and C<sv_pvn_force_nomg> are
9078 implemented in terms of this function.
9079 You normally want to use the various wrapper macros instead: see
9080 C<SvPV_force> and C<SvPV_force_nomg>
9081
9082 =cut
9083 */
9084
9085 char *
9086 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
9087 {
9088     dVAR;
9089
9090     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
9091
9092     if (flags & SV_GMAGIC) SvGETMAGIC(sv);
9093     if (SvTHINKFIRST(sv) && !SvROK(sv))
9094         sv_force_normal_flags(sv, 0);
9095
9096     if (SvPOK(sv)) {
9097         if (lp)
9098             *lp = SvCUR(sv);
9099     }
9100     else {
9101         char *s;
9102         STRLEN len;
9103
9104         if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
9105             const char * const ref = sv_reftype(sv,0);
9106             if (PL_op)
9107                 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
9108                            ref, OP_DESC(PL_op));
9109             else
9110                 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
9111         }
9112         if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
9113             || isGV_with_GP(sv))
9114             /* diag_listed_as: Can't coerce %s to %s in %s */
9115             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
9116                 OP_DESC(PL_op));
9117         s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
9118         if (lp)
9119             *lp = len;
9120
9121         if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
9122             if (SvROK(sv))
9123                 sv_unref(sv);
9124             SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
9125             SvGROW(sv, len + 1);
9126             Move(s,SvPVX(sv),len,char);
9127             SvCUR_set(sv, len);
9128             SvPVX(sv)[len] = '\0';
9129         }
9130         if (!SvPOK(sv)) {
9131             SvPOK_on(sv);               /* validate pointer */
9132             SvTAINT(sv);
9133             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
9134                                   PTR2UV(sv),SvPVX_const(sv)));
9135         }
9136     }
9137     return SvPVX_mutable(sv);
9138 }
9139
9140 /*
9141 =for apidoc sv_pvbyten_force
9142
9143 The backend for the C<SvPVbytex_force> macro.  Always use the macro
9144 instead.
9145
9146 =cut
9147 */
9148
9149 char *
9150 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
9151 {
9152     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
9153
9154     sv_pvn_force(sv,lp);
9155     sv_utf8_downgrade(sv,0);
9156     *lp = SvCUR(sv);
9157     return SvPVX(sv);
9158 }
9159
9160 /*
9161 =for apidoc sv_pvutf8n_force
9162
9163 The backend for the C<SvPVutf8x_force> macro.  Always use the macro
9164 instead.
9165
9166 =cut
9167 */
9168
9169 char *
9170 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9171 {
9172     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9173
9174     sv_pvn_force(sv,lp);
9175     sv_utf8_upgrade(sv);
9176     *lp = SvCUR(sv);
9177     return SvPVX(sv);
9178 }
9179
9180 /*
9181 =for apidoc sv_reftype
9182
9183 Returns a string describing what the SV is a reference to.
9184
9185 =cut
9186 */
9187
9188 const char *
9189 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9190 {
9191     PERL_ARGS_ASSERT_SV_REFTYPE;
9192     if (ob && SvOBJECT(sv)) {
9193         return SvPV_nolen_const(sv_ref(NULL, sv, ob));
9194     }
9195     else {
9196         switch (SvTYPE(sv)) {
9197         case SVt_NULL:
9198         case SVt_IV:
9199         case SVt_NV:
9200         case SVt_PV:
9201         case SVt_PVIV:
9202         case SVt_PVNV:
9203         case SVt_PVMG:
9204                                 if (SvVOK(sv))
9205                                     return "VSTRING";
9206                                 if (SvROK(sv))
9207                                     return "REF";
9208                                 else
9209                                     return "SCALAR";
9210
9211         case SVt_PVLV:          return (char *)  (SvROK(sv) ? "REF"
9212                                 /* tied lvalues should appear to be
9213                                  * scalars for backwards compatibility */
9214                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9215                                     ? "SCALAR" : "LVALUE");
9216         case SVt_PVAV:          return "ARRAY";
9217         case SVt_PVHV:          return "HASH";
9218         case SVt_PVCV:          return "CODE";
9219         case SVt_PVGV:          return (char *) (isGV_with_GP(sv)
9220                                     ? "GLOB" : "SCALAR");
9221         case SVt_PVFM:          return "FORMAT";
9222         case SVt_PVIO:          return "IO";
9223         case SVt_BIND:          return "BIND";
9224         case SVt_REGEXP:        return "REGEXP";
9225         default:                return "UNKNOWN";
9226         }
9227     }
9228 }
9229
9230 /*
9231 =for apidoc sv_ref
9232
9233 Returns a SV describing what the SV passed in is a reference to.
9234
9235 =cut
9236 */
9237
9238 SV *
9239 Perl_sv_ref(pTHX_ register SV *dst, const SV *const sv, const int ob)
9240 {
9241     PERL_ARGS_ASSERT_SV_REF;
9242
9243     if (!dst)
9244         dst = sv_newmortal();
9245
9246     if (ob && SvOBJECT(sv)) {
9247         HvNAME_get(SvSTASH(sv))
9248                     ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
9249                     : sv_setpvn(dst, "__ANON__", 8);
9250     }
9251     else {
9252         const char * reftype = sv_reftype(sv, 0);
9253         sv_setpv(dst, reftype);
9254     }
9255     return dst;
9256 }
9257
9258 /*
9259 =for apidoc sv_isobject
9260
9261 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9262 object.  If the SV is not an RV, or if the object is not blessed, then this
9263 will return false.
9264
9265 =cut
9266 */
9267
9268 int
9269 Perl_sv_isobject(pTHX_ SV *sv)
9270 {
9271     if (!sv)
9272         return 0;
9273     SvGETMAGIC(sv);
9274     if (!SvROK(sv))
9275         return 0;
9276     sv = SvRV(sv);
9277     if (!SvOBJECT(sv))
9278         return 0;
9279     return 1;
9280 }
9281
9282 /*
9283 =for apidoc sv_isa
9284
9285 Returns a boolean indicating whether the SV is blessed into the specified
9286 class.  This does not check for subtypes; use C<sv_derived_from> to verify
9287 an inheritance relationship.
9288
9289 =cut
9290 */
9291
9292 int
9293 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9294 {
9295     const char *hvname;
9296
9297     PERL_ARGS_ASSERT_SV_ISA;
9298
9299     if (!sv)
9300         return 0;
9301     SvGETMAGIC(sv);
9302     if (!SvROK(sv))
9303         return 0;
9304     sv = SvRV(sv);
9305     if (!SvOBJECT(sv))
9306         return 0;
9307     hvname = HvNAME_get(SvSTASH(sv));
9308     if (!hvname)
9309         return 0;
9310
9311     return strEQ(hvname, name);
9312 }
9313
9314 /*
9315 =for apidoc newSVrv
9316
9317 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
9318 it will be upgraded to one.  If C<classname> is non-null then the new SV will
9319 be blessed in the specified package.  The new SV is returned and its
9320 reference count is 1.
9321
9322 =cut
9323 */
9324
9325 SV*
9326 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9327 {
9328     dVAR;
9329     SV *sv;
9330
9331     PERL_ARGS_ASSERT_NEWSVRV;
9332
9333     new_SV(sv);
9334
9335     SV_CHECK_THINKFIRST_COW_DROP(rv);
9336     (void)SvAMAGIC_off(rv);
9337
9338     if (SvTYPE(rv) >= SVt_PVMG) {
9339         const U32 refcnt = SvREFCNT(rv);
9340         SvREFCNT(rv) = 0;
9341         sv_clear(rv);
9342         SvFLAGS(rv) = 0;
9343         SvREFCNT(rv) = refcnt;
9344
9345         sv_upgrade(rv, SVt_IV);
9346     } else if (SvROK(rv)) {
9347         SvREFCNT_dec(SvRV(rv));
9348     } else {
9349         prepare_SV_for_RV(rv);
9350     }
9351
9352     SvOK_off(rv);
9353     SvRV_set(rv, sv);
9354     SvROK_on(rv);
9355
9356     if (classname) {
9357         HV* const stash = gv_stashpv(classname, GV_ADD);
9358         (void)sv_bless(rv, stash);
9359     }
9360     return sv;
9361 }
9362
9363 /*
9364 =for apidoc sv_setref_pv
9365
9366 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
9367 argument will be upgraded to an RV.  That RV will be modified to point to
9368 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9369 into the SV.  The C<classname> argument indicates the package for the
9370 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9371 will have a reference count of 1, and the RV will be returned.
9372
9373 Do not use with other Perl types such as HV, AV, SV, CV, because those
9374 objects will become corrupted by the pointer copy process.
9375
9376 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9377
9378 =cut
9379 */
9380
9381 SV*
9382 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9383 {
9384     dVAR;
9385
9386     PERL_ARGS_ASSERT_SV_SETREF_PV;
9387
9388     if (!pv) {
9389         sv_setsv(rv, &PL_sv_undef);
9390         SvSETMAGIC(rv);
9391     }
9392     else
9393         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9394     return rv;
9395 }
9396
9397 /*
9398 =for apidoc sv_setref_iv
9399
9400 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
9401 argument will be upgraded to an RV.  That RV will be modified to point to
9402 the new SV.  The C<classname> argument indicates the package for the
9403 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9404 will have a reference count of 1, and the RV will be returned.
9405
9406 =cut
9407 */
9408
9409 SV*
9410 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9411 {
9412     PERL_ARGS_ASSERT_SV_SETREF_IV;
9413
9414     sv_setiv(newSVrv(rv,classname), iv);
9415     return rv;
9416 }
9417
9418 /*
9419 =for apidoc sv_setref_uv
9420
9421 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
9422 argument will be upgraded to an RV.  That RV will be modified to point to
9423 the new SV.  The C<classname> argument indicates the package for the
9424 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9425 will have a reference count of 1, and the RV will be returned.
9426
9427 =cut
9428 */
9429
9430 SV*
9431 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9432 {
9433     PERL_ARGS_ASSERT_SV_SETREF_UV;
9434
9435     sv_setuv(newSVrv(rv,classname), uv);
9436     return rv;
9437 }
9438
9439 /*
9440 =for apidoc sv_setref_nv
9441
9442 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
9443 argument will be upgraded to an RV.  That RV will be modified to point to
9444 the new SV.  The C<classname> argument indicates the package for the
9445 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9446 will have a reference count of 1, and the RV will be returned.
9447
9448 =cut
9449 */
9450
9451 SV*
9452 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9453 {
9454     PERL_ARGS_ASSERT_SV_SETREF_NV;
9455
9456     sv_setnv(newSVrv(rv,classname), nv);
9457     return rv;
9458 }
9459
9460 /*
9461 =for apidoc sv_setref_pvn
9462
9463 Copies a string into a new SV, optionally blessing the SV.  The length of the
9464 string must be specified with C<n>.  The C<rv> argument will be upgraded to
9465 an RV.  That RV will be modified to point to the new SV.  The C<classname>
9466 argument indicates the package for the blessing.  Set C<classname> to
9467 C<NULL> to avoid the blessing.  The new SV will have a reference count
9468 of 1, and the RV will be returned.
9469
9470 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9471
9472 =cut
9473 */
9474
9475 SV*
9476 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9477                    const char *const pv, const STRLEN n)
9478 {
9479     PERL_ARGS_ASSERT_SV_SETREF_PVN;
9480
9481     sv_setpvn(newSVrv(rv,classname), pv, n);
9482     return rv;
9483 }
9484
9485 /*
9486 =for apidoc sv_bless
9487
9488 Blesses an SV into a specified package.  The SV must be an RV.  The package
9489 must be designated by its stash (see C<gv_stashpv()>).  The reference count
9490 of the SV is unaffected.
9491
9492 =cut
9493 */
9494
9495 SV*
9496 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9497 {
9498     dVAR;
9499     SV *tmpRef;
9500
9501     PERL_ARGS_ASSERT_SV_BLESS;
9502
9503     if (!SvROK(sv))
9504         Perl_croak(aTHX_ "Can't bless non-reference value");
9505     tmpRef = SvRV(sv);
9506     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9507         if (SvIsCOW(tmpRef))
9508             sv_force_normal_flags(tmpRef, 0);
9509         if (SvREADONLY(tmpRef))
9510             Perl_croak_no_modify(aTHX);
9511         if (SvOBJECT(tmpRef)) {
9512             if (SvTYPE(tmpRef) != SVt_PVIO)
9513                 --PL_sv_objcount;
9514             SvREFCNT_dec(SvSTASH(tmpRef));
9515         }
9516     }
9517     SvOBJECT_on(tmpRef);
9518     if (SvTYPE(tmpRef) != SVt_PVIO)
9519         ++PL_sv_objcount;
9520     SvUPGRADE(tmpRef, SVt_PVMG);
9521     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9522
9523     if (Gv_AMG(stash))
9524         SvAMAGIC_on(sv);
9525     else
9526         (void)SvAMAGIC_off(sv);
9527
9528     if(SvSMAGICAL(tmpRef))
9529         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9530             mg_set(tmpRef);
9531
9532
9533
9534     return sv;
9535 }
9536
9537 /* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
9538  * as it is after unglobbing it.
9539  */
9540
9541 PERL_STATIC_INLINE void
9542 S_sv_unglob(pTHX_ SV *const sv, U32 flags)
9543 {
9544     dVAR;
9545     void *xpvmg;
9546     HV *stash;
9547     SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
9548
9549     PERL_ARGS_ASSERT_SV_UNGLOB;
9550
9551     assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9552     SvFAKE_off(sv);
9553     if (!(flags & SV_COW_DROP_PV))
9554         gv_efullname3(temp, MUTABLE_GV(sv), "*");
9555
9556     if (GvGP(sv)) {
9557         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9558            && HvNAME_get(stash))
9559             mro_method_changed_in(stash);
9560         gp_free(MUTABLE_GV(sv));
9561     }
9562     if (GvSTASH(sv)) {
9563         sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9564         GvSTASH(sv) = NULL;
9565     }
9566     GvMULTI_off(sv);
9567     if (GvNAME_HEK(sv)) {
9568         unshare_hek(GvNAME_HEK(sv));
9569     }
9570     isGV_with_GP_off(sv);
9571
9572     if(SvTYPE(sv) == SVt_PVGV) {
9573         /* need to keep SvANY(sv) in the right arena */
9574         xpvmg = new_XPVMG();
9575         StructCopy(SvANY(sv), xpvmg, XPVMG);
9576         del_XPVGV(SvANY(sv));
9577         SvANY(sv) = xpvmg;
9578
9579         SvFLAGS(sv) &= ~SVTYPEMASK;
9580         SvFLAGS(sv) |= SVt_PVMG;
9581     }
9582
9583     /* Intentionally not calling any local SET magic, as this isn't so much a
9584        set operation as merely an internal storage change.  */
9585     if (flags & SV_COW_DROP_PV) SvOK_off(sv);
9586     else sv_setsv_flags(sv, temp, 0);
9587
9588     if ((const GV *)sv == PL_last_in_gv)
9589         PL_last_in_gv = NULL;
9590     else if ((const GV *)sv == PL_statgv)
9591         PL_statgv = NULL;
9592 }
9593
9594 /*
9595 =for apidoc sv_unref_flags
9596
9597 Unsets the RV status of the SV, and decrements the reference count of
9598 whatever was being referenced by the RV.  This can almost be thought of
9599 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
9600 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9601 (otherwise the decrementing is conditional on the reference count being
9602 different from one or the reference being a readonly SV).
9603 See C<SvROK_off>.
9604
9605 =cut
9606 */
9607
9608 void
9609 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9610 {
9611     SV* const target = SvRV(ref);
9612
9613     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9614
9615     if (SvWEAKREF(ref)) {
9616         sv_del_backref(target, ref);
9617         SvWEAKREF_off(ref);
9618         SvRV_set(ref, NULL);
9619         return;
9620     }
9621     SvRV_set(ref, NULL);
9622     SvROK_off(ref);
9623     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9624        assigned to as BEGIN {$a = \"Foo"} will fail.  */
9625     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9626         SvREFCNT_dec(target);
9627     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9628         sv_2mortal(target);     /* Schedule for freeing later */
9629 }
9630
9631 /*
9632 =for apidoc sv_untaint
9633
9634 Untaint an SV.  Use C<SvTAINTED_off> instead.
9635
9636 =cut
9637 */
9638
9639 void
9640 Perl_sv_untaint(pTHX_ SV *const sv)
9641 {
9642     PERL_ARGS_ASSERT_SV_UNTAINT;
9643
9644     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9645         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9646         if (mg)
9647             mg->mg_len &= ~1;
9648     }
9649 }
9650
9651 /*
9652 =for apidoc sv_tainted
9653
9654 Test an SV for taintedness.  Use C<SvTAINTED> instead.
9655
9656 =cut
9657 */
9658
9659 bool
9660 Perl_sv_tainted(pTHX_ SV *const sv)
9661 {
9662     PERL_ARGS_ASSERT_SV_TAINTED;
9663
9664     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9665         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9666         if (mg && (mg->mg_len & 1) )
9667             return TRUE;
9668     }
9669     return FALSE;
9670 }
9671
9672 /*
9673 =for apidoc sv_setpviv
9674
9675 Copies an integer into the given SV, also updating its string value.
9676 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
9677
9678 =cut
9679 */
9680
9681 void
9682 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9683 {
9684     char buf[TYPE_CHARS(UV)];
9685     char *ebuf;
9686     char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9687
9688     PERL_ARGS_ASSERT_SV_SETPVIV;
9689
9690     sv_setpvn(sv, ptr, ebuf - ptr);
9691 }
9692
9693 /*
9694 =for apidoc sv_setpviv_mg
9695
9696 Like C<sv_setpviv>, but also handles 'set' magic.
9697
9698 =cut
9699 */
9700
9701 void
9702 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9703 {
9704     PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9705
9706     sv_setpviv(sv, iv);
9707     SvSETMAGIC(sv);
9708 }
9709
9710 #if defined(PERL_IMPLICIT_CONTEXT)
9711
9712 /* pTHX_ magic can't cope with varargs, so this is a no-context
9713  * version of the main function, (which may itself be aliased to us).
9714  * Don't access this version directly.
9715  */
9716
9717 void
9718 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9719 {
9720     dTHX;
9721     va_list args;
9722
9723     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9724
9725     va_start(args, pat);
9726     sv_vsetpvf(sv, pat, &args);
9727     va_end(args);
9728 }
9729
9730 /* pTHX_ magic can't cope with varargs, so this is a no-context
9731  * version of the main function, (which may itself be aliased to us).
9732  * Don't access this version directly.
9733  */
9734
9735 void
9736 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9737 {
9738     dTHX;
9739     va_list args;
9740
9741     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9742
9743     va_start(args, pat);
9744     sv_vsetpvf_mg(sv, pat, &args);
9745     va_end(args);
9746 }
9747 #endif
9748
9749 /*
9750 =for apidoc sv_setpvf
9751
9752 Works like C<sv_catpvf> but copies the text into the SV instead of
9753 appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
9754
9755 =cut
9756 */
9757
9758 void
9759 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9760 {
9761     va_list args;
9762
9763     PERL_ARGS_ASSERT_SV_SETPVF;
9764
9765     va_start(args, pat);
9766     sv_vsetpvf(sv, pat, &args);
9767     va_end(args);
9768 }
9769
9770 /*
9771 =for apidoc sv_vsetpvf
9772
9773 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9774 appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
9775
9776 Usually used via its frontend C<sv_setpvf>.
9777
9778 =cut
9779 */
9780
9781 void
9782 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9783 {
9784     PERL_ARGS_ASSERT_SV_VSETPVF;
9785
9786     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9787 }
9788
9789 /*
9790 =for apidoc sv_setpvf_mg
9791
9792 Like C<sv_setpvf>, but also handles 'set' magic.
9793
9794 =cut
9795 */
9796
9797 void
9798 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9799 {
9800     va_list args;
9801
9802     PERL_ARGS_ASSERT_SV_SETPVF_MG;
9803
9804     va_start(args, pat);
9805     sv_vsetpvf_mg(sv, pat, &args);
9806     va_end(args);
9807 }
9808
9809 /*
9810 =for apidoc sv_vsetpvf_mg
9811
9812 Like C<sv_vsetpvf>, but also handles 'set' magic.
9813
9814 Usually used via its frontend C<sv_setpvf_mg>.
9815
9816 =cut
9817 */
9818
9819 void
9820 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9821 {
9822     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9823
9824     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9825     SvSETMAGIC(sv);
9826 }
9827
9828 #if defined(PERL_IMPLICIT_CONTEXT)
9829
9830 /* pTHX_ magic can't cope with varargs, so this is a no-context
9831  * version of the main function, (which may itself be aliased to us).
9832  * Don't access this version directly.
9833  */
9834
9835 void
9836 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9837 {
9838     dTHX;
9839     va_list args;
9840
9841     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9842
9843     va_start(args, pat);
9844     sv_vcatpvf(sv, pat, &args);
9845     va_end(args);
9846 }
9847
9848 /* pTHX_ magic can't cope with varargs, so this is a no-context
9849  * version of the main function, (which may itself be aliased to us).
9850  * Don't access this version directly.
9851  */
9852
9853 void
9854 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9855 {
9856     dTHX;
9857     va_list args;
9858
9859     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9860
9861     va_start(args, pat);
9862     sv_vcatpvf_mg(sv, pat, &args);
9863     va_end(args);
9864 }
9865 #endif
9866
9867 /*
9868 =for apidoc sv_catpvf
9869
9870 Processes its arguments like C<sprintf> and appends the formatted
9871 output to an SV.  If the appended data contains "wide" characters
9872 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9873 and characters >255 formatted with %c), the original SV might get
9874 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
9875 C<sv_catpvf_mg>.  If the original SV was UTF-8, the pattern should be
9876 valid UTF-8; if the original SV was bytes, the pattern should be too.
9877
9878 =cut */
9879
9880 void
9881 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9882 {
9883     va_list args;
9884
9885     PERL_ARGS_ASSERT_SV_CATPVF;
9886
9887     va_start(args, pat);
9888     sv_vcatpvf(sv, pat, &args);
9889     va_end(args);
9890 }
9891
9892 /*
9893 =for apidoc sv_vcatpvf
9894
9895 Processes its arguments like C<vsprintf> and appends the formatted output
9896 to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
9897
9898 Usually used via its frontend C<sv_catpvf>.
9899
9900 =cut
9901 */
9902
9903 void
9904 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9905 {
9906     PERL_ARGS_ASSERT_SV_VCATPVF;
9907
9908     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9909 }
9910
9911 /*
9912 =for apidoc sv_catpvf_mg
9913
9914 Like C<sv_catpvf>, but also handles 'set' magic.
9915
9916 =cut
9917 */
9918
9919 void
9920 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9921 {
9922     va_list args;
9923
9924     PERL_ARGS_ASSERT_SV_CATPVF_MG;
9925
9926     va_start(args, pat);
9927     sv_vcatpvf_mg(sv, pat, &args);
9928     va_end(args);
9929 }
9930
9931 /*
9932 =for apidoc sv_vcatpvf_mg
9933
9934 Like C<sv_vcatpvf>, but also handles 'set' magic.
9935
9936 Usually used via its frontend C<sv_catpvf_mg>.
9937
9938 =cut
9939 */
9940
9941 void
9942 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9943 {
9944     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9945
9946     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9947     SvSETMAGIC(sv);
9948 }
9949
9950 /*
9951 =for apidoc sv_vsetpvfn
9952
9953 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9954 appending it.
9955
9956 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9957
9958 =cut
9959 */
9960
9961 void
9962 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9963                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9964 {
9965     PERL_ARGS_ASSERT_SV_VSETPVFN;
9966
9967     sv_setpvs(sv, "");
9968     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9969 }
9970
9971
9972 /*
9973  * Warn of missing argument to sprintf, and then return a defined value
9974  * to avoid inappropriate "use of uninit" warnings [perl #71000].
9975  */
9976 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9977 STATIC SV*
9978 S_vcatpvfn_missing_argument(pTHX) {
9979     if (ckWARN(WARN_MISSING)) {
9980         Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9981                 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9982     }
9983     return &PL_sv_no;
9984 }
9985
9986
9987 STATIC I32
9988 S_expect_number(pTHX_ char **const pattern)
9989 {
9990     dVAR;
9991     I32 var = 0;
9992
9993     PERL_ARGS_ASSERT_EXPECT_NUMBER;
9994
9995     switch (**pattern) {
9996     case '1': case '2': case '3':
9997     case '4': case '5': case '6':
9998     case '7': case '8': case '9':
9999         var = *(*pattern)++ - '0';
10000         while (isDIGIT(**pattern)) {
10001             const I32 tmp = var * 10 + (*(*pattern)++ - '0');
10002             if (tmp < var)
10003                 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
10004             var = tmp;
10005         }
10006     }
10007     return var;
10008 }
10009
10010 STATIC char *
10011 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
10012 {
10013     const int neg = nv < 0;
10014     UV uv;
10015
10016     PERL_ARGS_ASSERT_F0CONVERT;
10017
10018     if (neg)
10019         nv = -nv;
10020     if (nv < UV_MAX) {
10021         char *p = endbuf;
10022         nv += 0.5;
10023         uv = (UV)nv;
10024         if (uv & 1 && uv == nv)
10025             uv--;                       /* Round to even */
10026         do {
10027             const unsigned dig = uv % 10;
10028             *--p = '0' + dig;
10029         } while (uv /= 10);
10030         if (neg)
10031             *--p = '-';
10032         *len = endbuf - p;
10033         return p;
10034     }
10035     return NULL;
10036 }
10037
10038
10039 /*
10040 =for apidoc sv_vcatpvfn
10041
10042 Processes its arguments like C<vsprintf> and appends the formatted output
10043 to an SV.  Uses an array of SVs if the C style variable argument list is
10044 missing (NULL).  When running with taint checks enabled, indicates via
10045 C<maybe_tainted> if results are untrustworthy (often due to the use of
10046 locales).
10047
10048 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
10049
10050 =cut
10051 */
10052
10053
10054 #define VECTORIZE_ARGS  vecsv = va_arg(*args, SV*);\
10055                         vecstr = (U8*)SvPV_const(vecsv,veclen);\
10056                         vec_utf8 = DO_UTF8(vecsv);
10057
10058 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
10059
10060 void
10061 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10062                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10063 {
10064     dVAR;
10065     char *p;
10066     char *q;
10067     const char *patend;
10068     STRLEN origlen;
10069     I32 svix = 0;
10070     static const char nullstr[] = "(null)";
10071     SV *argsv = NULL;
10072     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
10073     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
10074     SV *nsv = NULL;
10075     /* Times 4: a decimal digit takes more than 3 binary digits.
10076      * NV_DIG: mantissa takes than many decimal digits.
10077      * Plus 32: Playing safe. */
10078     char ebuf[IV_DIG * 4 + NV_DIG + 32];
10079     /* large enough for "%#.#f" --chip */
10080     /* what about long double NVs? --jhi */
10081
10082     PERL_ARGS_ASSERT_SV_VCATPVFN;
10083     PERL_UNUSED_ARG(maybe_tainted);
10084
10085     /* no matter what, this is a string now */
10086     (void)SvPV_force(sv, origlen);
10087
10088     /* special-case "", "%s", and "%-p" (SVf - see below) */
10089     if (patlen == 0)
10090         return;
10091     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
10092         if (args) {
10093             const char * const s = va_arg(*args, char*);
10094             sv_catpv(sv, s ? s : nullstr);
10095         }
10096         else if (svix < svmax) {
10097             sv_catsv(sv, *svargs);
10098         }
10099         else
10100             S_vcatpvfn_missing_argument(aTHX);
10101         return;
10102     }
10103     if (args && patlen == 3 && pat[0] == '%' &&
10104                 pat[1] == '-' && pat[2] == 'p') {
10105         argsv = MUTABLE_SV(va_arg(*args, void*));
10106         sv_catsv(sv, argsv);
10107         return;
10108     }
10109
10110 #ifndef USE_LONG_DOUBLE
10111     /* special-case "%.<number>[gf]" */
10112     if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
10113          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
10114         unsigned digits = 0;
10115         const char *pp;
10116
10117         pp = pat + 2;
10118         while (*pp >= '0' && *pp <= '9')
10119             digits = 10 * digits + (*pp++ - '0');
10120         if (pp - pat == (int)patlen - 1 && svix < svmax) {
10121             const NV nv = SvNV(*svargs);
10122             if (*pp == 'g') {
10123                 /* Add check for digits != 0 because it seems that some
10124                    gconverts are buggy in this case, and we don't yet have
10125                    a Configure test for this.  */
10126                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
10127                      /* 0, point, slack */
10128                     Gconvert(nv, (int)digits, 0, ebuf);
10129                     sv_catpv(sv, ebuf);
10130                     if (*ebuf)  /* May return an empty string for digits==0 */
10131                         return;
10132                 }
10133             } else if (!digits) {
10134                 STRLEN l;
10135
10136                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
10137                     sv_catpvn(sv, p, l);
10138                     return;
10139                 }
10140             }
10141         }
10142     }
10143 #endif /* !USE_LONG_DOUBLE */
10144
10145     if (!args && svix < svmax && DO_UTF8(*svargs))
10146         has_utf8 = TRUE;
10147
10148     patend = (char*)pat + patlen;
10149     for (p = (char*)pat; p < patend; p = q) {
10150         bool alt = FALSE;
10151         bool left = FALSE;
10152         bool vectorize = FALSE;
10153         bool vectorarg = FALSE;
10154         bool vec_utf8 = FALSE;
10155         char fill = ' ';
10156         char plus = 0;
10157         char intsize = 0;
10158         STRLEN width = 0;
10159         STRLEN zeros = 0;
10160         bool has_precis = FALSE;
10161         STRLEN precis = 0;
10162         const I32 osvix = svix;
10163         bool is_utf8 = FALSE;  /* is this item utf8?   */
10164 #ifdef HAS_LDBL_SPRINTF_BUG
10165         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10166            with sfio - Allen <allens@cpan.org> */
10167         bool fix_ldbl_sprintf_bug = FALSE;
10168 #endif
10169
10170         char esignbuf[4];
10171         U8 utf8buf[UTF8_MAXBYTES+1];
10172         STRLEN esignlen = 0;
10173
10174         const char *eptr = NULL;
10175         const char *fmtstart;
10176         STRLEN elen = 0;
10177         SV *vecsv = NULL;
10178         const U8 *vecstr = NULL;
10179         STRLEN veclen = 0;
10180         char c = 0;
10181         int i;
10182         unsigned base = 0;
10183         IV iv = 0;
10184         UV uv = 0;
10185         /* we need a long double target in case HAS_LONG_DOUBLE but
10186            not USE_LONG_DOUBLE
10187         */
10188 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
10189         long double nv;
10190 #else
10191         NV nv;
10192 #endif
10193         STRLEN have;
10194         STRLEN need;
10195         STRLEN gap;
10196         const char *dotstr = ".";
10197         STRLEN dotstrlen = 1;
10198         I32 efix = 0; /* explicit format parameter index */
10199         I32 ewix = 0; /* explicit width index */
10200         I32 epix = 0; /* explicit precision index */
10201         I32 evix = 0; /* explicit vector index */
10202         bool asterisk = FALSE;
10203
10204         /* echo everything up to the next format specification */
10205         for (q = p; q < patend && *q != '%'; ++q) ;
10206         if (q > p) {
10207             if (has_utf8 && !pat_utf8)
10208                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
10209             else
10210                 sv_catpvn(sv, p, q - p);
10211             p = q;
10212         }
10213         if (q++ >= patend)
10214             break;
10215
10216         fmtstart = q;
10217
10218 /*
10219     We allow format specification elements in this order:
10220         \d+\$              explicit format parameter index
10221         [-+ 0#]+           flags
10222         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
10223         0                  flag (as above): repeated to allow "v02"
10224         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
10225         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10226         [hlqLV]            size
10227     [%bcdefginopsuxDFOUX] format (mandatory)
10228 */
10229
10230         if (args) {
10231 /*
10232         As of perl5.9.3, printf format checking is on by default.
10233         Internally, perl uses %p formats to provide an escape to
10234         some extended formatting.  This block deals with those
10235         extensions: if it does not match, (char*)q is reset and
10236         the normal format processing code is used.
10237
10238         Currently defined extensions are:
10239                 %p              include pointer address (standard)
10240                 %-p     (SVf)   include an SV (previously %_)
10241                 %-<num>p        include an SV with precision <num>
10242                 %2p             include a HEK
10243                 %3p             include a HEK with precision of 256
10244                 %<num>p         (where num != 2 or 3) reserved for future
10245                                 extensions
10246
10247         Robin Barker 2005-07-14 (but modified since)
10248
10249                 %1p     (VDf)   removed.  RMB 2007-10-19
10250 */
10251             char* r = q;
10252             bool sv = FALSE;
10253             STRLEN n = 0;
10254             if (*q == '-')
10255                 sv = *q++;
10256             n = expect_number(&q);
10257             if (*q++ == 'p') {
10258                 if (sv) {                       /* SVf */
10259                     if (n) {
10260                         precis = n;
10261                         has_precis = TRUE;
10262                     }
10263                     argsv = MUTABLE_SV(va_arg(*args, void*));
10264                     eptr = SvPV_const(argsv, elen);
10265                     if (DO_UTF8(argsv))
10266                         is_utf8 = TRUE;
10267                     goto string;
10268                 }
10269                 else if (n==2 || n==3) {        /* HEKf */
10270                     HEK * const hek = va_arg(*args, HEK *);
10271                     eptr = HEK_KEY(hek);
10272                     elen = HEK_LEN(hek);
10273                     if (HEK_UTF8(hek)) is_utf8 = TRUE;
10274                     if (n==3) precis = 256, has_precis = TRUE;
10275                     goto string;
10276                 }
10277                 else if (n) {
10278                     Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10279                                      "internal %%<num>p might conflict with future printf extensions");
10280                 }
10281             }
10282             q = r;
10283         }
10284
10285         if ( (width = expect_number(&q)) ) {
10286             if (*q == '$') {
10287                 ++q;
10288                 efix = width;
10289             } else {
10290                 goto gotwidth;
10291             }
10292         }
10293
10294         /* FLAGS */
10295
10296         while (*q) {
10297             switch (*q) {
10298             case ' ':
10299             case '+':
10300                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10301                     q++;
10302                 else
10303                     plus = *q++;
10304                 continue;
10305
10306             case '-':
10307                 left = TRUE;
10308                 q++;
10309                 continue;
10310
10311             case '0':
10312                 fill = *q++;
10313                 continue;
10314
10315             case '#':
10316                 alt = TRUE;
10317                 q++;
10318                 continue;
10319
10320             default:
10321                 break;
10322             }
10323             break;
10324         }
10325
10326       tryasterisk:
10327         if (*q == '*') {
10328             q++;
10329             if ( (ewix = expect_number(&q)) )
10330                 if (*q++ != '$')
10331                     goto unknown;
10332             asterisk = TRUE;
10333         }
10334         if (*q == 'v') {
10335             q++;
10336             if (vectorize)
10337                 goto unknown;
10338             if ((vectorarg = asterisk)) {
10339                 evix = ewix;
10340                 ewix = 0;
10341                 asterisk = FALSE;
10342             }
10343             vectorize = TRUE;
10344             goto tryasterisk;
10345         }
10346
10347         if (!asterisk)
10348         {
10349             if( *q == '0' )
10350                 fill = *q++;
10351             width = expect_number(&q);
10352         }
10353
10354         if (vectorize && vectorarg) {
10355             /* vectorizing, but not with the default "." */
10356             if (args)
10357                 vecsv = va_arg(*args, SV*);
10358             else if (evix) {
10359                 vecsv = (evix > 0 && evix <= svmax)
10360                     ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10361             } else {
10362                 vecsv = svix < svmax
10363                     ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10364             }
10365             dotstr = SvPV_const(vecsv, dotstrlen);
10366             /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10367                bad with tied or overloaded values that return UTF8.  */
10368             if (DO_UTF8(vecsv))
10369                 is_utf8 = TRUE;
10370             else if (has_utf8) {
10371                 vecsv = sv_mortalcopy(vecsv);
10372                 sv_utf8_upgrade(vecsv);
10373                 dotstr = SvPV_const(vecsv, dotstrlen);
10374                 is_utf8 = TRUE;
10375             }
10376         }
10377
10378         if (asterisk) {
10379             if (args)
10380                 i = va_arg(*args, int);
10381             else
10382                 i = (ewix ? ewix <= svmax : svix < svmax) ?
10383                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10384             left |= (i < 0);
10385             width = (i < 0) ? -i : i;
10386         }
10387       gotwidth:
10388
10389         /* PRECISION */
10390
10391         if (*q == '.') {
10392             q++;
10393             if (*q == '*') {
10394                 q++;
10395                 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10396                     goto unknown;
10397                 /* XXX: todo, support specified precision parameter */
10398                 if (epix)
10399                     goto unknown;
10400                 if (args)
10401                     i = va_arg(*args, int);
10402                 else
10403                     i = (ewix ? ewix <= svmax : svix < svmax)
10404                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10405                 precis = i;
10406                 has_precis = !(i < 0);
10407             }
10408             else {
10409                 precis = 0;
10410                 while (isDIGIT(*q))
10411                     precis = precis * 10 + (*q++ - '0');
10412                 has_precis = TRUE;
10413             }
10414         }
10415
10416         if (vectorize) {
10417             if (args) {
10418                 VECTORIZE_ARGS
10419             }
10420             else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10421                 vecsv = svargs[efix ? efix-1 : svix++];
10422                 vecstr = (U8*)SvPV_const(vecsv,veclen);
10423                 vec_utf8 = DO_UTF8(vecsv);
10424
10425                 /* if this is a version object, we need to convert
10426                  * back into v-string notation and then let the
10427                  * vectorize happen normally
10428                  */
10429                 if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
10430                     char *version = savesvpv(vecsv);
10431                     if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10432                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
10433                         "vector argument not supported with alpha versions");
10434                         goto unknown;
10435                     }
10436                     vecsv = sv_newmortal();
10437                     scan_vstring(version, version + veclen, vecsv);
10438                     vecstr = (U8*)SvPV_const(vecsv, veclen);
10439                     vec_utf8 = DO_UTF8(vecsv);
10440                     Safefree(version);
10441                 }
10442             }
10443             else {
10444                 vecstr = (U8*)"";
10445                 veclen = 0;
10446             }
10447         }
10448
10449         /* SIZE */
10450
10451         switch (*q) {
10452 #ifdef WIN32
10453         case 'I':                       /* Ix, I32x, and I64x */
10454 #  ifdef WIN64
10455             if (q[1] == '6' && q[2] == '4') {
10456                 q += 3;
10457                 intsize = 'q';
10458                 break;
10459             }
10460 #  endif
10461             if (q[1] == '3' && q[2] == '2') {
10462                 q += 3;
10463                 break;
10464             }
10465 #  ifdef WIN64
10466             intsize = 'q';
10467 #  endif
10468             q++;
10469             break;
10470 #endif
10471 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10472         case 'L':                       /* Ld */
10473             /*FALLTHROUGH*/
10474 #ifdef HAS_QUAD
10475         case 'q':                       /* qd */
10476 #endif
10477             intsize = 'q';
10478             q++;
10479             break;
10480 #endif
10481         case 'l':
10482             ++q;
10483 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10484             if (*q == 'l') {    /* lld, llf */
10485                 intsize = 'q';
10486                 ++q;
10487             }
10488             else
10489 #endif
10490                 intsize = 'l';
10491             break;
10492         case 'h':
10493             if (*++q == 'h') {  /* hhd, hhu */
10494                 intsize = 'c';
10495                 ++q;
10496             }
10497             else
10498                 intsize = 'h';
10499             break;
10500         case 'V':
10501         case 'z':
10502         case 't':
10503 #if HAS_C99
10504         case 'j':
10505 #endif
10506             intsize = *q++;
10507             break;
10508         }
10509
10510         /* CONVERSION */
10511
10512         if (*q == '%') {
10513             eptr = q++;
10514             elen = 1;
10515             if (vectorize) {
10516                 c = '%';
10517                 goto unknown;
10518             }
10519             goto string;
10520         }
10521
10522         if (!vectorize && !args) {
10523             if (efix) {
10524                 const I32 i = efix-1;
10525                 argsv = (i >= 0 && i < svmax)
10526                     ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10527             } else {
10528                 argsv = (svix >= 0 && svix < svmax)
10529                     ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10530             }
10531         }
10532
10533         switch (c = *q++) {
10534
10535             /* STRINGS */
10536
10537         case 'c':
10538             if (vectorize)
10539                 goto unknown;
10540             uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10541             if ((uv > 255 ||
10542                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
10543                 && !IN_BYTES) {
10544                 eptr = (char*)utf8buf;
10545                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10546                 is_utf8 = TRUE;
10547             }
10548             else {
10549                 c = (char)uv;
10550                 eptr = &c;
10551                 elen = 1;
10552             }
10553             goto string;
10554
10555         case 's':
10556             if (vectorize)
10557                 goto unknown;
10558             if (args) {
10559                 eptr = va_arg(*args, char*);
10560                 if (eptr)
10561                     elen = strlen(eptr);
10562                 else {
10563                     eptr = (char *)nullstr;
10564                     elen = sizeof nullstr - 1;
10565                 }
10566             }
10567             else {
10568                 eptr = SvPV_const(argsv, elen);
10569                 if (DO_UTF8(argsv)) {
10570                     STRLEN old_precis = precis;
10571                     if (has_precis && precis < elen) {
10572                         STRLEN ulen = sv_len_utf8(argsv);
10573                         I32 p = precis > ulen ? ulen : precis;
10574                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10575                         precis = p;
10576                     }
10577                     if (width) { /* fudge width (can't fudge elen) */
10578                         if (has_precis && precis < elen)
10579                             width += precis - old_precis;
10580                         else
10581                             width += elen - sv_len_utf8(argsv);
10582                     }
10583                     is_utf8 = TRUE;
10584                 }
10585             }
10586
10587         string:
10588             if (has_precis && precis < elen)
10589                 elen = precis;
10590             break;
10591
10592             /* INTEGERS */
10593
10594         case 'p':
10595             if (alt || vectorize)
10596                 goto unknown;
10597             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10598             base = 16;
10599             goto integer;
10600
10601         case 'D':
10602 #ifdef IV_IS_QUAD
10603             intsize = 'q';
10604 #else
10605             intsize = 'l';
10606 #endif
10607             /*FALLTHROUGH*/
10608         case 'd':
10609         case 'i':
10610 #if vdNUMBER
10611         format_vd:
10612 #endif
10613             if (vectorize) {
10614                 STRLEN ulen;
10615                 if (!veclen)
10616                     continue;
10617                 if (vec_utf8)
10618                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10619                                         UTF8_ALLOW_ANYUV);
10620                 else {
10621                     uv = *vecstr;
10622                     ulen = 1;
10623                 }
10624                 vecstr += ulen;
10625                 veclen -= ulen;
10626                 if (plus)
10627                      esignbuf[esignlen++] = plus;
10628             }
10629             else if (args) {
10630                 switch (intsize) {
10631                 case 'c':       iv = (char)va_arg(*args, int); break;
10632                 case 'h':       iv = (short)va_arg(*args, int); break;
10633                 case 'l':       iv = va_arg(*args, long); break;
10634                 case 'V':       iv = va_arg(*args, IV); break;
10635                 case 'z':       iv = va_arg(*args, SSize_t); break;
10636                 case 't':       iv = va_arg(*args, ptrdiff_t); break;
10637                 default:        iv = va_arg(*args, int); break;
10638 #if HAS_C99
10639                 case 'j':       iv = va_arg(*args, intmax_t); break;
10640 #endif
10641                 case 'q':
10642 #ifdef HAS_QUAD
10643                                 iv = va_arg(*args, Quad_t); break;
10644 #else
10645                                 goto unknown;
10646 #endif
10647                 }
10648             }
10649             else {
10650                 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10651                 switch (intsize) {
10652                 case 'c':       iv = (char)tiv; break;
10653                 case 'h':       iv = (short)tiv; break;
10654                 case 'l':       iv = (long)tiv; break;
10655                 case 'V':
10656                 default:        iv = tiv; break;
10657                 case 'q':
10658 #ifdef HAS_QUAD
10659                                 iv = (Quad_t)tiv; break;
10660 #else
10661                                 goto unknown;
10662 #endif
10663                 }
10664             }
10665             if ( !vectorize )   /* we already set uv above */
10666             {
10667                 if (iv >= 0) {
10668                     uv = iv;
10669                     if (plus)
10670                         esignbuf[esignlen++] = plus;
10671                 }
10672                 else {
10673                     uv = -iv;
10674                     esignbuf[esignlen++] = '-';
10675                 }
10676             }
10677             base = 10;
10678             goto integer;
10679
10680         case 'U':
10681 #ifdef IV_IS_QUAD
10682             intsize = 'q';
10683 #else
10684             intsize = 'l';
10685 #endif
10686             /*FALLTHROUGH*/
10687         case 'u':
10688             base = 10;
10689             goto uns_integer;
10690
10691         case 'B':
10692         case 'b':
10693             base = 2;
10694             goto uns_integer;
10695
10696         case 'O':
10697 #ifdef IV_IS_QUAD
10698             intsize = 'q';
10699 #else
10700             intsize = 'l';
10701 #endif
10702             /*FALLTHROUGH*/
10703         case 'o':
10704             base = 8;
10705             goto uns_integer;
10706
10707         case 'X':
10708         case 'x':
10709             base = 16;
10710
10711         uns_integer:
10712             if (vectorize) {
10713                 STRLEN ulen;
10714         vector:
10715                 if (!veclen)
10716                     continue;
10717                 if (vec_utf8)
10718                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10719                                         UTF8_ALLOW_ANYUV);
10720                 else {
10721                     uv = *vecstr;
10722                     ulen = 1;
10723                 }
10724                 vecstr += ulen;
10725                 veclen -= ulen;
10726             }
10727             else if (args) {
10728                 switch (intsize) {
10729                 case 'c':  uv = (unsigned char)va_arg(*args, unsigned); break;
10730                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
10731                 case 'l':  uv = va_arg(*args, unsigned long); break;
10732                 case 'V':  uv = va_arg(*args, UV); break;
10733                 case 'z':  uv = va_arg(*args, Size_t); break;
10734                 case 't':  uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
10735 #if HAS_C99
10736                 case 'j':  uv = va_arg(*args, uintmax_t); break;
10737 #endif
10738                 default:   uv = va_arg(*args, unsigned); break;
10739                 case 'q':
10740 #ifdef HAS_QUAD
10741                            uv = va_arg(*args, Uquad_t); break;
10742 #else
10743                            goto unknown;
10744 #endif
10745                 }
10746             }
10747             else {
10748                 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10749                 switch (intsize) {
10750                 case 'c':       uv = (unsigned char)tuv; break;
10751                 case 'h':       uv = (unsigned short)tuv; break;
10752                 case 'l':       uv = (unsigned long)tuv; break;
10753                 case 'V':
10754                 default:        uv = tuv; break;
10755                 case 'q':
10756 #ifdef HAS_QUAD
10757                                 uv = (Uquad_t)tuv; break;
10758 #else
10759                                 goto unknown;
10760 #endif
10761                 }
10762             }
10763
10764         integer:
10765             {
10766                 char *ptr = ebuf + sizeof ebuf;
10767                 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10768                 zeros = 0;
10769
10770                 switch (base) {
10771                     unsigned dig;
10772                 case 16:
10773                     p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10774                     do {
10775                         dig = uv & 15;
10776                         *--ptr = p[dig];
10777                     } while (uv >>= 4);
10778                     if (tempalt) {
10779                         esignbuf[esignlen++] = '0';
10780                         esignbuf[esignlen++] = c;  /* 'x' or 'X' */
10781                     }
10782                     break;
10783                 case 8:
10784                     do {
10785                         dig = uv & 7;
10786                         *--ptr = '0' + dig;
10787                     } while (uv >>= 3);
10788                     if (alt && *ptr != '0')
10789                         *--ptr = '0';
10790                     break;
10791                 case 2:
10792                     do {
10793                         dig = uv & 1;
10794                         *--ptr = '0' + dig;
10795                     } while (uv >>= 1);
10796                     if (tempalt) {
10797                         esignbuf[esignlen++] = '0';
10798                         esignbuf[esignlen++] = c;
10799                     }
10800                     break;
10801                 default:                /* it had better be ten or less */
10802                     do {
10803                         dig = uv % base;
10804                         *--ptr = '0' + dig;
10805                     } while (uv /= base);
10806                     break;
10807                 }
10808                 elen = (ebuf + sizeof ebuf) - ptr;
10809                 eptr = ptr;
10810                 if (has_precis) {
10811                     if (precis > elen)
10812                         zeros = precis - elen;
10813                     else if (precis == 0 && elen == 1 && *eptr == '0'
10814                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10815                         elen = 0;
10816
10817                 /* a precision nullifies the 0 flag. */
10818                     if (fill == '0')
10819                         fill = ' ';
10820                 }
10821             }
10822             break;
10823
10824             /* FLOATING POINT */
10825
10826         case 'F':
10827             c = 'f';            /* maybe %F isn't supported here */
10828             /*FALLTHROUGH*/
10829         case 'e': case 'E':
10830         case 'f':
10831         case 'g': case 'G':
10832             if (vectorize)
10833                 goto unknown;
10834
10835             /* This is evil, but floating point is even more evil */
10836
10837             /* for SV-style calling, we can only get NV
10838                for C-style calling, we assume %f is double;
10839                for simplicity we allow any of %Lf, %llf, %qf for long double
10840             */
10841             switch (intsize) {
10842             case 'V':
10843 #if defined(USE_LONG_DOUBLE)
10844                 intsize = 'q';
10845 #endif
10846                 break;
10847 /* [perl #20339] - we should accept and ignore %lf rather than die */
10848             case 'l':
10849                 /*FALLTHROUGH*/
10850             default:
10851 #if defined(USE_LONG_DOUBLE)
10852                 intsize = args ? 0 : 'q';
10853 #endif
10854                 break;
10855             case 'q':
10856 #if defined(HAS_LONG_DOUBLE)
10857                 break;
10858 #else
10859                 /*FALLTHROUGH*/
10860 #endif
10861             case 'c':
10862             case 'h':
10863             case 'z':
10864             case 't':
10865             case 'j':
10866                 goto unknown;
10867             }
10868
10869             /* now we need (long double) if intsize == 'q', else (double) */
10870             nv = (args) ?
10871 #if LONG_DOUBLESIZE > DOUBLESIZE
10872                 intsize == 'q' ?
10873                     va_arg(*args, long double) :
10874                     va_arg(*args, double)
10875 #else
10876                     va_arg(*args, double)
10877 #endif
10878                 : SvNV(argsv);
10879
10880             need = 0;
10881             /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10882                else. frexp() has some unspecified behaviour for those three */
10883             if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10884                 i = PERL_INT_MIN;
10885                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10886                    will cast our (long double) to (double) */
10887                 (void)Perl_frexp(nv, &i);
10888                 if (i == PERL_INT_MIN)
10889                     Perl_die(aTHX_ "panic: frexp");
10890                 if (i > 0)
10891                     need = BIT_DIGITS(i);
10892             }
10893             need += has_precis ? precis : 6; /* known default */
10894
10895             if (need < width)
10896                 need = width;
10897
10898 #ifdef HAS_LDBL_SPRINTF_BUG
10899             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10900                with sfio - Allen <allens@cpan.org> */
10901
10902 #  ifdef DBL_MAX
10903 #    define MY_DBL_MAX DBL_MAX
10904 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10905 #    if DOUBLESIZE >= 8
10906 #      define MY_DBL_MAX 1.7976931348623157E+308L
10907 #    else
10908 #      define MY_DBL_MAX 3.40282347E+38L
10909 #    endif
10910 #  endif
10911
10912 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10913 #    define MY_DBL_MAX_BUG 1L
10914 #  else
10915 #    define MY_DBL_MAX_BUG MY_DBL_MAX
10916 #  endif
10917
10918 #  ifdef DBL_MIN
10919 #    define MY_DBL_MIN DBL_MIN
10920 #  else  /* XXX guessing! -Allen */
10921 #    if DOUBLESIZE >= 8
10922 #      define MY_DBL_MIN 2.2250738585072014E-308L
10923 #    else
10924 #      define MY_DBL_MIN 1.17549435E-38L
10925 #    endif
10926 #  endif
10927
10928             if ((intsize == 'q') && (c == 'f') &&
10929                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10930                 (need < DBL_DIG)) {
10931                 /* it's going to be short enough that
10932                  * long double precision is not needed */
10933
10934                 if ((nv <= 0L) && (nv >= -0L))
10935                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10936                 else {
10937                     /* would use Perl_fp_class as a double-check but not
10938                      * functional on IRIX - see perl.h comments */
10939
10940                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10941                         /* It's within the range that a double can represent */
10942 #if defined(DBL_MAX) && !defined(DBL_MIN)
10943                         if ((nv >= ((long double)1/DBL_MAX)) ||
10944                             (nv <= (-(long double)1/DBL_MAX)))
10945 #endif
10946                         fix_ldbl_sprintf_bug = TRUE;
10947                     }
10948                 }
10949                 if (fix_ldbl_sprintf_bug == TRUE) {
10950                     double temp;
10951
10952                     intsize = 0;
10953                     temp = (double)nv;
10954                     nv = (NV)temp;
10955                 }
10956             }
10957
10958 #  undef MY_DBL_MAX
10959 #  undef MY_DBL_MAX_BUG
10960 #  undef MY_DBL_MIN
10961
10962 #endif /* HAS_LDBL_SPRINTF_BUG */
10963
10964             need += 20; /* fudge factor */
10965             if (PL_efloatsize < need) {
10966                 Safefree(PL_efloatbuf);
10967                 PL_efloatsize = need + 20; /* more fudge */
10968                 Newx(PL_efloatbuf, PL_efloatsize, char);
10969                 PL_efloatbuf[0] = '\0';
10970             }
10971
10972             if ( !(width || left || plus || alt) && fill != '0'
10973                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
10974                 /* See earlier comment about buggy Gconvert when digits,
10975                    aka precis is 0  */
10976                 if ( c == 'g' && precis) {
10977                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10978                     /* May return an empty string for digits==0 */
10979                     if (*PL_efloatbuf) {
10980                         elen = strlen(PL_efloatbuf);
10981                         goto float_converted;
10982                     }
10983                 } else if ( c == 'f' && !precis) {
10984                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10985                         break;
10986                 }
10987             }
10988             {
10989                 char *ptr = ebuf + sizeof ebuf;
10990                 *--ptr = '\0';
10991                 *--ptr = c;
10992                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10993 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10994                 if (intsize == 'q') {
10995                     /* Copy the one or more characters in a long double
10996                      * format before the 'base' ([efgEFG]) character to
10997                      * the format string. */
10998                     static char const prifldbl[] = PERL_PRIfldbl;
10999                     char const *p = prifldbl + sizeof(prifldbl) - 3;
11000                     while (p >= prifldbl) { *--ptr = *p--; }
11001                 }
11002 #endif
11003                 if (has_precis) {
11004                     base = precis;
11005                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
11006                     *--ptr = '.';
11007                 }
11008                 if (width) {
11009                     base = width;
11010                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
11011                 }
11012                 if (fill == '0')
11013                     *--ptr = fill;
11014                 if (left)
11015                     *--ptr = '-';
11016                 if (plus)
11017                     *--ptr = plus;
11018                 if (alt)
11019                     *--ptr = '#';
11020                 *--ptr = '%';
11021
11022                 /* No taint.  Otherwise we are in the strange situation
11023                  * where printf() taints but print($float) doesn't.
11024                  * --jhi */
11025 #if defined(HAS_LONG_DOUBLE)
11026                 elen = ((intsize == 'q')
11027                         ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
11028                         : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
11029 #else
11030                 elen = my_sprintf(PL_efloatbuf, ptr, nv);
11031 #endif
11032             }
11033         float_converted:
11034             eptr = PL_efloatbuf;
11035             break;
11036
11037             /* SPECIAL */
11038
11039         case 'n':
11040             if (vectorize)
11041                 goto unknown;
11042             i = SvCUR(sv) - origlen;
11043             if (args) {
11044                 switch (intsize) {
11045                 case 'c':       *(va_arg(*args, char*)) = i; break;
11046                 case 'h':       *(va_arg(*args, short*)) = i; break;
11047                 default:        *(va_arg(*args, int*)) = i; break;
11048                 case 'l':       *(va_arg(*args, long*)) = i; break;
11049                 case 'V':       *(va_arg(*args, IV*)) = i; break;
11050                 case 'z':       *(va_arg(*args, SSize_t*)) = i; break;
11051                 case 't':       *(va_arg(*args, ptrdiff_t*)) = i; break;
11052 #if HAS_C99
11053                 case 'j':       *(va_arg(*args, intmax_t*)) = i; break;
11054 #endif
11055                 case 'q':
11056 #ifdef HAS_QUAD
11057                                 *(va_arg(*args, Quad_t*)) = i; break;
11058 #else
11059                                 goto unknown;
11060 #endif
11061                 }
11062             }
11063             else
11064                 sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
11065             continue;   /* not "break" */
11066
11067             /* UNKNOWN */
11068
11069         default:
11070       unknown:
11071             if (!args
11072                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
11073                 && ckWARN(WARN_PRINTF))
11074             {
11075                 SV * const msg = sv_newmortal();
11076                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
11077                           (PL_op->op_type == OP_PRTF) ? "" : "s");
11078                 if (fmtstart < patend) {
11079                     const char * const fmtend = q < patend ? q : patend;
11080                     const char * f;
11081                     sv_catpvs(msg, "\"%");
11082                     for (f = fmtstart; f < fmtend; f++) {
11083                         if (isPRINT(*f)) {
11084                             sv_catpvn(msg, f, 1);
11085                         } else {
11086                             Perl_sv_catpvf(aTHX_ msg,
11087                                            "\\%03"UVof, (UV)*f & 0xFF);
11088                         }
11089                     }
11090                     sv_catpvs(msg, "\"");
11091                 } else {
11092                     sv_catpvs(msg, "end of string");
11093                 }
11094                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
11095             }
11096
11097             /* output mangled stuff ... */
11098             if (c == '\0')
11099                 --q;
11100             eptr = p;
11101             elen = q - p;
11102
11103             /* ... right here, because formatting flags should not apply */
11104             SvGROW(sv, SvCUR(sv) + elen + 1);
11105             p = SvEND(sv);
11106             Copy(eptr, p, elen, char);
11107             p += elen;
11108             *p = '\0';
11109             SvCUR_set(sv, p - SvPVX_const(sv));
11110             svix = osvix;
11111             continue;   /* not "break" */
11112         }
11113
11114         if (is_utf8 != has_utf8) {
11115             if (is_utf8) {
11116                 if (SvCUR(sv))
11117                     sv_utf8_upgrade(sv);
11118             }
11119             else {
11120                 const STRLEN old_elen = elen;
11121                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
11122                 sv_utf8_upgrade(nsv);
11123                 eptr = SvPVX_const(nsv);
11124                 elen = SvCUR(nsv);
11125
11126                 if (width) { /* fudge width (can't fudge elen) */
11127                     width += elen - old_elen;
11128                 }
11129                 is_utf8 = TRUE;
11130             }
11131         }
11132
11133         have = esignlen + zeros + elen;
11134         if (have < zeros)
11135             Perl_croak_nocontext("%s", PL_memory_wrap);
11136
11137         need = (have > width ? have : width);
11138         gap = need - have;
11139
11140         if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
11141             Perl_croak_nocontext("%s", PL_memory_wrap);
11142         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
11143         p = SvEND(sv);
11144         if (esignlen && fill == '0') {
11145             int i;
11146             for (i = 0; i < (int)esignlen; i++)
11147                 *p++ = esignbuf[i];
11148         }
11149         if (gap && !left) {
11150             memset(p, fill, gap);
11151             p += gap;
11152         }
11153         if (esignlen && fill != '0') {
11154             int i;
11155             for (i = 0; i < (int)esignlen; i++)
11156                 *p++ = esignbuf[i];
11157         }
11158         if (zeros) {
11159             int i;
11160             for (i = zeros; i; i--)
11161                 *p++ = '0';
11162         }
11163         if (elen) {
11164             Copy(eptr, p, elen, char);
11165             p += elen;
11166         }
11167         if (gap && left) {
11168             memset(p, ' ', gap);
11169             p += gap;
11170         }
11171         if (vectorize) {
11172             if (veclen) {
11173                 Copy(dotstr, p, dotstrlen, char);
11174                 p += dotstrlen;
11175             }
11176             else
11177                 vectorize = FALSE;              /* done iterating over vecstr */
11178         }
11179         if (is_utf8)
11180             has_utf8 = TRUE;
11181         if (has_utf8)
11182             SvUTF8_on(sv);
11183         *p = '\0';
11184         SvCUR_set(sv, p - SvPVX_const(sv));
11185         if (vectorize) {
11186             esignlen = 0;
11187             goto vector;
11188         }
11189     }
11190     SvTAINT(sv);
11191 }
11192
11193 /* =========================================================================
11194
11195 =head1 Cloning an interpreter
11196
11197 All the macros and functions in this section are for the private use of
11198 the main function, perl_clone().
11199
11200 The foo_dup() functions make an exact copy of an existing foo thingy.
11201 During the course of a cloning, a hash table is used to map old addresses
11202 to new addresses.  The table is created and manipulated with the
11203 ptr_table_* functions.
11204
11205 =cut
11206
11207  * =========================================================================*/
11208
11209
11210 #if defined(USE_ITHREADS)
11211
11212 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
11213 #ifndef GpREFCNT_inc
11214 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
11215 #endif
11216
11217
11218 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
11219    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
11220    If this changes, please unmerge ss_dup.
11221    Likewise, sv_dup_inc_multiple() relies on this fact.  */
11222 #define sv_dup_inc_NN(s,t)      SvREFCNT_inc_NN(sv_dup_inc(s,t))
11223 #define av_dup(s,t)     MUTABLE_AV(sv_dup((const SV *)s,t))
11224 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11225 #define hv_dup(s,t)     MUTABLE_HV(sv_dup((const SV *)s,t))
11226 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11227 #define cv_dup(s,t)     MUTABLE_CV(sv_dup((const SV *)s,t))
11228 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
11229 #define io_dup(s,t)     MUTABLE_IO(sv_dup((const SV *)s,t))
11230 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
11231 #define gv_dup(s,t)     MUTABLE_GV(sv_dup((const SV *)s,t))
11232 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
11233 #define SAVEPV(p)       ((p) ? savepv(p) : NULL)
11234 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
11235
11236 /* clone a parser */
11237
11238 yy_parser *
11239 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
11240 {
11241     yy_parser *parser;
11242
11243     PERL_ARGS_ASSERT_PARSER_DUP;
11244
11245     if (!proto)
11246         return NULL;
11247
11248     /* look for it in the table first */
11249     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11250     if (parser)
11251         return parser;
11252
11253     /* create anew and remember what it is */
11254     Newxz(parser, 1, yy_parser);
11255     ptr_table_store(PL_ptr_table, proto, parser);
11256
11257     /* XXX these not yet duped */
11258     parser->old_parser = NULL;
11259     parser->stack = NULL;
11260     parser->ps = NULL;
11261     parser->stack_size = 0;
11262     /* XXX parser->stack->state = 0; */
11263
11264     /* XXX eventually, just Copy() most of the parser struct ? */
11265
11266     parser->lex_brackets = proto->lex_brackets;
11267     parser->lex_casemods = proto->lex_casemods;
11268     parser->lex_brackstack = savepvn(proto->lex_brackstack,
11269                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11270     parser->lex_casestack = savepvn(proto->lex_casestack,
11271                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11272     parser->lex_defer   = proto->lex_defer;
11273     parser->lex_dojoin  = proto->lex_dojoin;
11274     parser->lex_expect  = proto->lex_expect;
11275     parser->lex_formbrack = proto->lex_formbrack;
11276     parser->lex_inpat   = proto->lex_inpat;
11277     parser->lex_inwhat  = proto->lex_inwhat;
11278     parser->lex_op      = proto->lex_op;
11279     parser->lex_repl    = sv_dup_inc(proto->lex_repl, param);
11280     parser->lex_starts  = proto->lex_starts;
11281     parser->lex_stuff   = sv_dup_inc(proto->lex_stuff, param);
11282     parser->multi_close = proto->multi_close;
11283     parser->multi_open  = proto->multi_open;
11284     parser->multi_start = proto->multi_start;
11285     parser->multi_end   = proto->multi_end;
11286     parser->pending_ident = proto->pending_ident;
11287     parser->preambled   = proto->preambled;
11288     parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11289     parser->linestr     = sv_dup_inc(proto->linestr, param);
11290     parser->expect      = proto->expect;
11291     parser->copline     = proto->copline;
11292     parser->last_lop_op = proto->last_lop_op;
11293     parser->lex_state   = proto->lex_state;
11294     parser->rsfp        = fp_dup(proto->rsfp, '<', param);
11295     /* rsfp_filters entries have fake IoDIRP() */
11296     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11297     parser->in_my       = proto->in_my;
11298     parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11299     parser->error_count = proto->error_count;
11300
11301
11302     parser->linestr     = sv_dup_inc(proto->linestr, param);
11303
11304     {
11305         char * const ols = SvPVX(proto->linestr);
11306         char * const ls  = SvPVX(parser->linestr);
11307
11308         parser->bufptr      = ls + (proto->bufptr >= ols ?
11309                                     proto->bufptr -  ols : 0);
11310         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
11311                                     proto->oldbufptr -  ols : 0);
11312         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11313                                     proto->oldoldbufptr -  ols : 0);
11314         parser->linestart   = ls + (proto->linestart >= ols ?
11315                                     proto->linestart -  ols : 0);
11316         parser->last_uni    = ls + (proto->last_uni >= ols ?
11317                                     proto->last_uni -  ols : 0);
11318         parser->last_lop    = ls + (proto->last_lop >= ols ?
11319                                     proto->last_lop -  ols : 0);
11320
11321         parser->bufend      = ls + SvCUR(parser->linestr);
11322     }
11323
11324     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11325
11326
11327 #ifdef PERL_MAD
11328     parser->endwhite    = proto->endwhite;
11329     parser->faketokens  = proto->faketokens;
11330     parser->lasttoke    = proto->lasttoke;
11331     parser->nextwhite   = proto->nextwhite;
11332     parser->realtokenstart = proto->realtokenstart;
11333     parser->skipwhite   = proto->skipwhite;
11334     parser->thisclose   = proto->thisclose;
11335     parser->thismad     = proto->thismad;
11336     parser->thisopen    = proto->thisopen;
11337     parser->thisstuff   = proto->thisstuff;
11338     parser->thistoken   = proto->thistoken;
11339     parser->thiswhite   = proto->thiswhite;
11340
11341     Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11342     parser->curforce    = proto->curforce;
11343 #else
11344     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11345     Copy(proto->nexttype, parser->nexttype, 5,  I32);
11346     parser->nexttoke    = proto->nexttoke;
11347 #endif
11348
11349     /* XXX should clone saved_curcop here, but we aren't passed
11350      * proto_perl; so do it in perl_clone_using instead */
11351
11352     return parser;
11353 }
11354
11355
11356 /* duplicate a file handle */
11357
11358 PerlIO *
11359 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11360 {
11361     PerlIO *ret;
11362
11363     PERL_ARGS_ASSERT_FP_DUP;
11364     PERL_UNUSED_ARG(type);
11365
11366     if (!fp)
11367         return (PerlIO*)NULL;
11368
11369     /* look for it in the table first */
11370     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11371     if (ret)
11372         return ret;
11373
11374     /* create anew and remember what it is */
11375     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11376     ptr_table_store(PL_ptr_table, fp, ret);
11377     return ret;
11378 }
11379
11380 /* duplicate a directory handle */
11381
11382 DIR *
11383 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11384 {
11385     DIR *ret;
11386
11387 #ifdef HAS_FCHDIR
11388     DIR *pwd;
11389     register const Direntry_t *dirent;
11390     char smallbuf[256];
11391     char *name = NULL;
11392     STRLEN len = 0;
11393     long pos;
11394 #endif
11395
11396     PERL_UNUSED_CONTEXT;
11397     PERL_ARGS_ASSERT_DIRP_DUP;
11398
11399     if (!dp)
11400         return (DIR*)NULL;
11401
11402     /* look for it in the table first */
11403     ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11404     if (ret)
11405         return ret;
11406
11407 #ifdef HAS_FCHDIR
11408
11409     PERL_UNUSED_ARG(param);
11410
11411     /* create anew */
11412
11413     /* open the current directory (so we can switch back) */
11414     if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11415
11416     /* chdir to our dir handle and open the present working directory */
11417     if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11418         PerlDir_close(pwd);
11419         return (DIR *)NULL;
11420     }
11421     /* Now we should have two dir handles pointing to the same dir. */
11422
11423     /* Be nice to the calling code and chdir back to where we were. */
11424     fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11425
11426     /* We have no need of the pwd handle any more. */
11427     PerlDir_close(pwd);
11428
11429 #ifdef DIRNAMLEN
11430 # define d_namlen(d) (d)->d_namlen
11431 #else
11432 # define d_namlen(d) strlen((d)->d_name)
11433 #endif
11434     /* Iterate once through dp, to get the file name at the current posi-
11435        tion. Then step back. */
11436     pos = PerlDir_tell(dp);
11437     if ((dirent = PerlDir_read(dp))) {
11438         len = d_namlen(dirent);
11439         if (len <= sizeof smallbuf) name = smallbuf;
11440         else Newx(name, len, char);
11441         Move(dirent->d_name, name, len, char);
11442     }
11443     PerlDir_seek(dp, pos);
11444
11445     /* Iterate through the new dir handle, till we find a file with the
11446        right name. */
11447     if (!dirent) /* just before the end */
11448         for(;;) {
11449             pos = PerlDir_tell(ret);
11450             if (PerlDir_read(ret)) continue; /* not there yet */
11451             PerlDir_seek(ret, pos); /* step back */
11452             break;
11453         }
11454     else {
11455         const long pos0 = PerlDir_tell(ret);
11456         for(;;) {
11457             pos = PerlDir_tell(ret);
11458             if ((dirent = PerlDir_read(ret))) {
11459                 if (len == d_namlen(dirent)
11460                  && memEQ(name, dirent->d_name, len)) {
11461                     /* found it */
11462                     PerlDir_seek(ret, pos); /* step back */
11463                     break;
11464                 }
11465                 /* else we are not there yet; keep iterating */
11466             }
11467             else { /* This is not meant to happen. The best we can do is
11468                       reset the iterator to the beginning. */
11469                 PerlDir_seek(ret, pos0);
11470                 break;
11471             }
11472         }
11473     }
11474 #undef d_namlen
11475
11476     if (name && name != smallbuf)
11477         Safefree(name);
11478 #endif
11479
11480 #ifdef WIN32
11481     ret = win32_dirp_dup(dp, param);
11482 #endif
11483
11484     /* pop it in the pointer table */
11485     if (ret)
11486         ptr_table_store(PL_ptr_table, dp, ret);
11487
11488     return ret;
11489 }
11490
11491 /* duplicate a typeglob */
11492
11493 GP *
11494 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11495 {
11496     GP *ret;
11497
11498     PERL_ARGS_ASSERT_GP_DUP;
11499
11500     if (!gp)
11501         return (GP*)NULL;
11502     /* look for it in the table first */
11503     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11504     if (ret)
11505         return ret;
11506
11507     /* create anew and remember what it is */
11508     Newxz(ret, 1, GP);
11509     ptr_table_store(PL_ptr_table, gp, ret);
11510
11511     /* clone */
11512     /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11513        on Newxz() to do this for us.  */
11514     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
11515     ret->gp_io          = io_dup_inc(gp->gp_io, param);
11516     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
11517     ret->gp_av          = av_dup_inc(gp->gp_av, param);
11518     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
11519     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11520     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
11521     ret->gp_cvgen       = gp->gp_cvgen;
11522     ret->gp_line        = gp->gp_line;
11523     ret->gp_file_hek    = hek_dup(gp->gp_file_hek, param);
11524     return ret;
11525 }
11526
11527 /* duplicate a chain of magic */
11528
11529 MAGIC *
11530 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11531 {
11532     MAGIC *mgret = NULL;
11533     MAGIC **mgprev_p = &mgret;
11534
11535     PERL_ARGS_ASSERT_MG_DUP;
11536
11537     for (; mg; mg = mg->mg_moremagic) {
11538         MAGIC *nmg;
11539
11540         if ((param->flags & CLONEf_JOIN_IN)
11541                 && mg->mg_type == PERL_MAGIC_backref)
11542             /* when joining, we let the individual SVs add themselves to
11543              * backref as needed. */
11544             continue;
11545
11546         Newx(nmg, 1, MAGIC);
11547         *mgprev_p = nmg;
11548         mgprev_p = &(nmg->mg_moremagic);
11549
11550         /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11551            dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11552            from the original commit adding Perl_mg_dup() - revision 4538.
11553            Similarly there is the annotation "XXX random ptr?" next to the
11554            assignment to nmg->mg_ptr.  */
11555         *nmg = *mg;
11556
11557         /* FIXME for plugins
11558         if (nmg->mg_type == PERL_MAGIC_qr) {
11559             nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11560         }
11561         else
11562         */
11563         nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11564                           ? nmg->mg_type == PERL_MAGIC_backref
11565                                 /* The backref AV has its reference
11566                                  * count deliberately bumped by 1 */
11567                                 ? SvREFCNT_inc(av_dup_inc((const AV *)
11568                                                     nmg->mg_obj, param))
11569                                 : sv_dup_inc(nmg->mg_obj, param)
11570                           : sv_dup(nmg->mg_obj, param);
11571
11572         if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11573             if (nmg->mg_len > 0) {
11574                 nmg->mg_ptr     = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11575                 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11576                         AMT_AMAGIC((AMT*)nmg->mg_ptr))
11577                 {
11578                     AMT * const namtp = (AMT*)nmg->mg_ptr;
11579                     sv_dup_inc_multiple((SV**)(namtp->table),
11580                                         (SV**)(namtp->table), NofAMmeth, param);
11581                 }
11582             }
11583             else if (nmg->mg_len == HEf_SVKEY)
11584                 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11585         }
11586         if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11587             nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11588         }
11589     }
11590     return mgret;
11591 }
11592
11593 #endif /* USE_ITHREADS */
11594
11595 struct ptr_tbl_arena {
11596     struct ptr_tbl_arena *next;
11597     struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers.  */
11598 };
11599
11600 /* create a new pointer-mapping table */
11601
11602 PTR_TBL_t *
11603 Perl_ptr_table_new(pTHX)
11604 {
11605     PTR_TBL_t *tbl;
11606     PERL_UNUSED_CONTEXT;
11607
11608     Newx(tbl, 1, PTR_TBL_t);
11609     tbl->tbl_max        = 511;
11610     tbl->tbl_items      = 0;
11611     tbl->tbl_arena      = NULL;
11612     tbl->tbl_arena_next = NULL;
11613     tbl->tbl_arena_end  = NULL;
11614     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11615     return tbl;
11616 }
11617
11618 #define PTR_TABLE_HASH(ptr) \
11619   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11620
11621 /* map an existing pointer using a table */
11622
11623 STATIC PTR_TBL_ENT_t *
11624 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11625 {
11626     PTR_TBL_ENT_t *tblent;
11627     const UV hash = PTR_TABLE_HASH(sv);
11628
11629     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11630
11631     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11632     for (; tblent; tblent = tblent->next) {
11633         if (tblent->oldval == sv)
11634             return tblent;
11635     }
11636     return NULL;
11637 }
11638
11639 void *
11640 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11641 {
11642     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11643
11644     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11645     PERL_UNUSED_CONTEXT;
11646
11647     return tblent ? tblent->newval : NULL;
11648 }
11649
11650 /* add a new entry to a pointer-mapping table */
11651
11652 void
11653 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
11654 {
11655     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
11656
11657     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
11658     PERL_UNUSED_CONTEXT;
11659
11660     if (tblent) {
11661         tblent->newval = newsv;
11662     } else {
11663         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
11664
11665         if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
11666             struct ptr_tbl_arena *new_arena;
11667
11668             Newx(new_arena, 1, struct ptr_tbl_arena);
11669             new_arena->next = tbl->tbl_arena;
11670             tbl->tbl_arena = new_arena;
11671             tbl->tbl_arena_next = new_arena->array;
11672             tbl->tbl_arena_end = new_arena->array
11673                 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
11674         }
11675
11676         tblent = tbl->tbl_arena_next++;
11677
11678         tblent->oldval = oldsv;
11679         tblent->newval = newsv;
11680         tblent->next = tbl->tbl_ary[entry];
11681         tbl->tbl_ary[entry] = tblent;
11682         tbl->tbl_items++;
11683         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
11684             ptr_table_split(tbl);
11685     }
11686 }
11687
11688 /* double the hash bucket size of an existing ptr table */
11689
11690 void
11691 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
11692 {
11693     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
11694     const UV oldsize = tbl->tbl_max + 1;
11695     UV newsize = oldsize * 2;
11696     UV i;
11697
11698     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11699     PERL_UNUSED_CONTEXT;
11700
11701     Renew(ary, newsize, PTR_TBL_ENT_t*);
11702     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11703     tbl->tbl_max = --newsize;
11704     tbl->tbl_ary = ary;
11705     for (i=0; i < oldsize; i++, ary++) {
11706         PTR_TBL_ENT_t **entp = ary;
11707         PTR_TBL_ENT_t *ent = *ary;
11708         PTR_TBL_ENT_t **curentp;
11709         if (!ent)
11710             continue;
11711         curentp = ary + oldsize;
11712         do {
11713             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11714                 *entp = ent->next;
11715                 ent->next = *curentp;
11716                 *curentp = ent;
11717             }
11718             else
11719                 entp = &ent->next;
11720             ent = *entp;
11721         } while (ent);
11722     }
11723 }
11724
11725 /* remove all the entries from a ptr table */
11726 /* Deprecated - will be removed post 5.14 */
11727
11728 void
11729 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11730 {
11731     if (tbl && tbl->tbl_items) {
11732         struct ptr_tbl_arena *arena = tbl->tbl_arena;
11733
11734         Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11735
11736         while (arena) {
11737             struct ptr_tbl_arena *next = arena->next;
11738
11739             Safefree(arena);
11740             arena = next;
11741         };
11742
11743         tbl->tbl_items = 0;
11744         tbl->tbl_arena = NULL;
11745         tbl->tbl_arena_next = NULL;
11746         tbl->tbl_arena_end = NULL;
11747     }
11748 }
11749
11750 /* clear and free a ptr table */
11751
11752 void
11753 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11754 {
11755     struct ptr_tbl_arena *arena;
11756
11757     if (!tbl) {
11758         return;
11759     }
11760
11761     arena = tbl->tbl_arena;
11762
11763     while (arena) {
11764         struct ptr_tbl_arena *next = arena->next;
11765
11766         Safefree(arena);
11767         arena = next;
11768     }
11769
11770     Safefree(tbl->tbl_ary);
11771     Safefree(tbl);
11772 }
11773
11774 #if defined(USE_ITHREADS)
11775
11776 void
11777 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11778 {
11779     PERL_ARGS_ASSERT_RVPV_DUP;
11780
11781     if (SvROK(sstr)) {
11782         if (SvWEAKREF(sstr)) {
11783             SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11784             if (param->flags & CLONEf_JOIN_IN) {
11785                 /* if joining, we add any back references individually rather
11786                  * than copying the whole backref array */
11787                 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11788             }
11789         }
11790         else
11791             SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11792     }
11793     else if (SvPVX_const(sstr)) {
11794         /* Has something there */
11795         if (SvLEN(sstr)) {
11796             /* Normal PV - clone whole allocated space */
11797             SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11798             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11799                 /* Not that normal - actually sstr is copy on write.
11800                    But we are a true, independent SV, so:  */
11801                 SvREADONLY_off(dstr);
11802                 SvFAKE_off(dstr);
11803             }
11804         }
11805         else {
11806             /* Special case - not normally malloced for some reason */
11807             if (isGV_with_GP(sstr)) {
11808                 /* Don't need to do anything here.  */
11809             }
11810             else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11811                 /* A "shared" PV - clone it as "shared" PV */
11812                 SvPV_set(dstr,
11813                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11814                                          param)));
11815             }
11816             else {
11817                 /* Some other special case - random pointer */
11818                 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11819             }
11820         }
11821     }
11822     else {
11823         /* Copy the NULL */
11824         SvPV_set(dstr, NULL);
11825     }
11826 }
11827
11828 /* duplicate a list of SVs. source and dest may point to the same memory.  */
11829 static SV **
11830 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11831                       SSize_t items, CLONE_PARAMS *const param)
11832 {
11833     PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11834
11835     while (items-- > 0) {
11836         *dest++ = sv_dup_inc(*source++, param);
11837     }
11838
11839     return dest;
11840 }
11841
11842 /* duplicate an SV of any type (including AV, HV etc) */
11843
11844 static SV *
11845 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11846 {
11847     dVAR;
11848     SV *dstr;
11849
11850     PERL_ARGS_ASSERT_SV_DUP_COMMON;
11851
11852     if (SvTYPE(sstr) == (svtype)SVTYPEMASK) {
11853 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11854         abort();
11855 #endif
11856         return NULL;
11857     }
11858     /* look for it in the table first */
11859     dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11860     if (dstr)
11861         return dstr;
11862
11863     if(param->flags & CLONEf_JOIN_IN) {
11864         /** We are joining here so we don't want do clone
11865             something that is bad **/
11866         if (SvTYPE(sstr) == SVt_PVHV) {
11867             const HEK * const hvname = HvNAME_HEK(sstr);
11868             if (hvname) {
11869                 /** don't clone stashes if they already exist **/
11870                 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
11871                                                 HEK_UTF8(hvname) ? SVf_UTF8 : 0));
11872                 ptr_table_store(PL_ptr_table, sstr, dstr);
11873                 return dstr;
11874             }
11875         }
11876         else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
11877             HV *stash = GvSTASH(sstr);
11878             const HEK * hvname;
11879             if (stash && (hvname = HvNAME_HEK(stash))) {
11880                 /** don't clone GVs if they already exist **/
11881                 SV **svp;
11882                 stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
11883                                     HEK_UTF8(hvname) ? SVf_UTF8 : 0);
11884                 svp = hv_fetch(
11885                         stash, GvNAME(sstr),
11886                         GvNAMEUTF8(sstr)
11887                             ? -GvNAMELEN(sstr)
11888                             :  GvNAMELEN(sstr),
11889                         0
11890                       );
11891                 if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
11892                     ptr_table_store(PL_ptr_table, sstr, *svp);
11893                     return *svp;
11894                 }
11895             }
11896         }
11897     }
11898
11899     /* create anew and remember what it is */
11900     new_SV(dstr);
11901
11902 #ifdef DEBUG_LEAKING_SCALARS
11903     dstr->sv_debug_optype = sstr->sv_debug_optype;
11904     dstr->sv_debug_line = sstr->sv_debug_line;
11905     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11906     dstr->sv_debug_parent = (SV*)sstr;
11907     FREE_SV_DEBUG_FILE(dstr);
11908     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11909 #endif
11910
11911     ptr_table_store(PL_ptr_table, sstr, dstr);
11912
11913     /* clone */
11914     SvFLAGS(dstr)       = SvFLAGS(sstr);
11915     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
11916     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
11917
11918 #ifdef DEBUGGING
11919     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11920         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11921                       (void*)PL_watch_pvx, SvPVX_const(sstr));
11922 #endif
11923
11924     /* don't clone objects whose class has asked us not to */
11925     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11926         SvFLAGS(dstr) = 0;
11927         return dstr;
11928     }
11929
11930     switch (SvTYPE(sstr)) {
11931     case SVt_NULL:
11932         SvANY(dstr)     = NULL;
11933         break;
11934     case SVt_IV:
11935         SvANY(dstr)     = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11936         if(SvROK(sstr)) {
11937             Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11938         } else {
11939             SvIV_set(dstr, SvIVX(sstr));
11940         }
11941         break;
11942     case SVt_NV:
11943         SvANY(dstr)     = new_XNV();
11944         SvNV_set(dstr, SvNVX(sstr));
11945         break;
11946         /* case SVt_BIND: */
11947     default:
11948         {
11949             /* These are all the types that need complex bodies allocating.  */
11950             void *new_body;
11951             const svtype sv_type = SvTYPE(sstr);
11952             const struct body_details *const sv_type_details
11953                 = bodies_by_type + sv_type;
11954
11955             switch (sv_type) {
11956             default:
11957                 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11958                 break;
11959
11960             case SVt_PVGV:
11961             case SVt_PVIO:
11962             case SVt_PVFM:
11963             case SVt_PVHV:
11964             case SVt_PVAV:
11965             case SVt_PVCV:
11966             case SVt_PVLV:
11967             case SVt_REGEXP:
11968             case SVt_PVMG:
11969             case SVt_PVNV:
11970             case SVt_PVIV:
11971             case SVt_PV:
11972                 assert(sv_type_details->body_size);
11973                 if (sv_type_details->arena) {
11974                     new_body_inline(new_body, sv_type);
11975                     new_body
11976                         = (void*)((char*)new_body - sv_type_details->offset);
11977                 } else {
11978                     new_body = new_NOARENA(sv_type_details);
11979                 }
11980             }
11981             assert(new_body);
11982             SvANY(dstr) = new_body;
11983
11984 #ifndef PURIFY
11985             Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11986                  ((char*)SvANY(dstr)) + sv_type_details->offset,
11987                  sv_type_details->copy, char);
11988 #else
11989             Copy(((char*)SvANY(sstr)),
11990                  ((char*)SvANY(dstr)),
11991                  sv_type_details->body_size + sv_type_details->offset, char);
11992 #endif
11993
11994             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11995                 && !isGV_with_GP(dstr)
11996                 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11997                 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11998
11999             /* The Copy above means that all the source (unduplicated) pointers
12000                are now in the destination.  We can check the flags and the
12001                pointers in either, but it's possible that there's less cache
12002                missing by always going for the destination.
12003                FIXME - instrument and check that assumption  */
12004             if (sv_type >= SVt_PVMG) {
12005                 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
12006                     SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
12007                 } else if (SvMAGIC(dstr))
12008                     SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
12009                 if (SvSTASH(dstr))
12010                     SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
12011             }
12012
12013             /* The cast silences a GCC warning about unhandled types.  */
12014             switch ((int)sv_type) {
12015             case SVt_PV:
12016                 break;
12017             case SVt_PVIV:
12018                 break;
12019             case SVt_PVNV:
12020                 break;
12021             case SVt_PVMG:
12022                 break;
12023             case SVt_REGEXP:
12024                 /* FIXME for plugins */
12025                 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
12026                 break;
12027             case SVt_PVLV:
12028                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
12029                 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
12030                     LvTARG(dstr) = dstr;
12031                 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
12032                     LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
12033                 else
12034                     LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
12035             case SVt_PVGV:
12036                 /* non-GP case already handled above */
12037                 if(isGV_with_GP(sstr)) {
12038                     GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
12039                     /* Don't call sv_add_backref here as it's going to be
12040                        created as part of the magic cloning of the symbol
12041                        table--unless this is during a join and the stash
12042                        is not actually being cloned.  */
12043                     /* Danger Will Robinson - GvGP(dstr) isn't initialised
12044                        at the point of this comment.  */
12045                     GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
12046                     if (param->flags & CLONEf_JOIN_IN)
12047                         Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
12048                     GvGP_set(dstr, gp_dup(GvGP(sstr), param));
12049                     (void)GpREFCNT_inc(GvGP(dstr));
12050                 }
12051                 break;
12052             case SVt_PVIO:
12053                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
12054                 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
12055                     /* I have no idea why fake dirp (rsfps)
12056                        should be treated differently but otherwise
12057                        we end up with leaks -- sky*/
12058                     IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
12059                     IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
12060                     IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
12061                 } else {
12062                     IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
12063                     IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
12064                     IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
12065                     if (IoDIRP(dstr)) {
12066                         IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr), param);
12067                     } else {
12068                         NOOP;
12069                         /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
12070                     }
12071                     IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
12072                 }
12073                 if (IoOFP(dstr) == IoIFP(sstr))
12074                     IoOFP(dstr) = IoIFP(dstr);
12075                 else
12076                     IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
12077                 IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
12078                 IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
12079                 IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
12080                 break;
12081             case SVt_PVAV:
12082                 /* avoid cloning an empty array */
12083                 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
12084                     SV **dst_ary, **src_ary;
12085                     SSize_t items = AvFILLp((const AV *)sstr) + 1;
12086
12087                     src_ary = AvARRAY((const AV *)sstr);
12088                     Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
12089                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
12090                     AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
12091                     AvALLOC((const AV *)dstr) = dst_ary;
12092                     if (AvREAL((const AV *)sstr)) {
12093                         dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
12094                                                       param);
12095                     }
12096                     else {
12097                         while (items-- > 0)
12098                             *dst_ary++ = sv_dup(*src_ary++, param);
12099                     }
12100                     items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
12101                     while (items-- > 0) {
12102                         *dst_ary++ = &PL_sv_undef;
12103                     }
12104                 }
12105                 else {
12106                     AvARRAY(MUTABLE_AV(dstr))   = NULL;
12107                     AvALLOC((const AV *)dstr)   = (SV**)NULL;
12108                     AvMAX(  (const AV *)dstr)   = -1;
12109                     AvFILLp((const AV *)dstr)   = -1;
12110                 }
12111                 break;
12112             case SVt_PVHV:
12113                 if (HvARRAY((const HV *)sstr)) {
12114                     STRLEN i = 0;
12115                     const bool sharekeys = !!HvSHAREKEYS(sstr);
12116                     XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
12117                     XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
12118                     char *darray;
12119                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
12120                         + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
12121                         char);
12122                     HvARRAY(dstr) = (HE**)darray;
12123                     while (i <= sxhv->xhv_max) {
12124                         const HE * const source = HvARRAY(sstr)[i];
12125                         HvARRAY(dstr)[i] = source
12126                             ? he_dup(source, sharekeys, param) : 0;
12127                         ++i;
12128                     }
12129                     if (SvOOK(sstr)) {
12130                         const struct xpvhv_aux * const saux = HvAUX(sstr);
12131                         struct xpvhv_aux * const daux = HvAUX(dstr);
12132                         /* This flag isn't copied.  */
12133                         SvOOK_on(dstr);
12134
12135                         if (saux->xhv_name_count) {
12136                             HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
12137                             const I32 count
12138                              = saux->xhv_name_count < 0
12139                                 ? -saux->xhv_name_count
12140                                 :  saux->xhv_name_count;
12141                             HEK **shekp = sname + count;
12142                             HEK **dhekp;
12143                             Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
12144                             dhekp = daux->xhv_name_u.xhvnameu_names + count;
12145                             while (shekp-- > sname) {
12146                                 dhekp--;
12147                                 *dhekp = hek_dup(*shekp, param);
12148                             }
12149                         }
12150                         else {
12151                             daux->xhv_name_u.xhvnameu_name
12152                                 = hek_dup(saux->xhv_name_u.xhvnameu_name,
12153                                           param);
12154                         }
12155                         daux->xhv_name_count = saux->xhv_name_count;
12156
12157                         daux->xhv_riter = saux->xhv_riter;
12158                         daux->xhv_eiter = saux->xhv_eiter
12159                             ? he_dup(saux->xhv_eiter,
12160                                         cBOOL(HvSHAREKEYS(sstr)), param) : 0;
12161                         /* backref array needs refcnt=2; see sv_add_backref */
12162                         daux->xhv_backreferences =
12163                             (param->flags & CLONEf_JOIN_IN)
12164                                 /* when joining, we let the individual GVs and
12165                                  * CVs add themselves to backref as
12166                                  * needed. This avoids pulling in stuff
12167                                  * that isn't required, and simplifies the
12168                                  * case where stashes aren't cloned back
12169                                  * if they already exist in the parent
12170                                  * thread */
12171                             ? NULL
12172                             : saux->xhv_backreferences
12173                                 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
12174                                     ? MUTABLE_AV(SvREFCNT_inc(
12175                                           sv_dup_inc((const SV *)
12176                                             saux->xhv_backreferences, param)))
12177                                     : MUTABLE_AV(sv_dup((const SV *)
12178                                             saux->xhv_backreferences, param))
12179                                 : 0;
12180
12181                         daux->xhv_mro_meta = saux->xhv_mro_meta
12182                             ? mro_meta_dup(saux->xhv_mro_meta, param)
12183                             : 0;
12184
12185                         /* Record stashes for possible cloning in Perl_clone(). */
12186                         if (HvNAME(sstr))
12187                             av_push(param->stashes, dstr);
12188                     }
12189                 }
12190                 else
12191                     HvARRAY(MUTABLE_HV(dstr)) = NULL;
12192                 break;
12193             case SVt_PVCV:
12194                 if (!(param->flags & CLONEf_COPY_STACKS)) {
12195                     CvDEPTH(dstr) = 0;
12196                 }
12197                 /*FALLTHROUGH*/
12198             case SVt_PVFM:
12199                 /* NOTE: not refcounted */
12200                 SvANY(MUTABLE_CV(dstr))->xcv_stash =
12201                     hv_dup(CvSTASH(dstr), param);
12202                 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
12203                     Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
12204                 if (!CvISXSUB(dstr)) {
12205                     OP_REFCNT_LOCK;
12206                     CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
12207                     OP_REFCNT_UNLOCK;
12208                 } else if (CvCONST(dstr)) {
12209                     CvXSUBANY(dstr).any_ptr =
12210                         sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
12211                 }
12212                 if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
12213                 /* don't dup if copying back - CvGV isn't refcounted, so the
12214                  * duped GV may never be freed. A bit of a hack! DAPM */
12215                 SvANY(MUTABLE_CV(dstr))->xcv_gv =
12216                     CvCVGV_RC(dstr)
12217                     ? gv_dup_inc(CvGV(sstr), param)
12218                     : (param->flags & CLONEf_JOIN_IN)
12219                         ? NULL
12220                         : gv_dup(CvGV(sstr), param);
12221
12222                 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
12223                 CvOUTSIDE(dstr) =
12224                     CvWEAKOUTSIDE(sstr)
12225                     ? cv_dup(    CvOUTSIDE(dstr), param)
12226                     : cv_dup_inc(CvOUTSIDE(dstr), param);
12227                 break;
12228             }
12229         }
12230     }
12231
12232     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
12233         ++PL_sv_objcount;
12234
12235     return dstr;
12236  }
12237
12238 SV *
12239 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12240 {
12241     PERL_ARGS_ASSERT_SV_DUP_INC;
12242     return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
12243 }
12244
12245 SV *
12246 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12247 {
12248     SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
12249     PERL_ARGS_ASSERT_SV_DUP;
12250
12251     /* Track every SV that (at least initially) had a reference count of 0.
12252        We need to do this by holding an actual reference to it in this array.
12253        If we attempt to cheat, turn AvREAL_off(), and store only pointers
12254        (akin to the stashes hash, and the perl stack), we come unstuck if
12255        a weak reference (or other SV legitimately SvREFCNT() == 0 for this
12256        thread) is manipulated in a CLONE method, because CLONE runs before the
12257        unreferenced array is walked to find SVs still with SvREFCNT() == 0
12258        (and fix things up by giving each a reference via the temps stack).
12259        Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
12260        then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
12261        before the walk of unreferenced happens and a reference to that is SV
12262        added to the temps stack. At which point we have the same SV considered
12263        to be in use, and free to be re-used. Not good.
12264     */
12265     if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
12266         assert(param->unreferenced);
12267         av_push(param->unreferenced, SvREFCNT_inc(dstr));
12268     }
12269
12270     return dstr;
12271 }
12272
12273 /* duplicate a context */
12274
12275 PERL_CONTEXT *
12276 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12277 {
12278     PERL_CONTEXT *ncxs;
12279
12280     PERL_ARGS_ASSERT_CX_DUP;
12281
12282     if (!cxs)
12283         return (PERL_CONTEXT*)NULL;
12284
12285     /* look for it in the table first */
12286     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12287     if (ncxs)
12288         return ncxs;
12289
12290     /* create anew and remember what it is */
12291     Newx(ncxs, max + 1, PERL_CONTEXT);
12292     ptr_table_store(PL_ptr_table, cxs, ncxs);
12293     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12294
12295     while (ix >= 0) {
12296         PERL_CONTEXT * const ncx = &ncxs[ix];
12297         if (CxTYPE(ncx) == CXt_SUBST) {
12298             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12299         }
12300         else {
12301             switch (CxTYPE(ncx)) {
12302             case CXt_SUB:
12303                 ncx->blk_sub.cv         = (ncx->blk_sub.olddepth == 0
12304                                            ? cv_dup_inc(ncx->blk_sub.cv, param)
12305                                            : cv_dup(ncx->blk_sub.cv,param));
12306                 ncx->blk_sub.argarray   = (CxHASARGS(ncx)
12307                                            ? av_dup_inc(ncx->blk_sub.argarray,
12308                                                         param)
12309                                            : NULL);
12310                 ncx->blk_sub.savearray  = av_dup_inc(ncx->blk_sub.savearray,
12311                                                      param);
12312                 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12313                                            ncx->blk_sub.oldcomppad);
12314                 break;
12315             case CXt_EVAL:
12316                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12317                                                       param);
12318                 ncx->blk_eval.cur_text  = sv_dup(ncx->blk_eval.cur_text, param);
12319                 ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
12320                 break;
12321             case CXt_LOOP_LAZYSV:
12322                 ncx->blk_loop.state_u.lazysv.end
12323                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12324                 /* We are taking advantage of av_dup_inc and sv_dup_inc
12325                    actually being the same function, and order equivalence of
12326                    the two unions.
12327                    We can assert the later [but only at run time :-(]  */
12328                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12329                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
12330             case CXt_LOOP_FOR:
12331                 ncx->blk_loop.state_u.ary.ary
12332                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12333             case CXt_LOOP_LAZYIV:
12334             case CXt_LOOP_PLAIN:
12335                 if (CxPADLOOP(ncx)) {
12336                     ncx->blk_loop.itervar_u.oldcomppad
12337                         = (PAD*)ptr_table_fetch(PL_ptr_table,
12338                                         ncx->blk_loop.itervar_u.oldcomppad);
12339                 } else {
12340                     ncx->blk_loop.itervar_u.gv
12341                         = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12342                                     param);
12343                 }
12344                 break;
12345             case CXt_FORMAT:
12346                 ncx->blk_format.cv      = cv_dup(ncx->blk_format.cv, param);
12347                 ncx->blk_format.gv      = gv_dup(ncx->blk_format.gv, param);
12348                 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12349                                                      param);
12350                 break;
12351             case CXt_BLOCK:
12352             case CXt_NULL:
12353             case CXt_WHEN:
12354             case CXt_GIVEN:
12355                 break;
12356             }
12357         }
12358         --ix;
12359     }
12360     return ncxs;
12361 }
12362
12363 /* duplicate a stack info structure */
12364
12365 PERL_SI *
12366 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12367 {
12368     PERL_SI *nsi;
12369
12370     PERL_ARGS_ASSERT_SI_DUP;
12371
12372     if (!si)
12373         return (PERL_SI*)NULL;
12374
12375     /* look for it in the table first */
12376     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12377     if (nsi)
12378         return nsi;
12379
12380     /* create anew and remember what it is */
12381     Newxz(nsi, 1, PERL_SI);
12382     ptr_table_store(PL_ptr_table, si, nsi);
12383
12384     nsi->si_stack       = av_dup_inc(si->si_stack, param);
12385     nsi->si_cxix        = si->si_cxix;
12386     nsi->si_cxmax       = si->si_cxmax;
12387     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12388     nsi->si_type        = si->si_type;
12389     nsi->si_prev        = si_dup(si->si_prev, param);
12390     nsi->si_next        = si_dup(si->si_next, param);
12391     nsi->si_markoff     = si->si_markoff;
12392
12393     return nsi;
12394 }
12395
12396 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
12397 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
12398 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
12399 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
12400 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
12401 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
12402 #define POPUV(ss,ix)    ((ss)[--(ix)].any_uv)
12403 #define TOPUV(ss,ix)    ((ss)[ix].any_uv)
12404 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
12405 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
12406 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
12407 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
12408 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
12409 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
12410 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12411 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12412
12413 /* XXXXX todo */
12414 #define pv_dup_inc(p)   SAVEPV(p)
12415 #define pv_dup(p)       SAVEPV(p)
12416 #define svp_dup_inc(p,pp)       any_dup(p,pp)
12417
12418 /* map any object to the new equivent - either something in the
12419  * ptr table, or something in the interpreter structure
12420  */
12421
12422 void *
12423 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12424 {
12425     void *ret;
12426
12427     PERL_ARGS_ASSERT_ANY_DUP;
12428
12429     if (!v)
12430         return (void*)NULL;
12431
12432     /* look for it in the table first */
12433     ret = ptr_table_fetch(PL_ptr_table, v);
12434     if (ret)
12435         return ret;
12436
12437     /* see if it is part of the interpreter structure */
12438     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12439         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12440     else {
12441         ret = v;
12442     }
12443
12444     return ret;
12445 }
12446
12447 /* duplicate the save stack */
12448
12449 ANY *
12450 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12451 {
12452     dVAR;
12453     ANY * const ss      = proto_perl->Isavestack;
12454     const I32 max       = proto_perl->Isavestack_max;
12455     I32 ix              = proto_perl->Isavestack_ix;
12456     ANY *nss;
12457     const SV *sv;
12458     const GV *gv;
12459     const AV *av;
12460     const HV *hv;
12461     void* ptr;
12462     int intval;
12463     long longval;
12464     GP *gp;
12465     IV iv;
12466     I32 i;
12467     char *c = NULL;
12468     void (*dptr) (void*);
12469     void (*dxptr) (pTHX_ void*);
12470
12471     PERL_ARGS_ASSERT_SS_DUP;
12472
12473     Newxz(nss, max, ANY);
12474
12475     while (ix > 0) {
12476         const UV uv = POPUV(ss,ix);
12477         const U8 type = (U8)uv & SAVE_MASK;
12478
12479         TOPUV(nss,ix) = uv;
12480         switch (type) {
12481         case SAVEt_CLEARSV:
12482             break;
12483         case SAVEt_HELEM:               /* hash element */
12484             sv = (const SV *)POPPTR(ss,ix);
12485             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12486             /* fall through */
12487         case SAVEt_ITEM:                        /* normal string */
12488         case SAVEt_GVSV:                        /* scalar slot in GV */
12489         case SAVEt_SV:                          /* scalar reference */
12490             sv = (const SV *)POPPTR(ss,ix);
12491             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12492             /* fall through */
12493         case SAVEt_FREESV:
12494         case SAVEt_MORTALIZESV:
12495             sv = (const SV *)POPPTR(ss,ix);
12496             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12497             break;
12498         case SAVEt_SHARED_PVREF:                /* char* in shared space */
12499             c = (char*)POPPTR(ss,ix);
12500             TOPPTR(nss,ix) = savesharedpv(c);
12501             ptr = POPPTR(ss,ix);
12502             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12503             break;
12504         case SAVEt_GENERIC_SVREF:               /* generic sv */
12505         case SAVEt_SVREF:                       /* scalar reference */
12506             sv = (const SV *)POPPTR(ss,ix);
12507             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12508             ptr = POPPTR(ss,ix);
12509             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12510             break;
12511         case SAVEt_HV:                          /* hash reference */
12512         case SAVEt_AV:                          /* array reference */
12513             sv = (const SV *) POPPTR(ss,ix);
12514             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12515             /* fall through */
12516         case SAVEt_COMPPAD:
12517         case SAVEt_NSTAB:
12518             sv = (const SV *) POPPTR(ss,ix);
12519             TOPPTR(nss,ix) = sv_dup(sv, param);
12520             break;
12521         case SAVEt_INT:                         /* int reference */
12522             ptr = POPPTR(ss,ix);
12523             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12524             intval = (int)POPINT(ss,ix);
12525             TOPINT(nss,ix) = intval;
12526             break;
12527         case SAVEt_LONG:                        /* long reference */
12528             ptr = POPPTR(ss,ix);
12529             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12530             longval = (long)POPLONG(ss,ix);
12531             TOPLONG(nss,ix) = longval;
12532             break;
12533         case SAVEt_I32:                         /* I32 reference */
12534             ptr = POPPTR(ss,ix);
12535             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12536             i = POPINT(ss,ix);
12537             TOPINT(nss,ix) = i;
12538             break;
12539         case SAVEt_IV:                          /* IV reference */
12540             ptr = POPPTR(ss,ix);
12541             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12542             iv = POPIV(ss,ix);
12543             TOPIV(nss,ix) = iv;
12544             break;
12545         case SAVEt_HPTR:                        /* HV* reference */
12546         case SAVEt_APTR:                        /* AV* reference */
12547         case SAVEt_SPTR:                        /* SV* reference */
12548             ptr = POPPTR(ss,ix);
12549             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12550             sv = (const SV *)POPPTR(ss,ix);
12551             TOPPTR(nss,ix) = sv_dup(sv, param);
12552             break;
12553         case SAVEt_VPTR:                        /* random* reference */
12554             ptr = POPPTR(ss,ix);
12555             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12556             /* Fall through */
12557         case SAVEt_INT_SMALL:
12558         case SAVEt_I32_SMALL:
12559         case SAVEt_I16:                         /* I16 reference */
12560         case SAVEt_I8:                          /* I8 reference */
12561         case SAVEt_BOOL:
12562             ptr = POPPTR(ss,ix);
12563             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12564             break;
12565         case SAVEt_GENERIC_PVREF:               /* generic char* */
12566         case SAVEt_PPTR:                        /* char* reference */
12567             ptr = POPPTR(ss,ix);
12568             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12569             c = (char*)POPPTR(ss,ix);
12570             TOPPTR(nss,ix) = pv_dup(c);
12571             break;
12572         case SAVEt_GP:                          /* scalar reference */
12573             gp = (GP*)POPPTR(ss,ix);
12574             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12575             (void)GpREFCNT_inc(gp);
12576             gv = (const GV *)POPPTR(ss,ix);
12577             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12578             break;
12579         case SAVEt_FREEOP:
12580             ptr = POPPTR(ss,ix);
12581             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12582                 /* these are assumed to be refcounted properly */
12583                 OP *o;
12584                 switch (((OP*)ptr)->op_type) {
12585                 case OP_LEAVESUB:
12586                 case OP_LEAVESUBLV:
12587                 case OP_LEAVEEVAL:
12588                 case OP_LEAVE:
12589                 case OP_SCOPE:
12590                 case OP_LEAVEWRITE:
12591                     TOPPTR(nss,ix) = ptr;
12592                     o = (OP*)ptr;
12593                     OP_REFCNT_LOCK;
12594                     (void) OpREFCNT_inc(o);
12595                     OP_REFCNT_UNLOCK;
12596                     break;
12597                 default:
12598                     TOPPTR(nss,ix) = NULL;
12599                     break;
12600                 }
12601             }
12602             else
12603                 TOPPTR(nss,ix) = NULL;
12604             break;
12605         case SAVEt_FREECOPHH:
12606             ptr = POPPTR(ss,ix);
12607             TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
12608             break;
12609         case SAVEt_DELETE:
12610             hv = (const HV *)POPPTR(ss,ix);
12611             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12612             i = POPINT(ss,ix);
12613             TOPINT(nss,ix) = i;
12614             /* Fall through */
12615         case SAVEt_FREEPV:
12616             c = (char*)POPPTR(ss,ix);
12617             TOPPTR(nss,ix) = pv_dup_inc(c);
12618             break;
12619         case SAVEt_STACK_POS:           /* Position on Perl stack */
12620             i = POPINT(ss,ix);
12621             TOPINT(nss,ix) = i;
12622             break;
12623         case SAVEt_DESTRUCTOR:
12624             ptr = POPPTR(ss,ix);
12625             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
12626             dptr = POPDPTR(ss,ix);
12627             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
12628                                         any_dup(FPTR2DPTR(void *, dptr),
12629                                                 proto_perl));
12630             break;
12631         case SAVEt_DESTRUCTOR_X:
12632             ptr = POPPTR(ss,ix);
12633             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
12634             dxptr = POPDXPTR(ss,ix);
12635             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
12636                                          any_dup(FPTR2DPTR(void *, dxptr),
12637                                                  proto_perl));
12638             break;
12639         case SAVEt_REGCONTEXT:
12640         case SAVEt_ALLOC:
12641             ix -= uv >> SAVE_TIGHT_SHIFT;
12642             break;
12643         case SAVEt_AELEM:               /* array element */
12644             sv = (const SV *)POPPTR(ss,ix);
12645             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12646             i = POPINT(ss,ix);
12647             TOPINT(nss,ix) = i;
12648             av = (const AV *)POPPTR(ss,ix);
12649             TOPPTR(nss,ix) = av_dup_inc(av, param);
12650             break;
12651         case SAVEt_OP:
12652             ptr = POPPTR(ss,ix);
12653             TOPPTR(nss,ix) = ptr;
12654             break;
12655         case SAVEt_HINTS:
12656             ptr = POPPTR(ss,ix);
12657             ptr = cophh_copy((COPHH*)ptr);
12658             TOPPTR(nss,ix) = ptr;
12659             i = POPINT(ss,ix);
12660             TOPINT(nss,ix) = i;
12661             if (i & HINT_LOCALIZE_HH) {
12662                 hv = (const HV *)POPPTR(ss,ix);
12663                 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12664             }
12665             break;
12666         case SAVEt_PADSV_AND_MORTALIZE:
12667             longval = (long)POPLONG(ss,ix);
12668             TOPLONG(nss,ix) = longval;
12669             ptr = POPPTR(ss,ix);
12670             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12671             sv = (const SV *)POPPTR(ss,ix);
12672             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12673             break;
12674         case SAVEt_SET_SVFLAGS:
12675             i = POPINT(ss,ix);
12676             TOPINT(nss,ix) = i;
12677             i = POPINT(ss,ix);
12678             TOPINT(nss,ix) = i;
12679             sv = (const SV *)POPPTR(ss,ix);
12680             TOPPTR(nss,ix) = sv_dup(sv, param);
12681             break;
12682         case SAVEt_RE_STATE:
12683             {
12684                 const struct re_save_state *const old_state
12685                     = (struct re_save_state *)
12686                     (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12687                 struct re_save_state *const new_state
12688                     = (struct re_save_state *)
12689                     (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12690
12691                 Copy(old_state, new_state, 1, struct re_save_state);
12692                 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12693
12694                 new_state->re_state_bostr
12695                     = pv_dup(old_state->re_state_bostr);
12696                 new_state->re_state_reginput
12697                     = pv_dup(old_state->re_state_reginput);
12698                 new_state->re_state_regeol
12699                     = pv_dup(old_state->re_state_regeol);
12700                 new_state->re_state_regoffs
12701                     = (regexp_paren_pair*)
12702                         any_dup(old_state->re_state_regoffs, proto_perl);
12703                 new_state->re_state_reglastparen
12704                     = (U32*) any_dup(old_state->re_state_reglastparen,
12705                               proto_perl);
12706                 new_state->re_state_reglastcloseparen
12707                     = (U32*)any_dup(old_state->re_state_reglastcloseparen,
12708                               proto_perl);
12709                 /* XXX This just has to be broken. The old save_re_context
12710                    code did SAVEGENERICPV(PL_reg_start_tmp);
12711                    PL_reg_start_tmp is char **.
12712                    Look above to what the dup code does for
12713                    SAVEt_GENERIC_PVREF
12714                    It can never have worked.
12715                    So this is merely a faithful copy of the exiting bug:  */
12716                 new_state->re_state_reg_start_tmp
12717                     = (char **) pv_dup((char *)
12718                                       old_state->re_state_reg_start_tmp);
12719                 /* I assume that it only ever "worked" because no-one called
12720                    (pseudo)fork while the regexp engine had re-entered itself.
12721                 */
12722 #ifdef PERL_OLD_COPY_ON_WRITE
12723                 new_state->re_state_nrs
12724                     = sv_dup(old_state->re_state_nrs, param);
12725 #endif
12726                 new_state->re_state_reg_magic
12727                     = (MAGIC*) any_dup(old_state->re_state_reg_magic,
12728                                proto_perl);
12729                 new_state->re_state_reg_oldcurpm
12730                     = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
12731                               proto_perl);
12732                 new_state->re_state_reg_curpm
12733                     = (PMOP*)  any_dup(old_state->re_state_reg_curpm,
12734                                proto_perl);
12735                 new_state->re_state_reg_oldsaved
12736                     = pv_dup(old_state->re_state_reg_oldsaved);
12737                 new_state->re_state_reg_poscache
12738                     = pv_dup(old_state->re_state_reg_poscache);
12739                 new_state->re_state_reg_starttry
12740                     = pv_dup(old_state->re_state_reg_starttry);
12741                 break;
12742             }
12743         case SAVEt_COMPILE_WARNINGS:
12744             ptr = POPPTR(ss,ix);
12745             TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12746             break;
12747         case SAVEt_PARSER:
12748             ptr = POPPTR(ss,ix);
12749             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12750             break;
12751         default:
12752             Perl_croak(aTHX_
12753                        "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12754         }
12755     }
12756
12757     return nss;
12758 }
12759
12760
12761 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12762  * flag to the result. This is done for each stash before cloning starts,
12763  * so we know which stashes want their objects cloned */
12764
12765 static void
12766 do_mark_cloneable_stash(pTHX_ SV *const sv)
12767 {
12768     const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12769     if (hvname) {
12770         GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12771         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12772         if (cloner && GvCV(cloner)) {
12773             dSP;
12774             UV status;
12775
12776             ENTER;
12777             SAVETMPS;
12778             PUSHMARK(SP);
12779             mXPUSHs(newSVhek(hvname));
12780             PUTBACK;
12781             call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12782             SPAGAIN;
12783             status = POPu;
12784             PUTBACK;
12785             FREETMPS;
12786             LEAVE;
12787             if (status)
12788                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12789         }
12790     }
12791 }
12792
12793
12794
12795 /*
12796 =for apidoc perl_clone
12797
12798 Create and return a new interpreter by cloning the current one.
12799
12800 perl_clone takes these flags as parameters:
12801
12802 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12803 without it we only clone the data and zero the stacks,
12804 with it we copy the stacks and the new perl interpreter is
12805 ready to run at the exact same point as the previous one.
12806 The pseudo-fork code uses COPY_STACKS while the
12807 threads->create doesn't.
12808
12809 CLONEf_KEEP_PTR_TABLE -
12810 perl_clone keeps a ptr_table with the pointer of the old
12811 variable as a key and the new variable as a value,
12812 this allows it to check if something has been cloned and not
12813 clone it again but rather just use the value and increase the
12814 refcount.  If KEEP_PTR_TABLE is not set then perl_clone will kill
12815 the ptr_table using the function
12816 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12817 reason to keep it around is if you want to dup some of your own
12818 variable who are outside the graph perl scans, example of this
12819 code is in threads.xs create.
12820
12821 CLONEf_CLONE_HOST -
12822 This is a win32 thing, it is ignored on unix, it tells perls
12823 win32host code (which is c++) to clone itself, this is needed on
12824 win32 if you want to run two threads at the same time,
12825 if you just want to do some stuff in a separate perl interpreter
12826 and then throw it away and return to the original one,
12827 you don't need to do anything.
12828
12829 =cut
12830 */
12831
12832 /* XXX the above needs expanding by someone who actually understands it ! */
12833 EXTERN_C PerlInterpreter *
12834 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12835
12836 PerlInterpreter *
12837 perl_clone(PerlInterpreter *proto_perl, UV flags)
12838 {
12839    dVAR;
12840 #ifdef PERL_IMPLICIT_SYS
12841
12842     PERL_ARGS_ASSERT_PERL_CLONE;
12843
12844    /* perlhost.h so we need to call into it
12845    to clone the host, CPerlHost should have a c interface, sky */
12846
12847    if (flags & CLONEf_CLONE_HOST) {
12848        return perl_clone_host(proto_perl,flags);
12849    }
12850    return perl_clone_using(proto_perl, flags,
12851                             proto_perl->IMem,
12852                             proto_perl->IMemShared,
12853                             proto_perl->IMemParse,
12854                             proto_perl->IEnv,
12855                             proto_perl->IStdIO,
12856                             proto_perl->ILIO,
12857                             proto_perl->IDir,
12858                             proto_perl->ISock,
12859                             proto_perl->IProc);
12860 }
12861
12862 PerlInterpreter *
12863 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12864                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
12865                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12866                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12867                  struct IPerlDir* ipD, struct IPerlSock* ipS,
12868                  struct IPerlProc* ipP)
12869 {
12870     /* XXX many of the string copies here can be optimized if they're
12871      * constants; they need to be allocated as common memory and just
12872      * their pointers copied. */
12873
12874     IV i;
12875     CLONE_PARAMS clone_params;
12876     CLONE_PARAMS* const param = &clone_params;
12877
12878     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12879
12880     PERL_ARGS_ASSERT_PERL_CLONE_USING;
12881 #else           /* !PERL_IMPLICIT_SYS */
12882     IV i;
12883     CLONE_PARAMS clone_params;
12884     CLONE_PARAMS* param = &clone_params;
12885     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12886
12887     PERL_ARGS_ASSERT_PERL_CLONE;
12888 #endif          /* PERL_IMPLICIT_SYS */
12889
12890     /* for each stash, determine whether its objects should be cloned */
12891     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12892     PERL_SET_THX(my_perl);
12893
12894 #ifdef DEBUGGING
12895     PoisonNew(my_perl, 1, PerlInterpreter);
12896     PL_op = NULL;
12897     PL_curcop = NULL;
12898     PL_defstash = NULL; /* may be used by perl malloc() */
12899     PL_markstack = 0;
12900     PL_scopestack = 0;
12901     PL_scopestack_name = 0;
12902     PL_savestack = 0;
12903     PL_savestack_ix = 0;
12904     PL_savestack_max = -1;
12905     PL_sig_pending = 0;
12906     PL_parser = NULL;
12907     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12908 #  ifdef DEBUG_LEAKING_SCALARS
12909     PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12910 #  endif
12911 #else   /* !DEBUGGING */
12912     Zero(my_perl, 1, PerlInterpreter);
12913 #endif  /* DEBUGGING */
12914
12915 #ifdef PERL_IMPLICIT_SYS
12916     /* host pointers */
12917     PL_Mem              = ipM;
12918     PL_MemShared        = ipMS;
12919     PL_MemParse         = ipMP;
12920     PL_Env              = ipE;
12921     PL_StdIO            = ipStd;
12922     PL_LIO              = ipLIO;
12923     PL_Dir              = ipD;
12924     PL_Sock             = ipS;
12925     PL_Proc             = ipP;
12926 #endif          /* PERL_IMPLICIT_SYS */
12927
12928     param->flags = flags;
12929     /* Nothing in the core code uses this, but we make it available to
12930        extensions (using mg_dup).  */
12931     param->proto_perl = proto_perl;
12932     /* Likely nothing will use this, but it is initialised to be consistent
12933        with Perl_clone_params_new().  */
12934     param->new_perl = my_perl;
12935     param->unreferenced = NULL;
12936
12937     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12938
12939     PL_body_arenas = NULL;
12940     Zero(&PL_body_roots, 1, PL_body_roots);
12941
12942     PL_sv_count         = 0;
12943     PL_sv_objcount      = 0;
12944     PL_sv_root          = NULL;
12945     PL_sv_arenaroot     = NULL;
12946
12947     PL_debug            = proto_perl->Idebug;
12948
12949     PL_hash_seed        = proto_perl->Ihash_seed;
12950     PL_rehash_seed      = proto_perl->Irehash_seed;
12951
12952     SvANY(&PL_sv_undef)         = NULL;
12953     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
12954     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
12955     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
12956     SvFLAGS(&PL_sv_no)          = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12957                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12958
12959     SvANY(&PL_sv_yes)           = new_XPVNV();
12960     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
12961     SvFLAGS(&PL_sv_yes)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12962                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12963
12964     /* dbargs array probably holds garbage */
12965     PL_dbargs           = NULL;
12966
12967     PL_compiling = proto_perl->Icompiling;
12968
12969 #ifdef PERL_DEBUG_READONLY_OPS
12970     PL_slabs = NULL;
12971     PL_slab_count = 0;
12972 #endif
12973
12974     /* pseudo environmental stuff */
12975     PL_origargc         = proto_perl->Iorigargc;
12976     PL_origargv         = proto_perl->Iorigargv;
12977
12978     /* Set tainting stuff before PerlIO_debug can possibly get called */
12979     PL_tainting         = proto_perl->Itainting;
12980     PL_taint_warn       = proto_perl->Itaint_warn;
12981
12982     PL_minus_c          = proto_perl->Iminus_c;
12983
12984     PL_localpatches     = proto_perl->Ilocalpatches;
12985     PL_splitstr         = proto_perl->Isplitstr;
12986     PL_minus_n          = proto_perl->Iminus_n;
12987     PL_minus_p          = proto_perl->Iminus_p;
12988     PL_minus_l          = proto_perl->Iminus_l;
12989     PL_minus_a          = proto_perl->Iminus_a;
12990     PL_minus_E          = proto_perl->Iminus_E;
12991     PL_minus_F          = proto_perl->Iminus_F;
12992     PL_doswitches       = proto_perl->Idoswitches;
12993     PL_dowarn           = proto_perl->Idowarn;
12994     PL_sawampersand     = proto_perl->Isawampersand;
12995     PL_unsafe           = proto_perl->Iunsafe;
12996     PL_perldb           = proto_perl->Iperldb;
12997     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12998     PL_exit_flags       = proto_perl->Iexit_flags;
12999
13000     /* XXX time(&PL_basetime) when asked for? */
13001     PL_basetime         = proto_perl->Ibasetime;
13002
13003     PL_maxsysfd         = proto_perl->Imaxsysfd;
13004     PL_statusvalue      = proto_perl->Istatusvalue;
13005 #ifdef VMS
13006     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
13007 #else
13008     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
13009 #endif
13010
13011     /* RE engine related */
13012     Zero(&PL_reg_state, 1, struct re_save_state);
13013     PL_reginterp_cnt    = 0;
13014     PL_regmatch_slab    = NULL;
13015
13016     PL_sub_generation   = proto_perl->Isub_generation;
13017
13018     /* funky return mechanisms */
13019     PL_forkprocess      = proto_perl->Iforkprocess;
13020
13021     /* internal state */
13022     PL_maxo             = proto_perl->Imaxo;
13023
13024     PL_main_start       = proto_perl->Imain_start;
13025     PL_eval_root        = proto_perl->Ieval_root;
13026     PL_eval_start       = proto_perl->Ieval_start;
13027
13028     PL_filemode         = proto_perl->Ifilemode;
13029     PL_lastfd           = proto_perl->Ilastfd;
13030     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
13031     PL_Argv             = NULL;
13032     PL_Cmd              = NULL;
13033     PL_gensym           = proto_perl->Igensym;
13034
13035     PL_laststatval      = proto_perl->Ilaststatval;
13036     PL_laststype        = proto_perl->Ilaststype;
13037     PL_mess_sv          = NULL;
13038
13039     PL_profiledata      = NULL;
13040
13041     PL_generation       = proto_perl->Igeneration;
13042
13043     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
13044     PL_in_clean_all     = proto_perl->Iin_clean_all;
13045
13046     PL_delaymagic_uid   = proto_perl->Idelaymagic_uid;
13047     PL_delaymagic_euid  = proto_perl->Idelaymagic_euid;
13048     PL_delaymagic_gid   = proto_perl->Idelaymagic_gid;
13049     PL_delaymagic_egid  = proto_perl->Idelaymagic_egid;
13050     PL_nomemok          = proto_perl->Inomemok;
13051     PL_an               = proto_perl->Ian;
13052     PL_evalseq          = proto_perl->Ievalseq;
13053     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
13054     PL_origalen         = proto_perl->Iorigalen;
13055
13056     PL_sighandlerp      = proto_perl->Isighandlerp;
13057
13058     PL_runops           = proto_perl->Irunops;
13059
13060     PL_subline          = proto_perl->Isubline;
13061
13062 #ifdef FCRYPT
13063     PL_cryptseen        = proto_perl->Icryptseen;
13064 #endif
13065
13066     PL_hints            = proto_perl->Ihints;
13067
13068     PL_amagic_generation        = proto_perl->Iamagic_generation;
13069
13070 #ifdef USE_LOCALE_COLLATE
13071     PL_collation_ix     = proto_perl->Icollation_ix;
13072     PL_collation_standard       = proto_perl->Icollation_standard;
13073     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
13074     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
13075 #endif /* USE_LOCALE_COLLATE */
13076
13077 #ifdef USE_LOCALE_NUMERIC
13078     PL_numeric_standard = proto_perl->Inumeric_standard;
13079     PL_numeric_local    = proto_perl->Inumeric_local;
13080 #endif /* !USE_LOCALE_NUMERIC */
13081
13082     /* Did the locale setup indicate UTF-8? */
13083     PL_utf8locale       = proto_perl->Iutf8locale;
13084     /* Unicode features (see perlrun/-C) */
13085     PL_unicode          = proto_perl->Iunicode;
13086
13087     /* Pre-5.8 signals control */
13088     PL_signals          = proto_perl->Isignals;
13089
13090     /* times() ticks per second */
13091     PL_clocktick        = proto_perl->Iclocktick;
13092
13093     /* Recursion stopper for PerlIO_find_layer */
13094     PL_in_load_module   = proto_perl->Iin_load_module;
13095
13096     /* sort() routine */
13097     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
13098
13099     /* Not really needed/useful since the reenrant_retint is "volatile",
13100      * but do it for consistency's sake. */
13101     PL_reentrant_retint = proto_perl->Ireentrant_retint;
13102
13103     /* Hooks to shared SVs and locks. */
13104     PL_sharehook        = proto_perl->Isharehook;
13105     PL_lockhook         = proto_perl->Ilockhook;
13106     PL_unlockhook       = proto_perl->Iunlockhook;
13107     PL_threadhook       = proto_perl->Ithreadhook;
13108     PL_destroyhook      = proto_perl->Idestroyhook;
13109     PL_signalhook       = proto_perl->Isignalhook;
13110
13111     PL_globhook         = proto_perl->Iglobhook;
13112
13113     /* swatch cache */
13114     PL_last_swash_hv    = NULL; /* reinits on demand */
13115     PL_last_swash_klen  = 0;
13116     PL_last_swash_key[0]= '\0';
13117     PL_last_swash_tmps  = (U8*)NULL;
13118     PL_last_swash_slen  = 0;
13119
13120     PL_glob_index       = proto_perl->Iglob_index;
13121     PL_srand_called     = proto_perl->Isrand_called;
13122
13123     if (flags & CLONEf_COPY_STACKS) {
13124         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13125         PL_tmps_ix              = proto_perl->Itmps_ix;
13126         PL_tmps_max             = proto_perl->Itmps_max;
13127         PL_tmps_floor           = proto_perl->Itmps_floor;
13128
13129         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13130          * NOTE: unlike the others! */
13131         PL_scopestack_ix        = proto_perl->Iscopestack_ix;
13132         PL_scopestack_max       = proto_perl->Iscopestack_max;
13133
13134         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13135          * NOTE: unlike the others! */
13136         PL_savestack_ix         = proto_perl->Isavestack_ix;
13137         PL_savestack_max        = proto_perl->Isavestack_max;
13138     }
13139
13140     PL_start_env        = proto_perl->Istart_env;       /* XXXXXX */
13141     PL_top_env          = &PL_start_env;
13142
13143     PL_op               = proto_perl->Iop;
13144
13145     PL_Sv               = NULL;
13146     PL_Xpv              = (XPV*)NULL;
13147     my_perl->Ina        = proto_perl->Ina;
13148
13149     PL_statbuf          = proto_perl->Istatbuf;
13150     PL_statcache        = proto_perl->Istatcache;
13151
13152 #ifdef HAS_TIMES
13153     PL_timesbuf         = proto_perl->Itimesbuf;
13154 #endif
13155
13156     PL_tainted          = proto_perl->Itainted;
13157     PL_curpm            = proto_perl->Icurpm;   /* XXX No PMOP ref count */
13158
13159     PL_chopset          = proto_perl->Ichopset; /* XXX never deallocated */
13160
13161     PL_restartjmpenv    = proto_perl->Irestartjmpenv;
13162     PL_restartop        = proto_perl->Irestartop;
13163     PL_in_eval          = proto_perl->Iin_eval;
13164     PL_delaymagic       = proto_perl->Idelaymagic;
13165     PL_phase            = proto_perl->Iphase;
13166     PL_localizing       = proto_perl->Ilocalizing;
13167
13168     PL_hv_fetch_ent_mh  = NULL;
13169     PL_modcount         = proto_perl->Imodcount;
13170     PL_lastgotoprobe    = NULL;
13171     PL_dumpindent       = proto_perl->Idumpindent;
13172
13173     PL_efloatbuf        = NULL;         /* reinits on demand */
13174     PL_efloatsize       = 0;                    /* reinits on demand */
13175
13176     /* regex stuff */
13177
13178     PL_regdummy         = proto_perl->Iregdummy;
13179     PL_colorset         = 0;            /* reinits PL_colors[] */
13180     /*PL_colors[6]      = {0,0,0,0,0,0};*/
13181
13182     /* Pluggable optimizer */
13183     PL_peepp            = proto_perl->Ipeepp;
13184     PL_rpeepp           = proto_perl->Irpeepp;
13185     /* op_free() hook */
13186     PL_opfreehook       = proto_perl->Iopfreehook;
13187
13188 #ifdef USE_REENTRANT_API
13189     /* XXX: things like -Dm will segfault here in perlio, but doing
13190      *  PERL_SET_CONTEXT(proto_perl);
13191      * breaks too many other things
13192      */
13193     Perl_reentrant_init(aTHX);
13194 #endif
13195
13196     /* create SV map for pointer relocation */
13197     PL_ptr_table = ptr_table_new();
13198
13199     /* initialize these special pointers as early as possible */
13200     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
13201
13202     SvANY(&PL_sv_no)            = new_XPVNV();
13203     SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
13204     SvCUR_set(&PL_sv_no, 0);
13205     SvLEN_set(&PL_sv_no, 1);
13206     SvIV_set(&PL_sv_no, 0);
13207     SvNV_set(&PL_sv_no, 0);
13208     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
13209
13210     SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
13211     SvCUR_set(&PL_sv_yes, 1);
13212     SvLEN_set(&PL_sv_yes, 2);
13213     SvIV_set(&PL_sv_yes, 1);
13214     SvNV_set(&PL_sv_yes, 1);
13215     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
13216
13217     /* create (a non-shared!) shared string table */
13218     PL_strtab           = newHV();
13219     HvSHAREKEYS_off(PL_strtab);
13220     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
13221     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
13222
13223     /* These two PVs will be free'd special way so must set them same way op.c does */
13224     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
13225     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
13226
13227     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
13228     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
13229
13230     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
13231     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
13232     CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
13233     PL_curcop           = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
13234
13235     param->stashes      = newAV();  /* Setup array of objects to call clone on */
13236     /* This makes no difference to the implementation, as it always pushes
13237        and shifts pointers to other SVs without changing their reference
13238        count, with the array becoming empty before it is freed. However, it
13239        makes it conceptually clear what is going on, and will avoid some
13240        work inside av.c, filling slots between AvFILL() and AvMAX() with
13241        &PL_sv_undef, and SvREFCNT_dec()ing those.  */
13242     AvREAL_off(param->stashes);
13243
13244     if (!(flags & CLONEf_COPY_STACKS)) {
13245         param->unreferenced = newAV();
13246     }
13247
13248 #ifdef PERLIO_LAYERS
13249     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
13250     PerlIO_clone(aTHX_ proto_perl, param);
13251 #endif
13252
13253     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
13254     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
13255     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
13256     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
13257     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
13258     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
13259
13260     /* switches */
13261     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
13262     PL_apiversion       = sv_dup_inc(proto_perl->Iapiversion, param);
13263     PL_inplace          = SAVEPV(proto_perl->Iinplace);
13264     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
13265
13266     /* magical thingies */
13267     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
13268
13269     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
13270
13271     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
13272     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
13273     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
13274
13275
13276     /* Clone the regex array */
13277     /* ORANGE FIXME for plugins, probably in the SV dup code.
13278        newSViv(PTR2IV(CALLREGDUPE(
13279        INT2PTR(REGEXP *, SvIVX(regex)), param))))
13280     */
13281     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
13282     PL_regex_pad = AvARRAY(PL_regex_padav);
13283
13284     /* shortcuts to various I/O objects */
13285     PL_ofsgv            = gv_dup_inc(proto_perl->Iofsgv, param);
13286     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
13287     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
13288     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
13289     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
13290     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
13291     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
13292
13293     /* shortcuts to regexp stuff */
13294     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
13295
13296     /* shortcuts to misc objects */
13297     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
13298
13299     /* shortcuts to debugging objects */
13300     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
13301     PL_DBline           = gv_dup(proto_perl->IDBline, param);
13302     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
13303     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
13304     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
13305     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
13306
13307     /* symbol tables */
13308     PL_defstash         = hv_dup_inc(proto_perl->Idefstash, param);
13309     PL_curstash         = hv_dup_inc(proto_perl->Icurstash, param);
13310     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
13311     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
13312     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
13313
13314     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
13315     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
13316     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
13317     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
13318     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
13319     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
13320     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
13321     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
13322
13323     PL_isarev           = hv_dup_inc(proto_perl->Iisarev, param);
13324
13325     /* subprocess state */
13326     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
13327
13328     if (proto_perl->Iop_mask)
13329         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
13330     else
13331         PL_op_mask      = NULL;
13332     /* PL_asserting        = proto_perl->Iasserting; */
13333
13334     /* current interpreter roots */
13335     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
13336     OP_REFCNT_LOCK;
13337     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
13338     OP_REFCNT_UNLOCK;
13339
13340     /* runtime control stuff */
13341     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
13342
13343     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
13344
13345     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
13346
13347     /* interpreter atexit processing */
13348     PL_exitlistlen      = proto_perl->Iexitlistlen;
13349     if (PL_exitlistlen) {
13350         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13351         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13352     }
13353     else
13354         PL_exitlist     = (PerlExitListEntry*)NULL;
13355
13356     PL_my_cxt_size = proto_perl->Imy_cxt_size;
13357     if (PL_my_cxt_size) {
13358         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
13359         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
13360 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13361         Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
13362         Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
13363 #endif
13364     }
13365     else {
13366         PL_my_cxt_list  = (void**)NULL;
13367 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13368         PL_my_cxt_keys  = (const char**)NULL;
13369 #endif
13370     }
13371     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
13372     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
13373     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
13374     PL_custom_ops       = hv_dup_inc(proto_perl->Icustom_ops, param);
13375
13376     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
13377
13378     PAD_CLONE_VARS(proto_perl, param);
13379
13380 #ifdef HAVE_INTERP_INTERN
13381     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
13382 #endif
13383
13384     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
13385
13386 #ifdef PERL_USES_PL_PIDSTATUS
13387     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
13388 #endif
13389     PL_osname           = SAVEPV(proto_perl->Iosname);
13390     PL_parser           = parser_dup(proto_perl->Iparser, param);
13391
13392     /* XXX this only works if the saved cop has already been cloned */
13393     if (proto_perl->Iparser) {
13394         PL_parser->saved_curcop = (COP*)any_dup(
13395                                     proto_perl->Iparser->saved_curcop,
13396                                     proto_perl);
13397     }
13398
13399     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
13400
13401 #ifdef USE_LOCALE_COLLATE
13402     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
13403 #endif /* USE_LOCALE_COLLATE */
13404
13405 #ifdef USE_LOCALE_NUMERIC
13406     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
13407     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13408 #endif /* !USE_LOCALE_NUMERIC */
13409
13410     /* Unicode inversion lists */
13411     PL_ASCII            = sv_dup_inc(proto_perl->IASCII, param);
13412     PL_Latin1           = sv_dup_inc(proto_perl->ILatin1, param);
13413
13414     PL_PerlSpace        = sv_dup_inc(proto_perl->IPerlSpace, param);
13415     PL_XPerlSpace       = sv_dup_inc(proto_perl->IXPerlSpace, param);
13416
13417     PL_L1PosixAlnum     = sv_dup_inc(proto_perl->IL1PosixAlnum, param);
13418     PL_PosixAlnum       = sv_dup_inc(proto_perl->IPosixAlnum, param);
13419
13420     PL_L1PosixAlpha     = sv_dup_inc(proto_perl->IL1PosixAlpha, param);
13421     PL_PosixAlpha       = sv_dup_inc(proto_perl->IPosixAlpha, param);
13422
13423     PL_PosixBlank       = sv_dup_inc(proto_perl->IPosixBlank, param);
13424     PL_XPosixBlank      = sv_dup_inc(proto_perl->IXPosixBlank, param);
13425
13426     PL_L1Cased          = sv_dup_inc(proto_perl->IL1Cased, param);
13427
13428     PL_PosixCntrl       = sv_dup_inc(proto_perl->IPosixCntrl, param);
13429     PL_XPosixCntrl      = sv_dup_inc(proto_perl->IXPosixCntrl, param);
13430
13431     PL_PosixDigit       = sv_dup_inc(proto_perl->IPosixDigit, param);
13432
13433     PL_L1PosixGraph     = sv_dup_inc(proto_perl->IL1PosixGraph, param);
13434     PL_PosixGraph       = sv_dup_inc(proto_perl->IPosixGraph, param);
13435
13436     PL_L1PosixLower     = sv_dup_inc(proto_perl->IL1PosixLower, param);
13437     PL_PosixLower       = sv_dup_inc(proto_perl->IPosixLower, param);
13438
13439     PL_L1PosixPrint     = sv_dup_inc(proto_perl->IL1PosixPrint, param);
13440     PL_PosixPrint       = sv_dup_inc(proto_perl->IPosixPrint, param);
13441
13442     PL_L1PosixPunct     = sv_dup_inc(proto_perl->IL1PosixPunct, param);
13443     PL_PosixPunct       = sv_dup_inc(proto_perl->IPosixPunct, param);
13444
13445     PL_PosixSpace       = sv_dup_inc(proto_perl->IPosixSpace, param);
13446     PL_XPosixSpace      = sv_dup_inc(proto_perl->IXPosixSpace, param);
13447
13448     PL_L1PosixUpper     = sv_dup_inc(proto_perl->IL1PosixUpper, param);
13449     PL_PosixUpper       = sv_dup_inc(proto_perl->IPosixUpper, param);
13450
13451     PL_L1PosixWord      = sv_dup_inc(proto_perl->IL1PosixWord, param);
13452     PL_PosixWord        = sv_dup_inc(proto_perl->IPosixWord, param);
13453
13454     PL_PosixXDigit      = sv_dup_inc(proto_perl->IPosixXDigit, param);
13455     PL_XPosixXDigit     = sv_dup_inc(proto_perl->IXPosixXDigit, param);
13456
13457     PL_VertSpace        = sv_dup_inc(proto_perl->IVertSpace, param);
13458
13459     /* utf8 character class swashes */
13460     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
13461     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
13462     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
13463     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
13464     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
13465     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
13466     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
13467     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
13468     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
13469     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
13470     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
13471     PL_utf8_X_begin     = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
13472     PL_utf8_X_extend    = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13473     PL_utf8_X_prepend   = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
13474     PL_utf8_X_non_hangul        = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
13475     PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
13476     PL_utf8_X_LV        = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
13477     PL_utf8_X_LVT       = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
13478     PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
13479     PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
13480     PL_utf8_X_LV_LVT_V  = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
13481     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13482     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13483     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13484     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13485     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13486     PL_utf8_xidstart    = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
13487     PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
13488     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13489     PL_utf8_xidcont     = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
13490     PL_utf8_foldable    = sv_dup_inc(proto_perl->Iutf8_foldable, param);
13491     PL_utf8_quotemeta   = sv_dup_inc(proto_perl->Iutf8_quotemeta, param);
13492     PL_ASCII            = sv_dup_inc(proto_perl->IASCII, param);
13493     PL_AboveLatin1      = sv_dup_inc(proto_perl->IAboveLatin1, param);
13494     PL_Latin1           = sv_dup_inc(proto_perl->ILatin1, param);
13495
13496
13497     if (proto_perl->Ipsig_pend) {
13498         Newxz(PL_psig_pend, SIG_SIZE, int);
13499     }
13500     else {
13501         PL_psig_pend    = (int*)NULL;
13502     }
13503
13504     if (proto_perl->Ipsig_name) {
13505         Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13506         sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13507                             param);
13508         PL_psig_ptr = PL_psig_name + SIG_SIZE;
13509     }
13510     else {
13511         PL_psig_ptr     = (SV**)NULL;
13512         PL_psig_name    = (SV**)NULL;
13513     }
13514
13515     if (flags & CLONEf_COPY_STACKS) {
13516         Newx(PL_tmps_stack, PL_tmps_max, SV*);
13517         sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13518                             PL_tmps_ix+1, param);
13519
13520         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13521         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13522         Newxz(PL_markstack, i, I32);
13523         PL_markstack_max        = PL_markstack + (proto_perl->Imarkstack_max
13524                                                   - proto_perl->Imarkstack);
13525         PL_markstack_ptr        = PL_markstack + (proto_perl->Imarkstack_ptr
13526                                                   - proto_perl->Imarkstack);
13527         Copy(proto_perl->Imarkstack, PL_markstack,
13528              PL_markstack_ptr - PL_markstack + 1, I32);
13529
13530         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13531          * NOTE: unlike the others! */
13532         Newxz(PL_scopestack, PL_scopestack_max, I32);
13533         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13534
13535 #ifdef DEBUGGING
13536         Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13537         Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13538 #endif
13539         /* NOTE: si_dup() looks at PL_markstack */
13540         PL_curstackinfo         = si_dup(proto_perl->Icurstackinfo, param);
13541
13542         /* PL_curstack          = PL_curstackinfo->si_stack; */
13543         PL_curstack             = av_dup(proto_perl->Icurstack, param);
13544         PL_mainstack            = av_dup(proto_perl->Imainstack, param);
13545
13546         /* next PUSHs() etc. set *(PL_stack_sp+1) */
13547         PL_stack_base           = AvARRAY(PL_curstack);
13548         PL_stack_sp             = PL_stack_base + (proto_perl->Istack_sp
13549                                                    - proto_perl->Istack_base);
13550         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
13551
13552         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13553         PL_savestack            = ss_dup(proto_perl, param);
13554     }
13555     else {
13556         init_stacks();
13557         ENTER;                  /* perl_destruct() wants to LEAVE; */
13558     }
13559
13560     PL_statgv           = gv_dup(proto_perl->Istatgv, param);
13561     PL_statname         = sv_dup_inc(proto_perl->Istatname, param);
13562
13563     PL_rs               = sv_dup_inc(proto_perl->Irs, param);
13564     PL_last_in_gv       = gv_dup(proto_perl->Ilast_in_gv, param);
13565     PL_defoutgv         = gv_dup_inc(proto_perl->Idefoutgv, param);
13566     PL_toptarget        = sv_dup_inc(proto_perl->Itoptarget, param);
13567     PL_bodytarget       = sv_dup_inc(proto_perl->Ibodytarget, param);
13568     PL_formtarget       = sv_dup(proto_perl->Iformtarget, param);
13569
13570     PL_errors           = sv_dup_inc(proto_perl->Ierrors, param);
13571
13572     PL_sortcop          = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13573     PL_sortstash        = hv_dup(proto_perl->Isortstash, param);
13574     PL_firstgv          = gv_dup(proto_perl->Ifirstgv, param);
13575     PL_secondgv         = gv_dup(proto_perl->Isecondgv, param);
13576
13577     PL_stashcache       = newHV();
13578
13579     PL_watchaddr        = (char **) ptr_table_fetch(PL_ptr_table,
13580                                             proto_perl->Iwatchaddr);
13581     PL_watchok          = PL_watchaddr ? * PL_watchaddr : NULL;
13582     if (PL_debug && PL_watchaddr) {
13583         PerlIO_printf(Perl_debug_log,
13584           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13585           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13586           PTR2UV(PL_watchok));
13587     }
13588
13589     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
13590     PL_blockhooks       = av_dup_inc(proto_perl->Iblockhooks, param);
13591     PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13592
13593     /* Call the ->CLONE method, if it exists, for each of the stashes
13594        identified by sv_dup() above.
13595     */
13596     while(av_len(param->stashes) != -1) {
13597         HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13598         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13599         if (cloner && GvCV(cloner)) {
13600             dSP;
13601             ENTER;
13602             SAVETMPS;
13603             PUSHMARK(SP);
13604             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13605             PUTBACK;
13606             call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13607             FREETMPS;
13608             LEAVE;
13609         }
13610     }
13611
13612     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13613         ptr_table_free(PL_ptr_table);
13614         PL_ptr_table = NULL;
13615     }
13616
13617     if (!(flags & CLONEf_COPY_STACKS)) {
13618         unreferenced_to_tmp_stack(param->unreferenced);
13619     }
13620
13621     SvREFCNT_dec(param->stashes);
13622
13623     /* orphaned? eg threads->new inside BEGIN or use */
13624     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13625         SvREFCNT_inc_simple_void(PL_compcv);
13626         SAVEFREESV(PL_compcv);
13627     }
13628
13629     return my_perl;
13630 }
13631
13632 static void
13633 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13634 {
13635     PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13636
13637     if (AvFILLp(unreferenced) > -1) {
13638         SV **svp = AvARRAY(unreferenced);
13639         SV **const last = svp + AvFILLp(unreferenced);
13640         SSize_t count = 0;
13641
13642         do {
13643             if (SvREFCNT(*svp) == 1)
13644                 ++count;
13645         } while (++svp <= last);
13646
13647         EXTEND_MORTAL(count);
13648         svp = AvARRAY(unreferenced);
13649
13650         do {
13651             if (SvREFCNT(*svp) == 1) {
13652                 /* Our reference is the only one to this SV. This means that
13653                    in this thread, the scalar effectively has a 0 reference.
13654                    That doesn't work (cleanup never happens), so donate our
13655                    reference to it onto the save stack. */
13656                 PL_tmps_stack[++PL_tmps_ix] = *svp;
13657             } else {
13658                 /* As an optimisation, because we are already walking the
13659                    entire array, instead of above doing either
13660                    SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13661                    release our reference to the scalar, so that at the end of
13662                    the array owns zero references to the scalars it happens to
13663                    point to. We are effectively converting the array from
13664                    AvREAL() on to AvREAL() off. This saves the av_clear()
13665                    (triggered by the SvREFCNT_dec(unreferenced) below) from
13666                    walking the array a second time.  */
13667                 SvREFCNT_dec(*svp);
13668             }
13669
13670         } while (++svp <= last);
13671         AvREAL_off(unreferenced);
13672     }
13673     SvREFCNT_dec(unreferenced);
13674 }
13675
13676 void
13677 Perl_clone_params_del(CLONE_PARAMS *param)
13678 {
13679     /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13680        happy: */
13681     PerlInterpreter *const to = param->new_perl;
13682     dTHXa(to);
13683     PerlInterpreter *const was = PERL_GET_THX;
13684
13685     PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13686
13687     if (was != to) {
13688         PERL_SET_THX(to);
13689     }
13690
13691     SvREFCNT_dec(param->stashes);
13692     if (param->unreferenced)
13693         unreferenced_to_tmp_stack(param->unreferenced);
13694
13695     Safefree(param);
13696
13697     if (was != to) {
13698         PERL_SET_THX(was);
13699     }
13700 }
13701
13702 CLONE_PARAMS *
13703 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13704 {
13705     dVAR;
13706     /* Need to play this game, as newAV() can call safesysmalloc(), and that
13707        does a dTHX; to get the context from thread local storage.
13708        FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13709        a version that passes in my_perl.  */
13710     PerlInterpreter *const was = PERL_GET_THX;
13711     CLONE_PARAMS *param;
13712
13713     PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13714
13715     if (was != to) {
13716         PERL_SET_THX(to);
13717     }
13718
13719     /* Given that we've set the context, we can do this unshared.  */
13720     Newx(param, 1, CLONE_PARAMS);
13721
13722     param->flags = 0;
13723     param->proto_perl = from;
13724     param->new_perl = to;
13725     param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13726     AvREAL_off(param->stashes);
13727     param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13728
13729     if (was != to) {
13730         PERL_SET_THX(was);
13731     }
13732     return param;
13733 }
13734
13735 #endif /* USE_ITHREADS */
13736
13737 /*
13738 =head1 Unicode Support
13739
13740 =for apidoc sv_recode_to_utf8
13741
13742 The encoding is assumed to be an Encode object, on entry the PV
13743 of the sv is assumed to be octets in that encoding, and the sv
13744 will be converted into Unicode (and UTF-8).
13745
13746 If the sv already is UTF-8 (or if it is not POK), or if the encoding
13747 is not a reference, nothing is done to the sv.  If the encoding is not
13748 an C<Encode::XS> Encoding object, bad things will happen.
13749 (See F<lib/encoding.pm> and L<Encode>.)
13750
13751 The PV of the sv is returned.
13752
13753 =cut */
13754
13755 char *
13756 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
13757 {
13758     dVAR;
13759
13760     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
13761
13762     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
13763         SV *uni;
13764         STRLEN len;
13765         const char *s;
13766         dSP;
13767         ENTER;
13768         SAVETMPS;
13769         save_re_context();
13770         PUSHMARK(sp);
13771         EXTEND(SP, 3);
13772         XPUSHs(encoding);
13773         XPUSHs(sv);
13774 /*
13775   NI-S 2002/07/09
13776   Passing sv_yes is wrong - it needs to be or'ed set of constants
13777   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
13778   remove converted chars from source.
13779
13780   Both will default the value - let them.
13781
13782         XPUSHs(&PL_sv_yes);
13783 */
13784         PUTBACK;
13785         call_method("decode", G_SCALAR);
13786         SPAGAIN;
13787         uni = POPs;
13788         PUTBACK;
13789         s = SvPV_const(uni, len);
13790         if (s != SvPVX_const(sv)) {
13791             SvGROW(sv, len + 1);
13792             Move(s, SvPVX(sv), len + 1, char);
13793             SvCUR_set(sv, len);
13794         }
13795         FREETMPS;
13796         LEAVE;
13797         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
13798             /* clear pos and any utf8 cache */
13799             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
13800             if (mg)
13801                 mg->mg_len = -1;
13802             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
13803                 magic_setutf8(sv,mg); /* clear UTF8 cache */
13804         }
13805         SvUTF8_on(sv);
13806         return SvPVX(sv);
13807     }
13808     return SvPOKp(sv) ? SvPVX(sv) : NULL;
13809 }
13810
13811 /*
13812 =for apidoc sv_cat_decode
13813
13814 The encoding is assumed to be an Encode object, the PV of the ssv is
13815 assumed to be octets in that encoding and decoding the input starts
13816 from the position which (PV + *offset) pointed to.  The dsv will be
13817 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
13818 when the string tstr appears in decoding output or the input ends on
13819 the PV of the ssv.  The value which the offset points will be modified
13820 to the last input position on the ssv.
13821
13822 Returns TRUE if the terminator was found, else returns FALSE.
13823
13824 =cut */
13825
13826 bool
13827 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13828                    SV *ssv, int *offset, char *tstr, int tlen)
13829 {
13830     dVAR;
13831     bool ret = FALSE;
13832
13833     PERL_ARGS_ASSERT_SV_CAT_DECODE;
13834
13835     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13836         SV *offsv;
13837         dSP;
13838         ENTER;
13839         SAVETMPS;
13840         save_re_context();
13841         PUSHMARK(sp);
13842         EXTEND(SP, 6);
13843         XPUSHs(encoding);
13844         XPUSHs(dsv);
13845         XPUSHs(ssv);
13846         offsv = newSViv(*offset);
13847         mXPUSHs(offsv);
13848         mXPUSHp(tstr, tlen);
13849         PUTBACK;
13850         call_method("cat_decode", G_SCALAR);
13851         SPAGAIN;
13852         ret = SvTRUE(TOPs);
13853         *offset = SvIV(offsv);
13854         PUTBACK;
13855         FREETMPS;
13856         LEAVE;
13857     }
13858     else
13859         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13860     return ret;
13861
13862 }
13863
13864 /* ---------------------------------------------------------------------
13865  *
13866  * support functions for report_uninit()
13867  */
13868
13869 /* the maxiumum size of array or hash where we will scan looking
13870  * for the undefined element that triggered the warning */
13871
13872 #define FUV_MAX_SEARCH_SIZE 1000
13873
13874 /* Look for an entry in the hash whose value has the same SV as val;
13875  * If so, return a mortal copy of the key. */
13876
13877 STATIC SV*
13878 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13879 {
13880     dVAR;
13881     register HE **array;
13882     I32 i;
13883
13884     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13885
13886     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13887                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13888         return NULL;
13889
13890     array = HvARRAY(hv);
13891
13892     for (i=HvMAX(hv); i>0; i--) {
13893         register HE *entry;
13894         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13895             if (HeVAL(entry) != val)
13896                 continue;
13897             if (    HeVAL(entry) == &PL_sv_undef ||
13898                     HeVAL(entry) == &PL_sv_placeholder)
13899                 continue;
13900             if (!HeKEY(entry))
13901                 return NULL;
13902             if (HeKLEN(entry) == HEf_SVKEY)
13903                 return sv_mortalcopy(HeKEY_sv(entry));
13904             return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13905         }
13906     }
13907     return NULL;
13908 }
13909
13910 /* Look for an entry in the array whose value has the same SV as val;
13911  * If so, return the index, otherwise return -1. */
13912
13913 STATIC I32
13914 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13915 {
13916     dVAR;
13917
13918     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13919
13920     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13921                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13922         return -1;
13923
13924     if (val != &PL_sv_undef) {
13925         SV ** const svp = AvARRAY(av);
13926         I32 i;
13927
13928         for (i=AvFILLp(av); i>=0; i--)
13929             if (svp[i] == val)
13930                 return i;
13931     }
13932     return -1;
13933 }
13934
13935 /* S_varname(): return the name of a variable, optionally with a subscript.
13936  * If gv is non-zero, use the name of that global, along with gvtype (one
13937  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13938  * targ.  Depending on the value of the subscript_type flag, return:
13939  */
13940
13941 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
13942 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
13943 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
13944 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
13945
13946 SV*
13947 Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13948         const SV *const keyname, I32 aindex, int subscript_type)
13949 {
13950
13951     SV * const name = sv_newmortal();
13952     if (gv && isGV(gv)) {
13953         char buffer[2];
13954         buffer[0] = gvtype;
13955         buffer[1] = 0;
13956
13957         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
13958
13959         gv_fullname4(name, gv, buffer, 0);
13960
13961         if ((unsigned int)SvPVX(name)[1] <= 26) {
13962             buffer[0] = '^';
13963             buffer[1] = SvPVX(name)[1] + 'A' - 1;
13964
13965             /* Swap the 1 unprintable control character for the 2 byte pretty
13966                version - ie substr($name, 1, 1) = $buffer; */
13967             sv_insert(name, 1, 1, buffer, 2);
13968         }
13969     }
13970     else {
13971         CV * const cv = gv ? (CV *)gv : find_runcv(NULL);
13972         SV *sv;
13973         AV *av;
13974
13975         assert(!cv || SvTYPE(cv) == SVt_PVCV);
13976
13977         if (!cv || !CvPADLIST(cv))
13978             return NULL;
13979         av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13980         sv = *av_fetch(av, targ, FALSE);
13981         sv_setsv(name, sv);
13982     }
13983
13984     if (subscript_type == FUV_SUBSCRIPT_HASH) {
13985         SV * const sv = newSV(0);
13986         *SvPVX(name) = '$';
13987         Perl_sv_catpvf(aTHX_ name, "{%s}",
13988             pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
13989                     PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
13990         SvREFCNT_dec(sv);
13991     }
13992     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13993         *SvPVX(name) = '$';
13994         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13995     }
13996     else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13997         /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13998         Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
13999     }
14000
14001     return name;
14002 }
14003
14004
14005 /*
14006 =for apidoc find_uninit_var
14007
14008 Find the name of the undefined variable (if any) that caused the operator
14009 to issue a "Use of uninitialized value" warning.
14010 If match is true, only return a name if its value matches uninit_sv.
14011 So roughly speaking, if a unary operator (such as OP_COS) generates a
14012 warning, then following the direct child of the op may yield an
14013 OP_PADSV or OP_GV that gives the name of the undefined variable.  On the
14014 other hand, with OP_ADD there are two branches to follow, so we only print
14015 the variable name if we get an exact match.
14016
14017 The name is returned as a mortal SV.
14018
14019 Assumes that PL_op is the op that originally triggered the error, and that
14020 PL_comppad/PL_curpad points to the currently executing pad.
14021
14022 =cut
14023 */
14024
14025 STATIC SV *
14026 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
14027                   bool match)
14028 {
14029     dVAR;
14030     SV *sv;
14031     const GV *gv;
14032     const OP *o, *o2, *kid;
14033
14034     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
14035                             uninit_sv == &PL_sv_placeholder)))
14036         return NULL;
14037
14038     switch (obase->op_type) {
14039
14040     case OP_RV2AV:
14041     case OP_RV2HV:
14042     case OP_PADAV:
14043     case OP_PADHV:
14044       {
14045         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
14046         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
14047         I32 index = 0;
14048         SV *keysv = NULL;
14049         int subscript_type = FUV_SUBSCRIPT_WITHIN;
14050
14051         if (pad) { /* @lex, %lex */
14052             sv = PAD_SVl(obase->op_targ);
14053             gv = NULL;
14054         }
14055         else {
14056             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14057             /* @global, %global */
14058                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14059                 if (!gv)
14060                     break;
14061                 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
14062             }
14063             else if (obase == PL_op) /* @{expr}, %{expr} */
14064                 return find_uninit_var(cUNOPx(obase)->op_first,
14065                                                     uninit_sv, match);
14066             else /* @{expr}, %{expr} as a sub-expression */
14067                 return NULL;
14068         }
14069
14070         /* attempt to find a match within the aggregate */
14071         if (hash) {
14072             keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14073             if (keysv)
14074                 subscript_type = FUV_SUBSCRIPT_HASH;
14075         }
14076         else {
14077             index = find_array_subscript((const AV *)sv, uninit_sv);
14078             if (index >= 0)
14079                 subscript_type = FUV_SUBSCRIPT_ARRAY;
14080         }
14081
14082         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
14083             break;
14084
14085         return varname(gv, hash ? '%' : '@', obase->op_targ,
14086                                     keysv, index, subscript_type);
14087       }
14088
14089     case OP_RV2SV:
14090         if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14091             /* $global */
14092             gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14093             if (!gv || !GvSTASH(gv))
14094                 break;
14095             if (match && (GvSV(gv) != uninit_sv))
14096                 break;
14097             return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14098         }
14099         /* ${expr} */
14100         return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
14101
14102     case OP_PADSV:
14103         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
14104             break;
14105         return varname(NULL, '$', obase->op_targ,
14106                                     NULL, 0, FUV_SUBSCRIPT_NONE);
14107
14108     case OP_GVSV:
14109         gv = cGVOPx_gv(obase);
14110         if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
14111             break;
14112         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14113
14114     case OP_AELEMFAST_LEX:
14115         if (match) {
14116             SV **svp;
14117             AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
14118             if (!av || SvRMAGICAL(av))
14119                 break;
14120             svp = av_fetch(av, (I32)obase->op_private, FALSE);
14121             if (!svp || *svp != uninit_sv)
14122                 break;
14123         }
14124         return varname(NULL, '$', obase->op_targ,
14125                        NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14126     case OP_AELEMFAST:
14127         {
14128             gv = cGVOPx_gv(obase);
14129             if (!gv)
14130                 break;
14131             if (match) {
14132                 SV **svp;
14133                 AV *const av = GvAV(gv);
14134                 if (!av || SvRMAGICAL(av))
14135                     break;
14136                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
14137                 if (!svp || *svp != uninit_sv)
14138                     break;
14139             }
14140             return varname(gv, '$', 0,
14141                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14142         }
14143         break;
14144
14145     case OP_EXISTS:
14146         o = cUNOPx(obase)->op_first;
14147         if (!o || o->op_type != OP_NULL ||
14148                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
14149             break;
14150         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
14151
14152     case OP_AELEM:
14153     case OP_HELEM:
14154     {
14155         bool negate = FALSE;
14156
14157         if (PL_op == obase)
14158             /* $a[uninit_expr] or $h{uninit_expr} */
14159             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
14160
14161         gv = NULL;
14162         o = cBINOPx(obase)->op_first;
14163         kid = cBINOPx(obase)->op_last;
14164
14165         /* get the av or hv, and optionally the gv */
14166         sv = NULL;
14167         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
14168             sv = PAD_SV(o->op_targ);
14169         }
14170         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
14171                 && cUNOPo->op_first->op_type == OP_GV)
14172         {
14173             gv = cGVOPx_gv(cUNOPo->op_first);
14174             if (!gv)
14175                 break;
14176             sv = o->op_type
14177                 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
14178         }
14179         if (!sv)
14180             break;
14181
14182         if (kid && kid->op_type == OP_NEGATE) {
14183             negate = TRUE;
14184             kid = cUNOPx(kid)->op_first;
14185         }
14186
14187         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
14188             /* index is constant */
14189             SV* kidsv;
14190             if (negate) {
14191                 kidsv = sv_2mortal(newSVpvs("-"));
14192                 sv_catsv(kidsv, cSVOPx_sv(kid));
14193             }
14194             else
14195                 kidsv = cSVOPx_sv(kid);
14196             if (match) {
14197                 if (SvMAGICAL(sv))
14198                     break;
14199                 if (obase->op_type == OP_HELEM) {
14200                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
14201                     if (!he || HeVAL(he) != uninit_sv)
14202                         break;
14203                 }
14204                 else {
14205                     SV * const * const svp = av_fetch(MUTABLE_AV(sv),
14206                         negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
14207                         FALSE);
14208                     if (!svp || *svp != uninit_sv)
14209                         break;
14210                 }
14211             }
14212             if (obase->op_type == OP_HELEM)
14213                 return varname(gv, '%', o->op_targ,
14214                             kidsv, 0, FUV_SUBSCRIPT_HASH);
14215             else
14216                 return varname(gv, '@', o->op_targ, NULL,
14217                     negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
14218                     FUV_SUBSCRIPT_ARRAY);
14219         }
14220         else  {
14221             /* index is an expression;
14222              * attempt to find a match within the aggregate */
14223             if (obase->op_type == OP_HELEM) {
14224                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14225                 if (keysv)
14226                     return varname(gv, '%', o->op_targ,
14227                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
14228             }
14229             else {
14230                 const I32 index
14231                     = find_array_subscript((const AV *)sv, uninit_sv);
14232                 if (index >= 0)
14233                     return varname(gv, '@', o->op_targ,
14234                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
14235             }
14236             if (match)
14237                 break;
14238             return varname(gv,
14239                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
14240                 ? '@' : '%',
14241                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
14242         }
14243         break;
14244     }
14245
14246     case OP_AASSIGN:
14247         /* only examine RHS */
14248         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
14249
14250     case OP_OPEN:
14251         o = cUNOPx(obase)->op_first;
14252         if (o->op_type == OP_PUSHMARK)
14253             o = o->op_sibling;
14254
14255         if (!o->op_sibling) {
14256             /* one-arg version of open is highly magical */
14257
14258             if (o->op_type == OP_GV) { /* open FOO; */
14259                 gv = cGVOPx_gv(o);
14260                 if (match && GvSV(gv) != uninit_sv)
14261                     break;
14262                 return varname(gv, '$', 0,
14263                             NULL, 0, FUV_SUBSCRIPT_NONE);
14264             }
14265             /* other possibilities not handled are:
14266              * open $x; or open my $x;  should return '${*$x}'
14267              * open expr;               should return '$'.expr ideally
14268              */
14269              break;
14270         }
14271         goto do_op;
14272
14273     /* ops where $_ may be an implicit arg */
14274     case OP_TRANS:
14275     case OP_TRANSR:
14276     case OP_SUBST:
14277     case OP_MATCH:
14278         if ( !(obase->op_flags & OPf_STACKED)) {
14279             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
14280                                  ? PAD_SVl(obase->op_targ)
14281                                  : DEFSV))
14282             {
14283                 sv = sv_newmortal();
14284                 sv_setpvs(sv, "$_");
14285                 return sv;
14286             }
14287         }
14288         goto do_op;
14289
14290     case OP_PRTF:
14291     case OP_PRINT:
14292     case OP_SAY:
14293         match = 1; /* print etc can return undef on defined args */
14294         /* skip filehandle as it can't produce 'undef' warning  */
14295         o = cUNOPx(obase)->op_first;
14296         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
14297             o = o->op_sibling->op_sibling;
14298         goto do_op2;
14299
14300
14301     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
14302     case OP_CUSTOM: /* XS or custom code could trigger random warnings */
14303
14304         /* the following ops are capable of returning PL_sv_undef even for
14305          * defined arg(s) */
14306
14307     case OP_BACKTICK:
14308     case OP_PIPE_OP:
14309     case OP_FILENO:
14310     case OP_BINMODE:
14311     case OP_TIED:
14312     case OP_GETC:
14313     case OP_SYSREAD:
14314     case OP_SEND:
14315     case OP_IOCTL:
14316     case OP_SOCKET:
14317     case OP_SOCKPAIR:
14318     case OP_BIND:
14319     case OP_CONNECT:
14320     case OP_LISTEN:
14321     case OP_ACCEPT:
14322     case OP_SHUTDOWN:
14323     case OP_SSOCKOPT:
14324     case OP_GETPEERNAME:
14325     case OP_FTRREAD:
14326     case OP_FTRWRITE:
14327     case OP_FTREXEC:
14328     case OP_FTROWNED:
14329     case OP_FTEREAD:
14330     case OP_FTEWRITE:
14331     case OP_FTEEXEC:
14332     case OP_FTEOWNED:
14333     case OP_FTIS:
14334     case OP_FTZERO:
14335     case OP_FTSIZE:
14336     case OP_FTFILE:
14337     case OP_FTDIR:
14338     case OP_FTLINK:
14339     case OP_FTPIPE:
14340     case OP_FTSOCK:
14341     case OP_FTBLK:
14342     case OP_FTCHR:
14343     case OP_FTTTY:
14344     case OP_FTSUID:
14345     case OP_FTSGID:
14346     case OP_FTSVTX:
14347     case OP_FTTEXT:
14348     case OP_FTBINARY:
14349     case OP_FTMTIME:
14350     case OP_FTATIME:
14351     case OP_FTCTIME:
14352     case OP_READLINK:
14353     case OP_OPEN_DIR:
14354     case OP_READDIR:
14355     case OP_TELLDIR:
14356     case OP_SEEKDIR:
14357     case OP_REWINDDIR:
14358     case OP_CLOSEDIR:
14359     case OP_GMTIME:
14360     case OP_ALARM:
14361     case OP_SEMGET:
14362     case OP_GETLOGIN:
14363     case OP_UNDEF:
14364     case OP_SUBSTR:
14365     case OP_AEACH:
14366     case OP_EACH:
14367     case OP_SORT:
14368     case OP_CALLER:
14369     case OP_DOFILE:
14370     case OP_PROTOTYPE:
14371     case OP_NCMP:
14372     case OP_SMARTMATCH:
14373     case OP_UNPACK:
14374     case OP_SYSOPEN:
14375     case OP_SYSSEEK:
14376         match = 1;
14377         goto do_op;
14378
14379     case OP_ENTERSUB:
14380     case OP_GOTO:
14381         /* XXX tmp hack: these two may call an XS sub, and currently
14382           XS subs don't have a SUB entry on the context stack, so CV and
14383           pad determination goes wrong, and BAD things happen. So, just
14384           don't try to determine the value under those circumstances.
14385           Need a better fix at dome point. DAPM 11/2007 */
14386         break;
14387
14388     case OP_FLIP:
14389     case OP_FLOP:
14390     {
14391         GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
14392         if (gv && GvSV(gv) == uninit_sv)
14393             return newSVpvs_flags("$.", SVs_TEMP);
14394         goto do_op;
14395     }
14396
14397     case OP_POS:
14398         /* def-ness of rval pos() is independent of the def-ness of its arg */
14399         if ( !(obase->op_flags & OPf_MOD))
14400             break;
14401
14402     case OP_SCHOMP:
14403     case OP_CHOMP:
14404         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
14405             return newSVpvs_flags("${$/}", SVs_TEMP);
14406         /*FALLTHROUGH*/
14407
14408     default:
14409     do_op:
14410         if (!(obase->op_flags & OPf_KIDS))
14411             break;
14412         o = cUNOPx(obase)->op_first;
14413
14414     do_op2:
14415         if (!o)
14416             break;
14417
14418         /* This loop checks all the kid ops, skipping any that cannot pos-
14419          * sibly be responsible for the uninitialized value; i.e., defined
14420          * constants and ops that return nothing.  If there is only one op
14421          * left that is not skipped, then we *know* it is responsible for
14422          * the uninitialized value.  If there is more than one op left, we
14423          * have to look for an exact match in the while() loop below.
14424          */
14425         o2 = NULL;
14426         for (kid=o; kid; kid = kid->op_sibling) {
14427             if (kid) {
14428                 const OPCODE type = kid->op_type;
14429                 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
14430                   || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
14431                   || (type == OP_PUSHMARK)
14432                 )
14433                 continue;
14434             }
14435             if (o2) { /* more than one found */
14436                 o2 = NULL;
14437                 break;
14438             }
14439             o2 = kid;
14440         }
14441         if (o2)
14442             return find_uninit_var(o2, uninit_sv, match);
14443
14444         /* scan all args */
14445         while (o) {
14446             sv = find_uninit_var(o, uninit_sv, 1);
14447             if (sv)
14448                 return sv;
14449             o = o->op_sibling;
14450         }
14451         break;
14452     }
14453     return NULL;
14454 }
14455
14456
14457 /*
14458 =for apidoc report_uninit
14459
14460 Print appropriate "Use of uninitialized variable" warning.
14461
14462 =cut
14463 */
14464
14465 void
14466 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14467 {
14468     dVAR;
14469     if (PL_op) {
14470         SV* varname = NULL;
14471         if (uninit_sv && PL_curpad) {
14472             varname = find_uninit_var(PL_op, uninit_sv,0);
14473             if (varname)
14474                 sv_insert(varname, 0, 0, " ", 1);
14475         }
14476         /* diag_listed_as: Use of uninitialized value%s */
14477         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
14478                 SVfARG(varname ? varname : &PL_sv_no),
14479                 " in ", OP_DESC(PL_op));
14480     }
14481     else
14482         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14483                     "", "", "");
14484 }
14485
14486 /*
14487  * Local variables:
14488  * c-indentation-style: bsd
14489  * c-basic-offset: 4
14490  * indent-tabs-mode: t
14491  * End:
14492  *
14493  * ex: set ts=8 sts=4 sw=4 noet:
14494  */