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) != 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) != 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     /* 8 bytes on most ILP32 with IEEE doubles */
 897     { sizeof(NV), sizeof(NV),
 898       STRUCT_OFFSET(XPVNV, xnv_u),
 899       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
 900
 901     /* 8 bytes on most ILP32 with IEEE doubles */
 902     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
 903       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
 904       + STRUCT_OFFSET(XPV, xpv_cur),
 905       SVt_PV, FALSE, NONV, HASARENA,
 906       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 907
 908     /* 12 */
 909     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
 910       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 911       + STRUCT_OFFSET(XPV, xpv_cur),
 912       SVt_PVIV, FALSE, NONV, HASARENA,
 913       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 914
 915     /* 20 */
 916     { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
 917       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 918       + STRUCT_OFFSET(XPV, xpv_cur),
 919       SVt_PVNV, FALSE, HADNV, HASARENA,
 920       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 921
 922     /* 28 */
 923     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
 924       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 925
 926     /* something big */
 927     { sizeof(regexp),
 928       sizeof(regexp),
 929       0,
 930       SVt_REGEXP, FALSE, NONV, HASARENA,
 931       FIT_ARENA(0, sizeof(regexp))
 932     },
 933
 934     /* 48 */
 935     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
 936       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
 937
 938     /* 64 */
 939     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
 940       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
 941
 942     { sizeof(XPVAV),
 943       copy_length(XPVAV, xav_alloc),
 944       0,
 945       SVt_PVAV, TRUE, NONV, HASARENA,
 946       FIT_ARENA(0, sizeof(XPVAV)) },
 947
 948     { sizeof(XPVHV),
 949       copy_length(XPVHV, xhv_max),
 950       0,
 951       SVt_PVHV, TRUE, NONV, HASARENA,
 952       FIT_ARENA(0, sizeof(XPVHV)) },
 953
 954     /* 56 */
 955     { sizeof(XPVCV),
 956       sizeof(XPVCV),
 957       0,
 958       SVt_PVCV, TRUE, NONV, HASARENA,
 959       FIT_ARENA(0, sizeof(XPVCV)) },
 960
 961     { sizeof(XPVFM),
 962       sizeof(XPVFM),
 963       0,
 964       SVt_PVFM, TRUE, NONV, NOARENA,
 965       FIT_ARENA(20, sizeof(XPVFM)) },
 966
 967     /* XPVIO is 84 bytes, fits 48x */
 968     { sizeof(XPVIO),
 969       sizeof(XPVIO),
 970       0,
 971       SVt_PVIO, TRUE, NONV, HASARENA,
 972       FIT_ARENA(24, sizeof(XPVIO)) },
 973 };
 974
 975 #define new_body_allocated(sv_type)             \
 976     (void *)((char *)S_new_body(aTHX_ sv_type)  \
 977              - bodies_by_type[sv_type].offset)
 978
 979 /* return a thing to the free list */
 980
 981 #define del_body(thing, root)                           \
 982     STMT_START {                                        \
 983         void ** const thing_copy = (void **)thing;      \
 984         *thing_copy = *root;                            \
 985         *root = (void*)thing_copy;                      \
 986     } STMT_END
 987
 988 #ifdef PURIFY
 989
 990 #define new_XNV()       safemalloc(sizeof(XPVNV))
 991 #define new_XPVNV()     safemalloc(sizeof(XPVNV))
 992 #define new_XPVMG()     safemalloc(sizeof(XPVMG))
 993
 994 #define del_XPVGV(p)    safefree(p)
 995
 996 #else /* !PURIFY */
 997
 998 #define new_XNV()       new_body_allocated(SVt_NV)
 999 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
1000 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
1001
1002 #define del_XPVGV(p)    del_body(p + bodies_by_type[SVt_PVGV].offset,   \
1003                                  &PL_body_roots[SVt_PVGV])
1004
1005 #endif /* PURIFY */
1006
1007 /* no arena for you! */
1008
1009 #define new_NOARENA(details) \
1010         safemalloc((details)->body_size + (details)->offset)
1011 #define new_NOARENAZ(details) \
1012         safecalloc((details)->body_size + (details)->offset, 1)
1013
1014 void *
1015 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1016                   const size_t arena_size)
1017 {
1018     dVAR;
1019     void ** const root = &PL_body_roots[sv_type];
1020     struct arena_desc *adesc;
1021     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1022     unsigned int curr;
1023     char *start;
1024     const char *end;
1025     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1026 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1027     static bool done_sanity_check;
1028
1029     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1030      * variables like done_sanity_check. */
1031     if (!done_sanity_check) {
1032         unsigned int i = SVt_LAST;
1033
1034         done_sanity_check = TRUE;
1035
1036         while (i--)
1037             assert (bodies_by_type[i].type == i);
1038     }
1039 #endif
1040
1041     assert(arena_size);
1042
1043     /* may need new arena-set to hold new arena */
1044     if (!aroot || aroot->curr >= aroot->set_size) {
1045         struct arena_set *newroot;
1046         Newxz(newroot, 1, struct arena_set);
1047         newroot->set_size = ARENAS_PER_SET;
1048         newroot->next = aroot;
1049         aroot = newroot;
1050         PL_body_arenas = (void *) newroot;
1051         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1052     }
1053
1054     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1055     curr = aroot->curr++;
1056     adesc = &(aroot->set[curr]);
1057     assert(!adesc->arena);
1058
1059     Newx(adesc->arena, good_arena_size, char);
1060     adesc->size = good_arena_size;
1061     adesc->utype = sv_type;
1062     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1063                           curr, (void*)adesc->arena, (UV)good_arena_size));
1064
1065     start = (char *) adesc->arena;
1066
1067     /* Get the address of the byte after the end of the last body we can fit.
1068        Remember, this is integer division:  */
1069     end = start + good_arena_size / body_size * body_size;
1070
1071     /* computed count doesn't reflect the 1st slot reservation */
1072 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1073     DEBUG_m(PerlIO_printf(Perl_debug_log,
1074                           "arena %p end %p arena-size %d (from %d) type %d "
1075                           "size %d ct %d\n",
1076                           (void*)start, (void*)end, (int)good_arena_size,
1077                           (int)arena_size, sv_type, (int)body_size,
1078                           (int)good_arena_size / (int)body_size));
1079 #else
1080     DEBUG_m(PerlIO_printf(Perl_debug_log,
1081                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1082                           (void*)start, (void*)end,
1083                           (int)arena_size, sv_type, (int)body_size,
1084                           (int)good_arena_size / (int)body_size));
1085 #endif
1086     *root = (void *)start;
1087
1088     while (1) {
1089         /* Where the next body would start:  */
1090         char * const next = start + body_size;
1091
1092         if (next >= end) {
1093             /* This is the last body:  */
1094             assert(next == end);
1095
1096             *(void **)start = 0;
1097             return *root;
1098         }
1099
1100         *(void**) start = (void *)next;
1101         start = next;
1102     }
1103 }
1104
1105 /* grab a new thing from the free list, allocating more if necessary.
1106    The inline version is used for speed in hot routines, and the
1107    function using it serves the rest (unless PURIFY).
1108 */
1109 #define new_body_inline(xpv, sv_type) \
1110     STMT_START { \
1111         void ** const r3wt = &PL_body_roots[sv_type]; \
1112         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1113           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1114                                              bodies_by_type[sv_type].body_size,\
1115                                              bodies_by_type[sv_type].arena_size)); \
1116         *(r3wt) = *(void**)(xpv); \
1117     } STMT_END
1118
1119 #ifndef PURIFY
1120
1121 STATIC void *
1122 S_new_body(pTHX_ const svtype sv_type)
1123 {
1124     dVAR;
1125     void *xpv;
1126     new_body_inline(xpv, sv_type);
1127     return xpv;
1128 }
1129
1130 #endif
1131
1132 static const struct body_details fake_rv =
1133     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1134
1135 /*
1136 =for apidoc sv_upgrade
1137
1138 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1139 SV, then copies across as much information as possible from the old body.
1140 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1141
1142 =cut
1143 */
1144
1145 void
1146 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1147 {
1148     dVAR;
1149     void*       old_body;
1150     void*       new_body;
1151     const svtype old_type = SvTYPE(sv);
1152     const struct body_details *new_type_details;
1153     const struct body_details *old_type_details
1154         = bodies_by_type + old_type;
1155     SV *referant = NULL;
1156
1157     PERL_ARGS_ASSERT_SV_UPGRADE;
1158
1159     if (old_type == new_type)
1160         return;
1161
1162     /* This clause was purposefully added ahead of the early return above to
1163        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1164        inference by Nick I-S that it would fix other troublesome cases. See
1165        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1166
1167        Given that shared hash key scalars are no longer PVIV, but PV, there is
1168        no longer need to unshare so as to free up the IVX slot for its proper
1169        purpose. So it's safe to move the early return earlier.  */
1170
1171     if (new_type != SVt_PV && SvIsCOW(sv)) {
1172         sv_force_normal_flags(sv, 0);
1173     }
1174
1175     old_body = SvANY(sv);
1176
1177     /* Copying structures onto other structures that have been neatly zeroed
1178        has a subtle gotcha. Consider XPVMG
1179
1180        +------+------+------+------+------+-------+-------+
1181        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1182        +------+------+------+------+------+-------+-------+
1183        0      4      8     12     16     20      24      28
1184
1185        where NVs are aligned to 8 bytes, so that sizeof that structure is
1186        actually 32 bytes long, with 4 bytes of padding at the end:
1187
1188        +------+------+------+------+------+-------+-------+------+
1189        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1190        +------+------+------+------+------+-------+-------+------+
1191        0      4      8     12     16     20      24      28     32
1192
1193        so what happens if you allocate memory for this structure:
1194
1195        +------+------+------+------+------+-------+-------+------+------+...
1196        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1197        +------+------+------+------+------+-------+-------+------+------+...
1198        0      4      8     12     16     20      24      28     32     36
1199
1200        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1201        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1202        started out as zero once, but it's quite possible that it isn't. So now,
1203        rather than a nicely zeroed GP, you have it pointing somewhere random.
1204        Bugs ensue.
1205
1206        (In fact, GP ends up pointing at a previous GP structure, because the
1207        principle cause of the padding in XPVMG getting garbage is a copy of
1208        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1209        this happens to be moot because XPVGV has been re-ordered, with GP
1210        no longer after STASH)
1211
1212        So we are careful and work out the size of used parts of all the
1213        structures.  */
1214
1215     switch (old_type) {
1216     case SVt_NULL:
1217         break;
1218     case SVt_IV:
1219         if (SvROK(sv)) {
1220             referant = SvRV(sv);
1221             old_type_details = &fake_rv;
1222             if (new_type == SVt_NV)
1223                 new_type = SVt_PVNV;
1224         } else {
1225             if (new_type < SVt_PVIV) {
1226                 new_type = (new_type == SVt_NV)
1227                     ? SVt_PVNV : SVt_PVIV;
1228             }
1229         }
1230         break;
1231     case SVt_NV:
1232         if (new_type < SVt_PVNV) {
1233             new_type = SVt_PVNV;
1234         }
1235         break;
1236     case SVt_PV:
1237         assert(new_type > SVt_PV);
1238         assert(SVt_IV < SVt_PV);
1239         assert(SVt_NV < SVt_PV);
1240         break;
1241     case SVt_PVIV:
1242         break;
1243     case SVt_PVNV:
1244         break;
1245     case SVt_PVMG:
1246         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1247            there's no way that it can be safely upgraded, because perl.c
1248            expects to Safefree(SvANY(PL_mess_sv))  */
1249         assert(sv != PL_mess_sv);
1250         /* This flag bit is used to mean other things in other scalar types.
1251            Given that it only has meaning inside the pad, it shouldn't be set
1252            on anything that can get upgraded.  */
1253         assert(!SvPAD_TYPED(sv));
1254         break;
1255     default:
1256         if (old_type_details->cant_upgrade)
1257             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1258                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1259     }
1260
1261     if (old_type > new_type)
1262         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1263                 (int)old_type, (int)new_type);
1264
1265     new_type_details = bodies_by_type + new_type;
1266
1267     SvFLAGS(sv) &= ~SVTYPEMASK;
1268     SvFLAGS(sv) |= new_type;
1269
1270     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1271        the return statements above will have triggered.  */
1272     assert (new_type != SVt_NULL);
1273     switch (new_type) {
1274     case SVt_IV:
1275         assert(old_type == SVt_NULL);
1276         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1277         SvIV_set(sv, 0);
1278         return;
1279     case SVt_NV:
1280         assert(old_type == SVt_NULL);
1281         SvANY(sv) = new_XNV();
1282         SvNV_set(sv, 0);
1283         return;
1284     case SVt_PVHV:
1285     case SVt_PVAV:
1286         assert(new_type_details->body_size);
1287
1288 #ifndef PURIFY
1289         assert(new_type_details->arena);
1290         assert(new_type_details->arena_size);
1291         /* This points to the start of the allocated area.  */
1292         new_body_inline(new_body, new_type);
1293         Zero(new_body, new_type_details->body_size, char);
1294         new_body = ((char *)new_body) - new_type_details->offset;
1295 #else
1296         /* We always allocated the full length item with PURIFY. To do this
1297            we fake things so that arena is false for all 16 types..  */
1298         new_body = new_NOARENAZ(new_type_details);
1299 #endif
1300         SvANY(sv) = new_body;
1301         if (new_type == SVt_PVAV) {
1302             AvMAX(sv)   = -1;
1303             AvFILLp(sv) = -1;
1304             AvREAL_only(sv);
1305             if (old_type_details->body_size) {
1306                 AvALLOC(sv) = 0;
1307             } else {
1308                 /* It will have been zeroed when the new body was allocated.
1309                    Lets not write to it, in case it confuses a write-back
1310                    cache.  */
1311             }
1312         } else {
1313             assert(!SvOK(sv));
1314             SvOK_off(sv);
1315 #ifndef NODEFAULT_SHAREKEYS
1316             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1317 #endif
1318             HvMAX(sv) = 7; /* (start with 8 buckets) */
1319         }
1320
1321         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1322            The target created by newSVrv also is, and it can have magic.
1323            However, it never has SvPVX set.
1324         */
1325         if (old_type == SVt_IV) {
1326             assert(!SvROK(sv));
1327         } else if (old_type >= SVt_PV) {
1328             assert(SvPVX_const(sv) == 0);
1329         }
1330
1331         if (old_type >= SVt_PVMG) {
1332             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1333             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1334         } else {
1335             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1336         }
1337         break;
1338
1339
1340     case SVt_REGEXP:
1341         /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1342            sv_force_normal_flags(sv) is called.  */
1343         SvFAKE_on(sv);
1344     case SVt_PVIV:
1345         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1346            no route from NV to PVIV, NOK can never be true  */
1347         assert(!SvNOKp(sv));
1348         assert(!SvNOK(sv));
1349     case SVt_PVIO:
1350     case SVt_PVFM:
1351     case SVt_PVGV:
1352     case SVt_PVCV:
1353     case SVt_PVLV:
1354     case SVt_PVMG:
1355     case SVt_PVNV:
1356     case SVt_PV:
1357
1358         assert(new_type_details->body_size);
1359         /* We always allocated the full length item with PURIFY. To do this
1360            we fake things so that arena is false for all 16 types..  */
1361         if(new_type_details->arena) {
1362             /* This points to the start of the allocated area.  */
1363             new_body_inline(new_body, new_type);
1364             Zero(new_body, new_type_details->body_size, char);
1365             new_body = ((char *)new_body) - new_type_details->offset;
1366         } else {
1367             new_body = new_NOARENAZ(new_type_details);
1368         }
1369         SvANY(sv) = new_body;
1370
1371         if (old_type_details->copy) {
1372             /* There is now the potential for an upgrade from something without
1373                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1374             int offset = old_type_details->offset;
1375             int length = old_type_details->copy;
1376
1377             if (new_type_details->offset > old_type_details->offset) {
1378                 const int difference
1379                     = new_type_details->offset - old_type_details->offset;
1380                 offset += difference;
1381                 length -= difference;
1382             }
1383             assert (length >= 0);
1384
1385             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1386                  char);
1387         }
1388
1389 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1390         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1391          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1392          * NV slot, but the new one does, then we need to initialise the
1393          * freshly created NV slot with whatever the correct bit pattern is
1394          * for 0.0  */
1395         if (old_type_details->zero_nv && !new_type_details->zero_nv
1396             && !isGV_with_GP(sv))
1397             SvNV_set(sv, 0);
1398 #endif
1399
1400         if (new_type == SVt_PVIO) {
1401             IO * const io = MUTABLE_IO(sv);
1402             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1403
1404             SvOBJECT_on(io);
1405             /* Clear the stashcache because a new IO could overrule a package
1406                name */
1407             hv_clear(PL_stashcache);
1408
1409             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1410             IoPAGE_LEN(sv) = 60;
1411         }
1412         if (old_type < SVt_PV) {
1413             /* referant will be NULL unless the old type was SVt_IV emulating
1414                SVt_RV */
1415             sv->sv_u.svu_rv = referant;
1416         }
1417         break;
1418     default:
1419         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1420                    (unsigned long)new_type);
1421     }
1422
1423     if (old_type > SVt_IV) {
1424 #ifdef PURIFY
1425         safefree(old_body);
1426 #else
1427         /* Note that there is an assumption that all bodies of types that
1428            can be upgraded came from arenas. Only the more complex non-
1429            upgradable types are allowed to be directly malloc()ed.  */
1430         assert(old_type_details->arena);
1431         del_body((void*)((char*)old_body + old_type_details->offset),
1432                  &PL_body_roots[old_type]);
1433 #endif
1434     }
1435 }
1436
1437 /*
1438 =for apidoc sv_backoff
1439
1440 Remove any string offset. You should normally use the C<SvOOK_off> macro
1441 wrapper instead.
1442
1443 =cut
1444 */
1445
1446 int
1447 Perl_sv_backoff(pTHX_ register SV *const sv)
1448 {
1449     STRLEN delta;
1450     const char * const s = SvPVX_const(sv);
1451
1452     PERL_ARGS_ASSERT_SV_BACKOFF;
1453     PERL_UNUSED_CONTEXT;
1454
1455     assert(SvOOK(sv));
1456     assert(SvTYPE(sv) != SVt_PVHV);
1457     assert(SvTYPE(sv) != SVt_PVAV);
1458
1459     SvOOK_offset(sv, delta);
1460
1461     SvLEN_set(sv, SvLEN(sv) + delta);
1462     SvPV_set(sv, SvPVX(sv) - delta);
1463     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1464     SvFLAGS(sv) &= ~SVf_OOK;
1465     return 0;
1466 }
1467
1468 /*
1469 =for apidoc sv_grow
1470
1471 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1472 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1473 Use the C<SvGROW> wrapper instead.
1474
1475 =cut
1476 */
1477
1478 char *
1479 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1480 {
1481     register char *s;
1482
1483     PERL_ARGS_ASSERT_SV_GROW;
1484
1485     if (PL_madskills && newlen >= 0x100000) {
1486         PerlIO_printf(Perl_debug_log,
1487                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1488     }
1489 #ifdef HAS_64K_LIMIT
1490     if (newlen >= 0x10000) {
1491         PerlIO_printf(Perl_debug_log,
1492                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1493         my_exit(1);
1494     }
1495 #endif /* HAS_64K_LIMIT */
1496     if (SvROK(sv))
1497         sv_unref(sv);
1498     if (SvTYPE(sv) < SVt_PV) {
1499         sv_upgrade(sv, SVt_PV);
1500         s = SvPVX_mutable(sv);
1501     }
1502     else if (SvOOK(sv)) {       /* pv is offset? */
1503         sv_backoff(sv);
1504         s = SvPVX_mutable(sv);
1505         if (newlen > SvLEN(sv))
1506             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1507 #ifdef HAS_64K_LIMIT
1508         if (newlen >= 0x10000)
1509             newlen = 0xFFFF;
1510 #endif
1511     }
1512     else
1513         s = SvPVX_mutable(sv);
1514
1515     if (newlen > SvLEN(sv)) {           /* need more room? */
1516         STRLEN minlen = SvCUR(sv);
1517         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1518         if (newlen < minlen)
1519             newlen = minlen;
1520 #ifndef Perl_safesysmalloc_size
1521         newlen = PERL_STRLEN_ROUNDUP(newlen);
1522 #endif
1523         if (SvLEN(sv) && s) {
1524             s = (char*)saferealloc(s, newlen);
1525         }
1526         else {
1527             s = (char*)safemalloc(newlen);
1528             if (SvPVX_const(sv) && SvCUR(sv)) {
1529                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1530             }
1531         }
1532         SvPV_set(sv, s);
1533 #ifdef Perl_safesysmalloc_size
1534         /* Do this here, do it once, do it right, and then we will never get
1535            called back into sv_grow() unless there really is some growing
1536            needed.  */
1537         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1538 #else
1539         SvLEN_set(sv, newlen);
1540 #endif
1541     }
1542     return s;
1543 }
1544
1545 /*
1546 =for apidoc sv_setiv
1547
1548 Copies an integer into the given SV, upgrading first if necessary.
1549 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1550
1551 =cut
1552 */
1553
1554 void
1555 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1556 {
1557     dVAR;
1558
1559     PERL_ARGS_ASSERT_SV_SETIV;
1560
1561     SV_CHECK_THINKFIRST_COW_DROP(sv);
1562     switch (SvTYPE(sv)) {
1563     case SVt_NULL:
1564     case SVt_NV:
1565         sv_upgrade(sv, SVt_IV);
1566         break;
1567     case SVt_PV:
1568         sv_upgrade(sv, SVt_PVIV);
1569         break;
1570
1571     case SVt_PVGV:
1572         if (!isGV_with_GP(sv))
1573             break;
1574     case SVt_PVAV:
1575     case SVt_PVHV:
1576     case SVt_PVCV:
1577     case SVt_PVFM:
1578     case SVt_PVIO:
1579         /* diag_listed_as: Can't coerce %s to %s in %s */
1580         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1581                    OP_DESC(PL_op));
1582     default: NOOP;
1583     }
1584     (void)SvIOK_only(sv);                       /* validate number */
1585     SvIV_set(sv, i);
1586     SvTAINT(sv);
1587 }
1588
1589 /*
1590 =for apidoc sv_setiv_mg
1591
1592 Like C<sv_setiv>, but also handles 'set' magic.
1593
1594 =cut
1595 */
1596
1597 void
1598 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1599 {
1600     PERL_ARGS_ASSERT_SV_SETIV_MG;
1601
1602     sv_setiv(sv,i);
1603     SvSETMAGIC(sv);
1604 }
1605
1606 /*
1607 =for apidoc sv_setuv
1608
1609 Copies an unsigned integer into the given SV, upgrading first if necessary.
1610 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1611
1612 =cut
1613 */
1614
1615 void
1616 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1617 {
1618     PERL_ARGS_ASSERT_SV_SETUV;
1619
1620     /* With these two if statements:
1621        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1622
1623        without
1624        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1625
1626        If you wish to remove them, please benchmark to see what the effect is
1627     */
1628     if (u <= (UV)IV_MAX) {
1629        sv_setiv(sv, (IV)u);
1630        return;
1631     }
1632     sv_setiv(sv, 0);
1633     SvIsUV_on(sv);
1634     SvUV_set(sv, u);
1635 }
1636
1637 /*
1638 =for apidoc sv_setuv_mg
1639
1640 Like C<sv_setuv>, but also handles 'set' magic.
1641
1642 =cut
1643 */
1644
1645 void
1646 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1647 {
1648     PERL_ARGS_ASSERT_SV_SETUV_MG;
1649
1650     sv_setuv(sv,u);
1651     SvSETMAGIC(sv);
1652 }
1653
1654 /*
1655 =for apidoc sv_setnv
1656
1657 Copies a double into the given SV, upgrading first if necessary.
1658 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1659
1660 =cut
1661 */
1662
1663 void
1664 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1665 {
1666     dVAR;
1667
1668     PERL_ARGS_ASSERT_SV_SETNV;
1669
1670     SV_CHECK_THINKFIRST_COW_DROP(sv);
1671     switch (SvTYPE(sv)) {
1672     case SVt_NULL:
1673     case SVt_IV:
1674         sv_upgrade(sv, SVt_NV);
1675         break;
1676     case SVt_PV:
1677     case SVt_PVIV:
1678         sv_upgrade(sv, SVt_PVNV);
1679         break;
1680
1681     case SVt_PVGV:
1682         if (!isGV_with_GP(sv))
1683             break;
1684     case SVt_PVAV:
1685     case SVt_PVHV:
1686     case SVt_PVCV:
1687     case SVt_PVFM:
1688     case SVt_PVIO:
1689         /* diag_listed_as: Can't coerce %s to %s in %s */
1690         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1691                    OP_DESC(PL_op));
1692     default: NOOP;
1693     }
1694     SvNV_set(sv, num);
1695     (void)SvNOK_only(sv);                       /* validate number */
1696     SvTAINT(sv);
1697 }
1698
1699 /*
1700 =for apidoc sv_setnv_mg
1701
1702 Like C<sv_setnv>, but also handles 'set' magic.
1703
1704 =cut
1705 */
1706
1707 void
1708 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1709 {
1710     PERL_ARGS_ASSERT_SV_SETNV_MG;
1711
1712     sv_setnv(sv,num);
1713     SvSETMAGIC(sv);
1714 }
1715
1716 /* Print an "isn't numeric" warning, using a cleaned-up,
1717  * printable version of the offending string
1718  */
1719
1720 STATIC void
1721 S_not_a_number(pTHX_ SV *const sv)
1722 {
1723      dVAR;
1724      SV *dsv;
1725      char tmpbuf[64];
1726      const char *pv;
1727
1728      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1729
1730      if (DO_UTF8(sv)) {
1731           dsv = newSVpvs_flags("", SVs_TEMP);
1732           pv = sv_uni_display(dsv, sv, 10, 0);
1733      } else {
1734           char *d = tmpbuf;
1735           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1736           /* each *s can expand to 4 chars + "...\0",
1737              i.e. need room for 8 chars */
1738
1739           const char *s = SvPVX_const(sv);
1740           const char * const end = s + SvCUR(sv);
1741           for ( ; s < end && d < limit; s++ ) {
1742                int ch = *s & 0xFF;
1743                if (ch & 128 && !isPRINT_LC(ch)) {
1744                     *d++ = 'M';
1745                     *d++ = '-';
1746                     ch &= 127;
1747                }
1748                if (ch == '\n') {
1749                     *d++ = '\\';
1750                     *d++ = 'n';
1751                }
1752                else if (ch == '\r') {
1753                     *d++ = '\\';
1754                     *d++ = 'r';
1755                }
1756                else if (ch == '\f') {
1757                     *d++ = '\\';
1758                     *d++ = 'f';
1759                }
1760                else if (ch == '\\') {
1761                     *d++ = '\\';
1762                     *d++ = '\\';
1763                }
1764                else if (ch == '\0') {
1765                     *d++ = '\\';
1766                     *d++ = '0';
1767                }
1768                else if (isPRINT_LC(ch))
1769                     *d++ = ch;
1770                else {
1771                     *d++ = '^';
1772                     *d++ = toCTRL(ch);
1773                }
1774           }
1775           if (s < end) {
1776                *d++ = '.';
1777                *d++ = '.';
1778                *d++ = '.';
1779           }
1780           *d = '\0';
1781           pv = tmpbuf;
1782     }
1783
1784     if (PL_op)
1785         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1786                     "Argument \"%s\" isn't numeric in %s", pv,
1787                     OP_DESC(PL_op));
1788     else
1789         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1790                     "Argument \"%s\" isn't numeric", pv);
1791 }
1792
1793 /*
1794 =for apidoc looks_like_number
1795
1796 Test if the content of an SV looks like a number (or is a number).
1797 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1798 non-numeric warning), even if your atof() doesn't grok them.
1799
1800 =cut
1801 */
1802
1803 I32
1804 Perl_looks_like_number(pTHX_ SV *const sv)
1805 {
1806     register const char *sbegin;
1807     STRLEN len;
1808
1809     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1810
1811     if (SvPOK(sv)) {
1812         sbegin = SvPVX_const(sv);
1813         len = SvCUR(sv);
1814     }
1815     else if (SvPOKp(sv))
1816         sbegin = SvPV_const(sv, len);
1817     else
1818         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1819     return grok_number(sbegin, len, NULL);
1820 }
1821
1822 STATIC bool
1823 S_glob_2number(pTHX_ GV * const gv)
1824 {
1825     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1826     SV *const buffer = sv_newmortal();
1827
1828     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1829
1830     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1831        is on.  */
1832     SvFAKE_off(gv);
1833     gv_efullname3(buffer, gv, "*");
1834     SvFLAGS(gv) |= wasfake;
1835
1836     /* We know that all GVs stringify to something that is not-a-number,
1837         so no need to test that.  */
1838     if (ckWARN(WARN_NUMERIC))
1839         not_a_number(buffer);
1840     /* We just want something true to return, so that S_sv_2iuv_common
1841         can tail call us and return true.  */
1842     return TRUE;
1843 }
1844
1845 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1846    until proven guilty, assume that things are not that bad... */
1847
1848 /*
1849    NV_PRESERVES_UV:
1850
1851    As 64 bit platforms often have an NV that doesn't preserve all bits of
1852    an IV (an assumption perl has been based on to date) it becomes necessary
1853    to remove the assumption that the NV always carries enough precision to
1854    recreate the IV whenever needed, and that the NV is the canonical form.
1855    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1856    precision as a side effect of conversion (which would lead to insanity
1857    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1858    1) to distinguish between IV/UV/NV slots that have cached a valid
1859       conversion where precision was lost and IV/UV/NV slots that have a
1860       valid conversion which has lost no precision
1861    2) to ensure that if a numeric conversion to one form is requested that
1862       would lose precision, the precise conversion (or differently
1863       imprecise conversion) is also performed and cached, to prevent
1864       requests for different numeric formats on the same SV causing
1865       lossy conversion chains. (lossless conversion chains are perfectly
1866       acceptable (still))
1867
1868
1869    flags are used:
1870    SvIOKp is true if the IV slot contains a valid value
1871    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1872    SvNOKp is true if the NV slot contains a valid value
1873    SvNOK  is true only if the NV value is accurate
1874
1875    so
1876    while converting from PV to NV, check to see if converting that NV to an
1877    IV(or UV) would lose accuracy over a direct conversion from PV to
1878    IV(or UV). If it would, cache both conversions, return NV, but mark
1879    SV as IOK NOKp (ie not NOK).
1880
1881    While converting from PV to IV, check to see if converting that IV to an
1882    NV would lose accuracy over a direct conversion from PV to NV. If it
1883    would, cache both conversions, flag similarly.
1884
1885    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1886    correctly because if IV & NV were set NV *always* overruled.
1887    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1888    changes - now IV and NV together means that the two are interchangeable:
1889    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1890
1891    The benefit of this is that operations such as pp_add know that if
1892    SvIOK is true for both left and right operands, then integer addition
1893    can be used instead of floating point (for cases where the result won't
1894    overflow). Before, floating point was always used, which could lead to
1895    loss of precision compared with integer addition.
1896
1897    * making IV and NV equal status should make maths accurate on 64 bit
1898      platforms
1899    * may speed up maths somewhat if pp_add and friends start to use
1900      integers when possible instead of fp. (Hopefully the overhead in
1901      looking for SvIOK and checking for overflow will not outweigh the
1902      fp to integer speedup)
1903    * will slow down integer operations (callers of SvIV) on "inaccurate"
1904      values, as the change from SvIOK to SvIOKp will cause a call into
1905      sv_2iv each time rather than a macro access direct to the IV slot
1906    * should speed up number->string conversion on integers as IV is
1907      favoured when IV and NV are equally accurate
1908
1909    ####################################################################
1910    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1911    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1912    On the other hand, SvUOK is true iff UV.
1913    ####################################################################
1914
1915    Your mileage will vary depending your CPU's relative fp to integer
1916    performance ratio.
1917 */
1918
1919 #ifndef NV_PRESERVES_UV
1920 #  define IS_NUMBER_UNDERFLOW_IV 1
1921 #  define IS_NUMBER_UNDERFLOW_UV 2
1922 #  define IS_NUMBER_IV_AND_UV    2
1923 #  define IS_NUMBER_OVERFLOW_IV  4
1924 #  define IS_NUMBER_OVERFLOW_UV  5
1925
1926 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1927
1928 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1929 STATIC int
1930 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1931 #  ifdef DEBUGGING
1932                        , I32 numtype
1933 #  endif
1934                        )
1935 {
1936     dVAR;
1937
1938     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1939
1940     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));
1941     if (SvNVX(sv) < (NV)IV_MIN) {
1942         (void)SvIOKp_on(sv);
1943         (void)SvNOK_on(sv);
1944         SvIV_set(sv, IV_MIN);
1945         return IS_NUMBER_UNDERFLOW_IV;
1946     }
1947     if (SvNVX(sv) > (NV)UV_MAX) {
1948         (void)SvIOKp_on(sv);
1949         (void)SvNOK_on(sv);
1950         SvIsUV_on(sv);
1951         SvUV_set(sv, UV_MAX);
1952         return IS_NUMBER_OVERFLOW_UV;
1953     }
1954     (void)SvIOKp_on(sv);
1955     (void)SvNOK_on(sv);
1956     /* Can't use strtol etc to convert this string.  (See truth table in
1957        sv_2iv  */
1958     if (SvNVX(sv) <= (UV)IV_MAX) {
1959         SvIV_set(sv, I_V(SvNVX(sv)));
1960         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1961             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1962         } else {
1963             /* Integer is imprecise. NOK, IOKp */
1964         }
1965         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1966     }
1967     SvIsUV_on(sv);
1968     SvUV_set(sv, U_V(SvNVX(sv)));
1969     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1970         if (SvUVX(sv) == UV_MAX) {
1971             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1972                possibly be preserved by NV. Hence, it must be overflow.
1973                NOK, IOKp */
1974             return IS_NUMBER_OVERFLOW_UV;
1975         }
1976         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1977     } else {
1978         /* Integer is imprecise. NOK, IOKp */
1979     }
1980     return IS_NUMBER_OVERFLOW_IV;
1981 }
1982 #endif /* !NV_PRESERVES_UV*/
1983
1984 STATIC bool
1985 S_sv_2iuv_common(pTHX_ SV *const sv)
1986 {
1987     dVAR;
1988
1989     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1990
1991     if (SvNOKp(sv)) {
1992         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1993          * without also getting a cached IV/UV from it at the same time
1994          * (ie PV->NV conversion should detect loss of accuracy and cache
1995          * IV or UV at same time to avoid this. */
1996         /* IV-over-UV optimisation - choose to cache IV if possible */
1997
1998         if (SvTYPE(sv) == SVt_NV)
1999             sv_upgrade(sv, SVt_PVNV);
2000
2001         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2002         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2003            certainly cast into the IV range at IV_MAX, whereas the correct
2004            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2005            cases go to UV */
2006 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2007         if (Perl_isnan(SvNVX(sv))) {
2008             SvUV_set(sv, 0);
2009             SvIsUV_on(sv);
2010             return FALSE;
2011         }
2012 #endif
2013         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2014             SvIV_set(sv, I_V(SvNVX(sv)));
2015             if (SvNVX(sv) == (NV) SvIVX(sv)
2016 #ifndef NV_PRESERVES_UV
2017                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2018                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2019                 /* Don't flag it as "accurately an integer" if the number
2020                    came from a (by definition imprecise) NV operation, and
2021                    we're outside the range of NV integer precision */
2022 #endif
2023                 ) {
2024                 if (SvNOK(sv))
2025                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2026                 else {
2027                     /* scalar has trailing garbage, eg "42a" */
2028                 }
2029                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2030                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2031                                       PTR2UV(sv),
2032                                       SvNVX(sv),
2033                                       SvIVX(sv)));
2034
2035             } else {
2036                 /* IV not precise.  No need to convert from PV, as NV
2037                    conversion would already have cached IV if it detected
2038                    that PV->IV would be better than PV->NV->IV
2039                    flags already correct - don't set public IOK.  */
2040                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2041                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2042                                       PTR2UV(sv),
2043                                       SvNVX(sv),
2044                                       SvIVX(sv)));
2045             }
2046             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2047                but the cast (NV)IV_MIN rounds to a the value less (more
2048                negative) than IV_MIN which happens to be equal to SvNVX ??
2049                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2050                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2051                (NV)UVX == NVX are both true, but the values differ. :-(
2052                Hopefully for 2s complement IV_MIN is something like
2053                0x8000000000000000 which will be exact. NWC */
2054         }
2055         else {
2056             SvUV_set(sv, U_V(SvNVX(sv)));
2057             if (
2058                 (SvNVX(sv) == (NV) SvUVX(sv))
2059 #ifndef  NV_PRESERVES_UV
2060                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2061                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2062                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2063                 /* Don't flag it as "accurately an integer" if the number
2064                    came from a (by definition imprecise) NV operation, and
2065                    we're outside the range of NV integer precision */
2066 #endif
2067                 && SvNOK(sv)
2068                 )
2069                 SvIOK_on(sv);
2070             SvIsUV_on(sv);
2071             DEBUG_c(PerlIO_printf(Perl_debug_log,
2072                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2073                                   PTR2UV(sv),
2074                                   SvUVX(sv),
2075                                   SvUVX(sv)));
2076         }
2077     }
2078     else if (SvPOKp(sv) && SvLEN(sv)) {
2079         UV value;
2080         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2081         /* We want to avoid a possible problem when we cache an IV/ a UV which
2082            may be later translated to an NV, and the resulting NV is not
2083            the same as the direct translation of the initial string
2084            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2085            be careful to ensure that the value with the .456 is around if the
2086            NV value is requested in the future).
2087
2088            This means that if we cache such an IV/a UV, we need to cache the
2089            NV as well.  Moreover, we trade speed for space, and do not
2090            cache the NV if we are sure it's not needed.
2091          */
2092
2093         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2094         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2095              == IS_NUMBER_IN_UV) {
2096             /* It's definitely an integer, only upgrade to PVIV */
2097             if (SvTYPE(sv) < SVt_PVIV)
2098                 sv_upgrade(sv, SVt_PVIV);
2099             (void)SvIOK_on(sv);
2100         } else if (SvTYPE(sv) < SVt_PVNV)
2101             sv_upgrade(sv, SVt_PVNV);
2102
2103         /* If NVs preserve UVs then we only use the UV value if we know that
2104            we aren't going to call atof() below. If NVs don't preserve UVs
2105            then the value returned may have more precision than atof() will
2106            return, even though value isn't perfectly accurate.  */
2107         if ((numtype & (IS_NUMBER_IN_UV
2108 #ifdef NV_PRESERVES_UV
2109                         | IS_NUMBER_NOT_INT
2110 #endif
2111             )) == IS_NUMBER_IN_UV) {
2112             /* This won't turn off the public IOK flag if it was set above  */
2113             (void)SvIOKp_on(sv);
2114
2115             if (!(numtype & IS_NUMBER_NEG)) {
2116                 /* positive */;
2117                 if (value <= (UV)IV_MAX) {
2118                     SvIV_set(sv, (IV)value);
2119                 } else {
2120                     /* it didn't overflow, and it was positive. */
2121                     SvUV_set(sv, value);
2122                     SvIsUV_on(sv);
2123                 }
2124             } else {
2125                 /* 2s complement assumption  */
2126                 if (value <= (UV)IV_MIN) {
2127                     SvIV_set(sv, -(IV)value);
2128                 } else {
2129                     /* Too negative for an IV.  This is a double upgrade, but
2130                        I'm assuming it will be rare.  */
2131                     if (SvTYPE(sv) < SVt_PVNV)
2132                         sv_upgrade(sv, SVt_PVNV);
2133                     SvNOK_on(sv);
2134                     SvIOK_off(sv);
2135                     SvIOKp_on(sv);
2136                     SvNV_set(sv, -(NV)value);
2137                     SvIV_set(sv, IV_MIN);
2138                 }
2139             }
2140         }
2141         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2142            will be in the previous block to set the IV slot, and the next
2143            block to set the NV slot.  So no else here.  */
2144
2145         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2146             != IS_NUMBER_IN_UV) {
2147             /* It wasn't an (integer that doesn't overflow the UV). */
2148             SvNV_set(sv, Atof(SvPVX_const(sv)));
2149
2150             if (! numtype && ckWARN(WARN_NUMERIC))
2151                 not_a_number(sv);
2152
2153 #if defined(USE_LONG_DOUBLE)
2154             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2155                                   PTR2UV(sv), SvNVX(sv)));
2156 #else
2157             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2158                                   PTR2UV(sv), SvNVX(sv)));
2159 #endif
2160
2161 #ifdef NV_PRESERVES_UV
2162             (void)SvIOKp_on(sv);
2163             (void)SvNOK_on(sv);
2164             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2165                 SvIV_set(sv, I_V(SvNVX(sv)));
2166                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2167                     SvIOK_on(sv);
2168                 } else {
2169                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2170                 }
2171                 /* UV will not work better than IV */
2172             } else {
2173                 if (SvNVX(sv) > (NV)UV_MAX) {
2174                     SvIsUV_on(sv);
2175                     /* Integer is inaccurate. NOK, IOKp, is UV */
2176                     SvUV_set(sv, UV_MAX);
2177                 } else {
2178                     SvUV_set(sv, U_V(SvNVX(sv)));
2179                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2180                        NV preservse UV so can do correct comparison.  */
2181                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2182                         SvIOK_on(sv);
2183                     } else {
2184                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2185                     }
2186                 }
2187                 SvIsUV_on(sv);
2188             }
2189 #else /* NV_PRESERVES_UV */
2190             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2191                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2192                 /* The IV/UV slot will have been set from value returned by
2193                    grok_number above.  The NV slot has just been set using
2194                    Atof.  */
2195                 SvNOK_on(sv);
2196                 assert (SvIOKp(sv));
2197             } else {
2198                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2199                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2200                     /* Small enough to preserve all bits. */
2201                     (void)SvIOKp_on(sv);
2202                     SvNOK_on(sv);
2203                     SvIV_set(sv, I_V(SvNVX(sv)));
2204                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2205                         SvIOK_on(sv);
2206                     /* Assumption: first non-preserved integer is < IV_MAX,
2207                        this NV is in the preserved range, therefore: */
2208                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2209                           < (UV)IV_MAX)) {
2210                         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);
2211                     }
2212                 } else {
2213                     /* IN_UV NOT_INT
2214                          0      0       already failed to read UV.
2215                          0      1       already failed to read UV.
2216                          1      0       you won't get here in this case. IV/UV
2217                                         slot set, public IOK, Atof() unneeded.
2218                          1      1       already read UV.
2219                        so there's no point in sv_2iuv_non_preserve() attempting
2220                        to use atol, strtol, strtoul etc.  */
2221 #  ifdef DEBUGGING
2222                     sv_2iuv_non_preserve (sv, numtype);
2223 #  else
2224                     sv_2iuv_non_preserve (sv);
2225 #  endif
2226                 }
2227             }
2228 #endif /* NV_PRESERVES_UV */
2229         /* It might be more code efficient to go through the entire logic above
2230            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2231            gets complex and potentially buggy, so more programmer efficient
2232            to do it this way, by turning off the public flags:  */
2233         if (!numtype)
2234             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2235         }
2236     }
2237     else  {
2238         if (isGV_with_GP(sv))
2239             return glob_2number(MUTABLE_GV(sv));
2240
2241         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2242             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2243                 report_uninit(sv);
2244         }
2245         if (SvTYPE(sv) < SVt_IV)
2246             /* Typically the caller expects that sv_any is not NULL now.  */
2247             sv_upgrade(sv, SVt_IV);
2248         /* Return 0 from the caller.  */
2249         return TRUE;
2250     }
2251     return FALSE;
2252 }
2253
2254 /*
2255 =for apidoc sv_2iv_flags
2256
2257 Return the integer value of an SV, doing any necessary string
2258 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2259 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2260
2261 =cut
2262 */
2263
2264 IV
2265 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2266 {
2267     dVAR;
2268     if (!sv)
2269         return 0;
2270     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2271         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2272            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2273            In practice they are extremely unlikely to actually get anywhere
2274            accessible by user Perl code - the only way that I'm aware of is when
2275            a constant subroutine which is used as the second argument to index.
2276         */
2277         if (flags & SV_GMAGIC)
2278             mg_get(sv);
2279         if (SvIOKp(sv))
2280             return SvIVX(sv);
2281         if (SvNOKp(sv)) {
2282             return I_V(SvNVX(sv));
2283         }
2284         if (SvPOKp(sv) && SvLEN(sv)) {
2285             UV value;
2286             const int numtype
2287                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2288
2289             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2290                 == IS_NUMBER_IN_UV) {
2291                 /* It's definitely an integer */
2292                 if (numtype & IS_NUMBER_NEG) {
2293                     if (value < (UV)IV_MIN)
2294                         return -(IV)value;
2295                 } else {
2296                     if (value < (UV)IV_MAX)
2297                         return (IV)value;
2298                 }
2299             }
2300             if (!numtype) {
2301                 if (ckWARN(WARN_NUMERIC))
2302                     not_a_number(sv);
2303             }
2304             return I_V(Atof(SvPVX_const(sv)));
2305         }
2306         if (SvROK(sv)) {
2307             goto return_rok;
2308         }
2309         assert(SvTYPE(sv) >= SVt_PVMG);
2310         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2311     } else if (SvTHINKFIRST(sv)) {
2312         if (SvROK(sv)) {
2313         return_rok:
2314             if (SvAMAGIC(sv)) {
2315                 SV * tmpstr;
2316                 if (flags & SV_SKIP_OVERLOAD)
2317                     return 0;
2318                 tmpstr = AMG_CALLunary(sv, numer_amg);
2319                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2320                     return SvIV(tmpstr);
2321                 }
2322             }
2323             return PTR2IV(SvRV(sv));
2324         }
2325         if (SvIsCOW(sv)) {
2326             sv_force_normal_flags(sv, 0);
2327         }
2328         if (SvREADONLY(sv) && !SvOK(sv)) {
2329             if (ckWARN(WARN_UNINITIALIZED))
2330                 report_uninit(sv);
2331             return 0;
2332         }
2333     }
2334     if (!SvIOKp(sv)) {
2335         if (S_sv_2iuv_common(aTHX_ sv))
2336             return 0;
2337     }
2338     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2339         PTR2UV(sv),SvIVX(sv)));
2340     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2341 }
2342
2343 /*
2344 =for apidoc sv_2uv_flags
2345
2346 Return the unsigned integer value of an SV, doing any necessary string
2347 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2348 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2349
2350 =cut
2351 */
2352
2353 UV
2354 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2355 {
2356     dVAR;
2357     if (!sv)
2358         return 0;
2359     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2360         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2361            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  */
2362         if (flags & SV_GMAGIC)
2363             mg_get(sv);
2364         if (SvIOKp(sv))
2365             return SvUVX(sv);
2366         if (SvNOKp(sv))
2367             return U_V(SvNVX(sv));
2368         if (SvPOKp(sv) && SvLEN(sv)) {
2369             UV value;
2370             const int numtype
2371                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2372
2373             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2374                 == IS_NUMBER_IN_UV) {
2375                 /* It's definitely an integer */
2376                 if (!(numtype & IS_NUMBER_NEG))
2377                     return value;
2378             }
2379             if (!numtype) {
2380                 if (ckWARN(WARN_NUMERIC))
2381                     not_a_number(sv);
2382             }
2383             return U_V(Atof(SvPVX_const(sv)));
2384         }
2385         if (SvROK(sv)) {
2386             goto return_rok;
2387         }
2388         assert(SvTYPE(sv) >= SVt_PVMG);
2389         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2390     } else if (SvTHINKFIRST(sv)) {
2391         if (SvROK(sv)) {
2392         return_rok:
2393             if (SvAMAGIC(sv)) {
2394                 SV *tmpstr;
2395                 if (flags & SV_SKIP_OVERLOAD)
2396                     return 0;
2397                 tmpstr = AMG_CALLunary(sv, numer_amg);
2398                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2399                     return SvUV(tmpstr);
2400                 }
2401             }
2402             return PTR2UV(SvRV(sv));
2403         }
2404         if (SvIsCOW(sv)) {
2405             sv_force_normal_flags(sv, 0);
2406         }
2407         if (SvREADONLY(sv) && !SvOK(sv)) {
2408             if (ckWARN(WARN_UNINITIALIZED))
2409                 report_uninit(sv);
2410             return 0;
2411         }
2412     }
2413     if (!SvIOKp(sv)) {
2414         if (S_sv_2iuv_common(aTHX_ sv))
2415             return 0;
2416     }
2417
2418     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2419                           PTR2UV(sv),SvUVX(sv)));
2420     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2421 }
2422
2423 /*
2424 =for apidoc sv_2nv_flags
2425
2426 Return the num value of an SV, doing any necessary string or integer
2427 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2428 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2429
2430 =cut
2431 */
2432
2433 NV
2434 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2435 {
2436     dVAR;
2437     if (!sv)
2438         return 0.0;
2439     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2440         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2441            the same flag bit as SVf_IVisUV, so must not let them cache NVs.  */
2442         if (flags & SV_GMAGIC)
2443             mg_get(sv);
2444         if (SvNOKp(sv))
2445             return SvNVX(sv);
2446         if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2447             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2448                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2449                 not_a_number(sv);
2450             return Atof(SvPVX_const(sv));
2451         }
2452         if (SvIOKp(sv)) {
2453             if (SvIsUV(sv))
2454                 return (NV)SvUVX(sv);
2455             else
2456                 return (NV)SvIVX(sv);
2457         }
2458         if (SvROK(sv)) {
2459             goto return_rok;
2460         }
2461         assert(SvTYPE(sv) >= SVt_PVMG);
2462         /* This falls through to the report_uninit near the end of the
2463            function. */
2464     } else if (SvTHINKFIRST(sv)) {
2465         if (SvROK(sv)) {
2466         return_rok:
2467             if (SvAMAGIC(sv)) {
2468                 SV *tmpstr;
2469                 if (flags & SV_SKIP_OVERLOAD)
2470                     return 0;
2471                 tmpstr = AMG_CALLunary(sv, numer_amg);
2472                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2473                     return SvNV(tmpstr);
2474                 }
2475             }
2476             return PTR2NV(SvRV(sv));
2477         }
2478         if (SvIsCOW(sv)) {
2479             sv_force_normal_flags(sv, 0);
2480         }
2481         if (SvREADONLY(sv) && !SvOK(sv)) {
2482             if (ckWARN(WARN_UNINITIALIZED))
2483                 report_uninit(sv);
2484             return 0.0;
2485         }
2486     }
2487     if (SvTYPE(sv) < SVt_NV) {
2488         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2489         sv_upgrade(sv, SVt_NV);
2490 #ifdef USE_LONG_DOUBLE
2491         DEBUG_c({
2492             STORE_NUMERIC_LOCAL_SET_STANDARD();
2493             PerlIO_printf(Perl_debug_log,
2494                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2495                           PTR2UV(sv), SvNVX(sv));
2496             RESTORE_NUMERIC_LOCAL();
2497         });
2498 #else
2499         DEBUG_c({
2500             STORE_NUMERIC_LOCAL_SET_STANDARD();
2501             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2502                           PTR2UV(sv), SvNVX(sv));
2503             RESTORE_NUMERIC_LOCAL();
2504         });
2505 #endif
2506     }
2507     else if (SvTYPE(sv) < SVt_PVNV)
2508         sv_upgrade(sv, SVt_PVNV);
2509     if (SvNOKp(sv)) {
2510         return SvNVX(sv);
2511     }
2512     if (SvIOKp(sv)) {
2513         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2514 #ifdef NV_PRESERVES_UV
2515         if (SvIOK(sv))
2516             SvNOK_on(sv);
2517         else
2518             SvNOKp_on(sv);
2519 #else
2520         /* Only set the public NV OK flag if this NV preserves the IV  */
2521         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2522         if (SvIOK(sv) &&
2523             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2524                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2525             SvNOK_on(sv);
2526         else
2527             SvNOKp_on(sv);
2528 #endif
2529     }
2530     else if (SvPOKp(sv) && SvLEN(sv)) {
2531         UV value;
2532         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2533         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2534             not_a_number(sv);
2535 #ifdef NV_PRESERVES_UV
2536         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2537             == IS_NUMBER_IN_UV) {
2538             /* It's definitely an integer */
2539             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2540         } else
2541             SvNV_set(sv, Atof(SvPVX_const(sv)));
2542         if (numtype)
2543             SvNOK_on(sv);
2544         else
2545             SvNOKp_on(sv);
2546 #else
2547         SvNV_set(sv, Atof(SvPVX_const(sv)));
2548         /* Only set the public NV OK flag if this NV preserves the value in
2549            the PV at least as well as an IV/UV would.
2550            Not sure how to do this 100% reliably. */
2551         /* if that shift count is out of range then Configure's test is
2552            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2553            UV_BITS */
2554         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2555             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2556             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2557         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2558             /* Can't use strtol etc to convert this string, so don't try.
2559                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2560             SvNOK_on(sv);
2561         } else {
2562             /* value has been set.  It may not be precise.  */
2563             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2564                 /* 2s complement assumption for (UV)IV_MIN  */
2565                 SvNOK_on(sv); /* Integer is too negative.  */
2566             } else {
2567                 SvNOKp_on(sv);
2568                 SvIOKp_on(sv);
2569
2570                 if (numtype & IS_NUMBER_NEG) {
2571                     SvIV_set(sv, -(IV)value);
2572                 } else if (value <= (UV)IV_MAX) {
2573                     SvIV_set(sv, (IV)value);
2574                 } else {
2575                     SvUV_set(sv, value);
2576                     SvIsUV_on(sv);
2577                 }
2578
2579                 if (numtype & IS_NUMBER_NOT_INT) {
2580                     /* I believe that even if the original PV had decimals,
2581                        they are lost beyond the limit of the FP precision.
2582                        However, neither is canonical, so both only get p
2583                        flags.  NWC, 2000/11/25 */
2584                     /* Both already have p flags, so do nothing */
2585                 } else {
2586                     const NV nv = SvNVX(sv);
2587                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2588                         if (SvIVX(sv) == I_V(nv)) {
2589                             SvNOK_on(sv);
2590                         } else {
2591                             /* It had no "." so it must be integer.  */
2592                         }
2593                         SvIOK_on(sv);
2594                     } else {
2595                         /* between IV_MAX and NV(UV_MAX).
2596                            Could be slightly > UV_MAX */
2597
2598                         if (numtype & IS_NUMBER_NOT_INT) {
2599                             /* UV and NV both imprecise.  */
2600                         } else {
2601                             const UV nv_as_uv = U_V(nv);
2602
2603                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2604                                 SvNOK_on(sv);
2605                             }
2606                             SvIOK_on(sv);
2607                         }
2608                     }
2609                 }
2610             }
2611         }
2612         /* It might be more code efficient to go through the entire logic above
2613            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2614            gets complex and potentially buggy, so more programmer efficient
2615            to do it this way, by turning off the public flags:  */
2616         if (!numtype)
2617             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2618 #endif /* NV_PRESERVES_UV */
2619     }
2620     else  {
2621         if (isGV_with_GP(sv)) {
2622             glob_2number(MUTABLE_GV(sv));
2623             return 0.0;
2624         }
2625
2626         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2627             report_uninit(sv);
2628         assert (SvTYPE(sv) >= SVt_NV);
2629         /* Typically the caller expects that sv_any is not NULL now.  */
2630         /* XXX Ilya implies that this is a bug in callers that assume this
2631            and ideally should be fixed.  */
2632         return 0.0;
2633     }
2634 #if defined(USE_LONG_DOUBLE)
2635     DEBUG_c({
2636         STORE_NUMERIC_LOCAL_SET_STANDARD();
2637         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2638                       PTR2UV(sv), SvNVX(sv));
2639         RESTORE_NUMERIC_LOCAL();
2640     });
2641 #else
2642     DEBUG_c({
2643         STORE_NUMERIC_LOCAL_SET_STANDARD();
2644         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2645                       PTR2UV(sv), SvNVX(sv));
2646         RESTORE_NUMERIC_LOCAL();
2647     });
2648 #endif
2649     return SvNVX(sv);
2650 }
2651
2652 /*
2653 =for apidoc sv_2num
2654
2655 Return an SV with the numeric value of the source SV, doing any necessary
2656 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2657 access this function.
2658
2659 =cut
2660 */
2661
2662 SV *
2663 Perl_sv_2num(pTHX_ register SV *const sv)
2664 {
2665     PERL_ARGS_ASSERT_SV_2NUM;
2666
2667     if (!SvROK(sv))
2668         return sv;
2669     if (SvAMAGIC(sv)) {
2670         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2671         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2672         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2673             return sv_2num(tmpsv);
2674     }
2675     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2676 }
2677
2678 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2679  * UV as a string towards the end of buf, and return pointers to start and
2680  * end of it.
2681  *
2682  * We assume that buf is at least TYPE_CHARS(UV) long.
2683  */
2684
2685 static char *
2686 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2687 {
2688     char *ptr = buf + TYPE_CHARS(UV);
2689     char * const ebuf = ptr;
2690     int sign;
2691
2692     PERL_ARGS_ASSERT_UIV_2BUF;
2693
2694     if (is_uv)
2695         sign = 0;
2696     else if (iv >= 0) {
2697         uv = iv;
2698         sign = 0;
2699     } else {
2700         uv = -iv;
2701         sign = 1;
2702     }
2703     do {
2704         *--ptr = '0' + (char)(uv % 10);
2705     } while (uv /= 10);
2706     if (sign)
2707         *--ptr = '-';
2708     *peob = ebuf;
2709     return ptr;
2710 }
2711
2712 /*
2713 =for apidoc sv_2pv_flags
2714
2715 Returns a pointer to the string value of an SV, and sets *lp to its length.
2716 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2717 if necessary.
2718 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2719 usually end up here too.
2720
2721 =cut
2722 */
2723
2724 char *
2725 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2726 {
2727     dVAR;
2728     register char *s;
2729
2730     if (!sv) {
2731         if (lp)
2732             *lp = 0;
2733         return (char *)"";
2734     }
2735     if (SvGMAGICAL(sv)) {
2736         if (flags & SV_GMAGIC)
2737             mg_get(sv);
2738         if (SvPOKp(sv)) {
2739             if (lp)
2740                 *lp = SvCUR(sv);
2741             if (flags & SV_MUTABLE_RETURN)
2742                 return SvPVX_mutable(sv);
2743             if (flags & SV_CONST_RETURN)
2744                 return (char *)SvPVX_const(sv);
2745             return SvPVX(sv);
2746         }
2747         if (SvIOKp(sv) || SvNOKp(sv)) {
2748             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2749             STRLEN len;
2750
2751             if (SvIOKp(sv)) {
2752                 len = SvIsUV(sv)
2753                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2754                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2755             } else if(SvNVX(sv) == 0.0) {
2756                     tbuf[0] = '0';
2757                     tbuf[1] = 0;
2758                     len = 1;
2759             } else {
2760                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2761                 len = strlen(tbuf);
2762             }
2763             assert(!SvROK(sv));
2764             {
2765                 dVAR;
2766
2767                 SvUPGRADE(sv, SVt_PV);
2768                 if (lp)
2769                     *lp = len;
2770                 s = SvGROW_mutable(sv, len + 1);
2771                 SvCUR_set(sv, len);
2772                 SvPOKp_on(sv);
2773                 return (char*)memcpy(s, tbuf, len + 1);
2774             }
2775         }
2776         if (SvROK(sv)) {
2777             goto return_rok;
2778         }
2779         assert(SvTYPE(sv) >= SVt_PVMG);
2780         /* This falls through to the report_uninit near the end of the
2781            function. */
2782     } else if (SvTHINKFIRST(sv)) {
2783         if (SvROK(sv)) {
2784         return_rok:
2785             if (SvAMAGIC(sv)) {
2786                 SV *tmpstr;
2787                 if (flags & SV_SKIP_OVERLOAD)
2788                     return NULL;
2789                 tmpstr = AMG_CALLunary(sv, string_amg);
2790                 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2791                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2792                     /* Unwrap this:  */
2793                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2794                      */
2795
2796                     char *pv;
2797                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2798                         if (flags & SV_CONST_RETURN) {
2799                             pv = (char *) SvPVX_const(tmpstr);
2800                         } else {
2801                             pv = (flags & SV_MUTABLE_RETURN)
2802                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2803                         }
2804                         if (lp)
2805                             *lp = SvCUR(tmpstr);
2806                     } else {
2807                         pv = sv_2pv_flags(tmpstr, lp, flags);
2808                     }
2809                     if (SvUTF8(tmpstr))
2810                         SvUTF8_on(sv);
2811                     else
2812                         SvUTF8_off(sv);
2813                     return pv;
2814                 }
2815             }
2816             {
2817                 STRLEN len;
2818                 char *retval;
2819                 char *buffer;
2820                 SV *const referent = SvRV(sv);
2821
2822                 if (!referent) {
2823                     len = 7;
2824                     retval = buffer = savepvn("NULLREF", len);
2825                 } else if (SvTYPE(referent) == SVt_REGEXP) {
2826                     REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2827                     I32 seen_evals = 0;
2828
2829                     assert(re);
2830
2831                     /* If the regex is UTF-8 we want the containing scalar to
2832                        have an UTF-8 flag too */
2833                     if (RX_UTF8(re))
2834                         SvUTF8_on(sv);
2835                     else
2836                         SvUTF8_off(sv);
2837
2838                     if ((seen_evals = RX_SEEN_EVALS(re)))
2839                         PL_reginterp_cnt += seen_evals;
2840
2841                     if (lp)
2842                         *lp = RX_WRAPLEN(re);
2843
2844                     return RX_WRAPPED(re);
2845                 } else {
2846                     const char *const typestr = sv_reftype(referent, 0);
2847                     const STRLEN typelen = strlen(typestr);
2848                     UV addr = PTR2UV(referent);
2849                     const char *stashname = NULL;
2850                     STRLEN stashnamelen = 0; /* hush, gcc */
2851                     const char *buffer_end;
2852
2853                     if (SvOBJECT(referent)) {
2854                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2855
2856                         if (name) {
2857                             stashname = HEK_KEY(name);
2858                             stashnamelen = HEK_LEN(name);
2859
2860                             if (HEK_UTF8(name)) {
2861                                 SvUTF8_on(sv);
2862                             } else {
2863                                 SvUTF8_off(sv);
2864                             }
2865                         } else {
2866                             stashname = "__ANON__";
2867                             stashnamelen = 8;
2868                         }
2869                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2870                             + 2 * sizeof(UV) + 2 /* )\0 */;
2871                     } else {
2872                         len = typelen + 3 /* (0x */
2873                             + 2 * sizeof(UV) + 2 /* )\0 */;
2874                     }
2875
2876                     Newx(buffer, len, char);
2877                     buffer_end = retval = buffer + len;
2878
2879                     /* Working backwards  */
2880                     *--retval = '\0';
2881                     *--retval = ')';
2882                     do {
2883                         *--retval = PL_hexdigit[addr & 15];
2884                     } while (addr >>= 4);
2885                     *--retval = 'x';
2886                     *--retval = '0';
2887                     *--retval = '(';
2888
2889                     retval -= typelen;
2890                     memcpy(retval, typestr, typelen);
2891
2892                     if (stashname) {
2893                         *--retval = '=';
2894                         retval -= stashnamelen;
2895                         memcpy(retval, stashname, stashnamelen);
2896                     }
2897                     /* retval may not necessarily have reached the start of the
2898                        buffer here.  */
2899                     assert (retval >= buffer);
2900
2901                     len = buffer_end - retval - 1; /* -1 for that \0  */
2902                 }
2903                 if (lp)
2904                     *lp = len;
2905                 SAVEFREEPV(buffer);
2906                 return retval;
2907             }
2908         }
2909         if (SvREADONLY(sv) && !SvOK(sv)) {
2910             if (lp)
2911                 *lp = 0;
2912             if (flags & SV_UNDEF_RETURNS_NULL)
2913                 return NULL;
2914             if (ckWARN(WARN_UNINITIALIZED))
2915                 report_uninit(sv);
2916             return (char *)"";
2917         }
2918     }
2919     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2920         /* I'm assuming that if both IV and NV are equally valid then
2921            converting the IV is going to be more efficient */
2922         const U32 isUIOK = SvIsUV(sv);
2923         char buf[TYPE_CHARS(UV)];
2924         char *ebuf, *ptr;
2925         STRLEN len;
2926
2927         if (SvTYPE(sv) < SVt_PVIV)
2928             sv_upgrade(sv, SVt_PVIV);
2929         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2930         len = ebuf - ptr;
2931         /* inlined from sv_setpvn */
2932         s = SvGROW_mutable(sv, len + 1);
2933         Move(ptr, s, len, char);
2934         s += len;
2935         *s = '\0';
2936     }
2937     else if (SvNOKp(sv)) {
2938         if (SvTYPE(sv) < SVt_PVNV)
2939             sv_upgrade(sv, SVt_PVNV);
2940         if (SvNVX(sv) == 0.0) {
2941             s = SvGROW_mutable(sv, 2);
2942             *s++ = '0';
2943             *s = '\0';
2944         } else {
2945             dSAVE_ERRNO;
2946             /* The +20 is pure guesswork.  Configure test needed. --jhi */
2947             s = SvGROW_mutable(sv, NV_DIG + 20);
2948             /* some Xenix systems wipe out errno here */
2949             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2950             RESTORE_ERRNO;
2951             while (*s) s++;
2952         }
2953 #ifdef hcx
2954         if (s[-1] == '.')
2955             *--s = '\0';
2956 #endif
2957     }
2958     else {
2959         if (isGV_with_GP(sv)) {
2960             GV *const gv = MUTABLE_GV(sv);
2961             const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2962             SV *const buffer = sv_newmortal();
2963
2964             /* FAKE globs can get coerced, so need to turn this off temporarily
2965                if it is on.  */
2966             SvFAKE_off(gv);
2967             gv_efullname3(buffer, gv, "*");
2968             SvFLAGS(gv) |= wasfake;
2969
2970             if (SvPOK(buffer)) {
2971                 if (lp) {
2972                     *lp = SvCUR(buffer);
2973                 }
2974                 return SvPVX(buffer);
2975             }
2976             else {
2977                 if (lp)
2978                     *lp = 0;
2979                 return (char *)"";
2980             }
2981         }
2982
2983         if (lp)
2984             *lp = 0;
2985         if (flags & SV_UNDEF_RETURNS_NULL)
2986             return NULL;
2987         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2988             report_uninit(sv);
2989         if (SvTYPE(sv) < SVt_PV)
2990             /* Typically the caller expects that sv_any is not NULL now.  */
2991             sv_upgrade(sv, SVt_PV);
2992         return (char *)"";
2993     }
2994     {
2995         const STRLEN len = s - SvPVX_const(sv);
2996         if (lp)
2997             *lp = len;
2998         SvCUR_set(sv, len);
2999     }
3000     SvPOK_on(sv);
3001     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3002                           PTR2UV(sv),SvPVX_const(sv)));
3003     if (flags & SV_CONST_RETURN)
3004         return (char *)SvPVX_const(sv);
3005     if (flags & SV_MUTABLE_RETURN)
3006         return SvPVX_mutable(sv);
3007     return SvPVX(sv);
3008 }
3009
3010 /*
3011 =for apidoc sv_copypv
3012
3013 Copies a stringified representation of the source SV into the
3014 destination SV.  Automatically performs any necessary mg_get and
3015 coercion of numeric values into strings.  Guaranteed to preserve
3016 UTF8 flag even from overloaded objects.  Similar in nature to
3017 sv_2pv[_flags] but operates directly on an SV instead of just the
3018 string.  Mostly uses sv_2pv_flags to do its work, except when that
3019 would lose the UTF-8'ness of the PV.
3020
3021 =cut
3022 */
3023
3024 void
3025 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3026 {
3027     STRLEN len;
3028     const char * const s = SvPV_const(ssv,len);
3029
3030     PERL_ARGS_ASSERT_SV_COPYPV;
3031
3032     sv_setpvn(dsv,s,len);
3033     if (SvUTF8(ssv))
3034         SvUTF8_on(dsv);
3035     else
3036         SvUTF8_off(dsv);
3037 }
3038
3039 /*
3040 =for apidoc sv_2pvbyte
3041
3042 Return a pointer to the byte-encoded representation of the SV, and set *lp
3043 to its length.  May cause the SV to be downgraded from UTF-8 as a
3044 side-effect.
3045
3046 Usually accessed via the C<SvPVbyte> macro.
3047
3048 =cut
3049 */
3050
3051 char *
3052 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3053 {
3054     PERL_ARGS_ASSERT_SV_2PVBYTE;
3055
3056     SvGETMAGIC(sv);
3057     sv_utf8_downgrade(sv,0);
3058     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3059 }
3060
3061 /*
3062 =for apidoc sv_2pvutf8
3063
3064 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3065 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3066
3067 Usually accessed via the C<SvPVutf8> macro.
3068
3069 =cut
3070 */
3071
3072 char *
3073 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3074 {
3075     PERL_ARGS_ASSERT_SV_2PVUTF8;
3076
3077     sv_utf8_upgrade(sv);
3078     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3079 }
3080
3081
3082 /*
3083 =for apidoc sv_2bool
3084
3085 This macro is only used by sv_true() or its macro equivalent, and only if
3086 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3087 It calls sv_2bool_flags with the SV_GMAGIC flag.
3088
3089 =for apidoc sv_2bool_flags
3090
3091 This function is only used by sv_true() and friends,  and only if
3092 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3093 contain SV_GMAGIC, then it does an mg_get() first.
3094
3095
3096 =cut
3097 */
3098
3099 bool
3100 Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
3101 {
3102     dVAR;
3103
3104     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3105
3106     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3107
3108     if (!SvOK(sv))
3109         return 0;
3110     if (SvROK(sv)) {
3111         if (SvAMAGIC(sv)) {
3112             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3113             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3114                 return cBOOL(SvTRUE(tmpsv));
3115         }
3116         return SvRV(sv) != 0;
3117     }
3118     if (SvPOKp(sv)) {
3119         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3120         if (Xpvtmp &&
3121                 (*sv->sv_u.svu_pv > '0' ||
3122                 Xpvtmp->xpv_cur > 1 ||
3123                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3124             return 1;
3125         else
3126             return 0;
3127     }
3128     else {
3129         if (SvIOKp(sv))
3130             return SvIVX(sv) != 0;
3131         else {
3132             if (SvNOKp(sv))
3133                 return SvNVX(sv) != 0.0;
3134             else {
3135                 if (isGV_with_GP(sv))
3136                     return TRUE;
3137                 else
3138                     return FALSE;
3139             }
3140         }
3141     }
3142 }
3143
3144 /*
3145 =for apidoc sv_utf8_upgrade
3146
3147 Converts the PV of an SV to its UTF-8-encoded form.
3148 Forces the SV to string form if it is not already.
3149 Will C<mg_get> on C<sv> if appropriate.
3150 Always sets the SvUTF8 flag to avoid future validity checks even
3151 if the whole string is the same in UTF-8 as not.
3152 Returns the number of bytes in the converted string
3153
3154 This is not as a general purpose byte encoding to Unicode interface:
3155 use the Encode extension for that.
3156
3157 =for apidoc sv_utf8_upgrade_nomg
3158
3159 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3160
3161 =for apidoc sv_utf8_upgrade_flags
3162
3163 Converts the PV of an SV to its UTF-8-encoded form.
3164 Forces the SV to string form if it is not already.
3165 Always sets the SvUTF8 flag to avoid future validity checks even
3166 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3167 will C<mg_get> on C<sv> if appropriate, else not.
3168 Returns the number of bytes in the converted string
3169 C<sv_utf8_upgrade> and
3170 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3171
3172 This is not as a general purpose byte encoding to Unicode interface:
3173 use the Encode extension for that.
3174
3175 =cut
3176
3177 The grow version is currently not externally documented.  It adds a parameter,
3178 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3179 have free after it upon return.  This allows the caller to reserve extra space
3180 that it intends to fill, to avoid extra grows.
3181
3182 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3183 which can be used to tell this function to not first check to see if there are
3184 any characters that are different in UTF-8 (variant characters) which would
3185 force it to allocate a new string to sv, but to assume there are.  Typically
3186 this flag is used by a routine that has already parsed the string to find that
3187 there are such characters, and passes this information on so that the work
3188 doesn't have to be repeated.
3189
3190 (One might think that the calling routine could pass in the position of the
3191 first such variant, so it wouldn't have to be found again.  But that is not the
3192 case, because typically when the caller is likely to use this flag, it won't be
3193 calling this routine unless it finds something that won't fit into a byte.
3194 Otherwise it tries to not upgrade and just use bytes.  But some things that
3195 do fit into a byte are variants in utf8, and the caller may not have been
3196 keeping track of these.)
3197
3198 If the routine itself changes the string, it adds a trailing NUL.  Such a NUL
3199 isn't guaranteed due to having other routines do the work in some input cases,
3200 or if the input is already flagged as being in utf8.
3201
3202 The speed of this could perhaps be improved for many cases if someone wanted to
3203 write a fast function that counts the number of variant characters in a string,
3204 especially if it could return the position of the first one.
3205
3206 */
3207
3208 STRLEN
3209 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3210 {
3211     dVAR;
3212
3213     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3214
3215     if (sv == &PL_sv_undef)
3216         return 0;
3217     if (!SvPOK(sv)) {
3218         STRLEN len = 0;
3219         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3220             (void) sv_2pv_flags(sv,&len, flags);
3221             if (SvUTF8(sv)) {
3222                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3223                 return len;
3224             }
3225         } else {
3226             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3227         }
3228     }
3229
3230     if (SvUTF8(sv)) {
3231         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3232         return SvCUR(sv);
3233     }
3234
3235     if (SvIsCOW(sv)) {
3236         sv_force_normal_flags(sv, 0);
3237     }
3238
3239     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3240         sv_recode_to_utf8(sv, PL_encoding);
3241         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3242         return SvCUR(sv);
3243     }
3244
3245     if (SvCUR(sv) == 0) {
3246         if (extra) SvGROW(sv, extra);
3247     } else { /* Assume Latin-1/EBCDIC */
3248         /* This function could be much more efficient if we
3249          * had a FLAG in SVs to signal if there are any variant
3250          * chars in the PV.  Given that there isn't such a flag
3251          * make the loop as fast as possible (although there are certainly ways
3252          * to speed this up, eg. through vectorization) */
3253         U8 * s = (U8 *) SvPVX_const(sv);
3254         U8 * e = (U8 *) SvEND(sv);
3255         U8 *t = s;
3256         STRLEN two_byte_count = 0;
3257
3258         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3259
3260         /* See if really will need to convert to utf8.  We mustn't rely on our
3261          * incoming SV being well formed and having a trailing '\0', as certain
3262          * code in pp_formline can send us partially built SVs. */
3263
3264         while (t < e) {
3265             const U8 ch = *t++;
3266             if (NATIVE_IS_INVARIANT(ch)) continue;
3267
3268             t--;    /* t already incremented; re-point to first variant */
3269             two_byte_count = 1;
3270             goto must_be_utf8;
3271         }
3272
3273         /* utf8 conversion not needed because all are invariants.  Mark as
3274          * UTF-8 even if no variant - saves scanning loop */
3275         SvUTF8_on(sv);
3276         return SvCUR(sv);
3277
3278 must_be_utf8:
3279
3280         /* Here, the string should be converted to utf8, either because of an
3281          * input flag (two_byte_count = 0), or because a character that
3282          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3283          * the beginning of the string (if we didn't examine anything), or to
3284          * the first variant.  In either case, everything from s to t - 1 will
3285          * occupy only 1 byte each on output.
3286          *
3287          * There are two main ways to convert.  One is to create a new string
3288          * and go through the input starting from the beginning, appending each
3289          * converted value onto the new string as we go along.  It's probably
3290          * best to allocate enough space in the string for the worst possible
3291          * case rather than possibly running out of space and having to
3292          * reallocate and then copy what we've done so far.  Since everything
3293          * from s to t - 1 is invariant, the destination can be initialized
3294          * with these using a fast memory copy
3295          *
3296          * The other way is to figure out exactly how big the string should be
3297          * by parsing the entire input.  Then you don't have to make it big
3298          * enough to handle the worst possible case, and more importantly, if
3299          * the string you already have is large enough, you don't have to
3300          * allocate a new string, you can copy the last character in the input
3301          * string to the final position(s) that will be occupied by the
3302          * converted string and go backwards, stopping at t, since everything
3303          * before that is invariant.
3304          *
3305          * There are advantages and disadvantages to each method.
3306          *
3307          * In the first method, we can allocate a new string, do the memory
3308          * copy from the s to t - 1, and then proceed through the rest of the
3309          * string byte-by-byte.
3310          *
3311          * In the second method, we proceed through the rest of the input
3312          * string just calculating how big the converted string will be.  Then
3313          * there are two cases:
3314          *  1)  if the string has enough extra space to handle the converted
3315          *      value.  We go backwards through the string, converting until we
3316          *      get to the position we are at now, and then stop.  If this
3317          *      position is far enough along in the string, this method is
3318          *      faster than the other method.  If the memory copy were the same
3319          *      speed as the byte-by-byte loop, that position would be about
3320          *      half-way, as at the half-way mark, parsing to the end and back
3321          *      is one complete string's parse, the same amount as starting
3322          *      over and going all the way through.  Actually, it would be
3323          *      somewhat less than half-way, as it's faster to just count bytes
3324          *      than to also copy, and we don't have the overhead of allocating
3325          *      a new string, changing the scalar to use it, and freeing the
3326          *      existing one.  But if the memory copy is fast, the break-even
3327          *      point is somewhere after half way.  The counting loop could be
3328          *      sped up by vectorization, etc, to move the break-even point
3329          *      further towards the beginning.
3330          *  2)  if the string doesn't have enough space to handle the converted
3331          *      value.  A new string will have to be allocated, and one might
3332          *      as well, given that, start from the beginning doing the first
3333          *      method.  We've spent extra time parsing the string and in
3334          *      exchange all we've gotten is that we know precisely how big to
3335          *      make the new one.  Perl is more optimized for time than space,
3336          *      so this case is a loser.
3337          * So what I've decided to do is not use the 2nd method unless it is
3338          * guaranteed that a new string won't have to be allocated, assuming
3339          * the worst case.  I also decided not to put any more conditions on it
3340          * than this, for now.  It seems likely that, since the worst case is
3341          * twice as big as the unknown portion of the string (plus 1), we won't
3342          * be guaranteed enough space, causing us to go to the first method,
3343          * unless the string is short, or the first variant character is near
3344          * the end of it.  In either of these cases, it seems best to use the
3345          * 2nd method.  The only circumstance I can think of where this would
3346          * be really slower is if the string had once had much more data in it
3347          * than it does now, but there is still a substantial amount in it  */
3348
3349         {
3350             STRLEN invariant_head = t - s;
3351             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3352             if (SvLEN(sv) < size) {
3353
3354                 /* Here, have decided to allocate a new string */
3355
3356                 U8 *dst;
3357                 U8 *d;
3358
3359                 Newx(dst, size, U8);
3360
3361                 /* If no known invariants at the beginning of the input string,
3362                  * set so starts from there.  Otherwise, can use memory copy to
3363                  * get up to where we are now, and then start from here */
3364
3365                 if (invariant_head <= 0) {
3366                     d = dst;
3367                 } else {
3368                     Copy(s, dst, invariant_head, char);
3369                     d = dst + invariant_head;
3370                 }
3371
3372                 while (t < e) {
3373                     const UV uv = NATIVE8_TO_UNI(*t++);
3374                     if (UNI_IS_INVARIANT(uv))
3375                         *d++ = (U8)UNI_TO_NATIVE(uv);
3376                     else {
3377                         *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3378                         *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3379                     }
3380                 }
3381                 *d = '\0';
3382                 SvPV_free(sv); /* No longer using pre-existing string */
3383                 SvPV_set(sv, (char*)dst);
3384                 SvCUR_set(sv, d - dst);
3385                 SvLEN_set(sv, size);
3386             } else {
3387
3388                 /* Here, have decided to get the exact size of the string.
3389                  * Currently this happens only when we know that there is
3390                  * guaranteed enough space to fit the converted string, so
3391                  * don't have to worry about growing.  If two_byte_count is 0,
3392                  * then t points to the first byte of the string which hasn't
3393                  * been examined yet.  Otherwise two_byte_count is 1, and t
3394                  * points to the first byte in the string that will expand to
3395                  * two.  Depending on this, start examining at t or 1 after t.
3396                  * */
3397
3398                 U8 *d = t + two_byte_count;
3399
3400
3401                 /* Count up the remaining bytes that expand to two */
3402
3403                 while (d < e) {
3404                     const U8 chr = *d++;
3405                     if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3406                 }
3407
3408                 /* The string will expand by just the number of bytes that
3409                  * occupy two positions.  But we are one afterwards because of
3410                  * the increment just above.  This is the place to put the
3411                  * trailing NUL, and to set the length before we decrement */
3412
3413                 d += two_byte_count;
3414                 SvCUR_set(sv, d - s);
3415                 *d-- = '\0';
3416
3417
3418                 /* Having decremented d, it points to the position to put the
3419                  * very last byte of the expanded string.  Go backwards through
3420                  * the string, copying and expanding as we go, stopping when we
3421                  * get to the part that is invariant the rest of the way down */
3422
3423                 e--;
3424                 while (e >= t) {
3425                     const U8 ch = NATIVE8_TO_UNI(*e--);
3426                     if (UNI_IS_INVARIANT(ch)) {
3427                         *d-- = UNI_TO_NATIVE(ch);
3428                     } else {
3429                         *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3430                         *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3431                     }
3432                 }
3433             }
3434
3435             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3436                 /* Update pos. We do it at the end rather than during
3437                  * the upgrade, to avoid slowing down the common case
3438                  * (upgrade without pos) */
3439                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3440                 if (mg) {
3441                     I32 pos = mg->mg_len;
3442                     if (pos > 0 && (U32)pos > invariant_head) {
3443                         U8 *d = (U8*) SvPVX(sv) + invariant_head;
3444                         STRLEN n = (U32)pos - invariant_head;
3445                         while (n > 0) {
3446                             if (UTF8_IS_START(*d))
3447                                 d++;
3448                             d++;
3449                             n--;
3450                         }
3451                         mg->mg_len  = d - (U8*)SvPVX(sv);
3452                     }
3453                 }
3454                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3455                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3456             }
3457         }
3458     }
3459
3460     /* Mark as UTF-8 even if no variant - saves scanning loop */
3461     SvUTF8_on(sv);
3462     return SvCUR(sv);
3463 }
3464
3465 /*
3466 =for apidoc sv_utf8_downgrade
3467
3468 Attempts to convert the PV of an SV from characters to bytes.
3469 If the PV contains a character that cannot fit
3470 in a byte, this conversion will fail;
3471 in this case, either returns false or, if C<fail_ok> is not
3472 true, croaks.
3473
3474 This is not as a general purpose Unicode to byte encoding interface:
3475 use the Encode extension for that.
3476
3477 =cut
3478 */
3479
3480 bool
3481 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3482 {
3483     dVAR;
3484
3485     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3486
3487     if (SvPOKp(sv) && SvUTF8(sv)) {
3488         if (SvCUR(sv)) {
3489             U8 *s;
3490             STRLEN len;
3491             int mg_flags = SV_GMAGIC;
3492
3493             if (SvIsCOW(sv)) {
3494                 sv_force_normal_flags(sv, 0);
3495             }
3496             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3497                 /* update pos */
3498                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3499                 if (mg) {
3500                     I32 pos = mg->mg_len;
3501                     if (pos > 0) {
3502                         sv_pos_b2u(sv, &pos);
3503                         mg_flags = 0; /* sv_pos_b2u does get magic */
3504                         mg->mg_len  = pos;
3505                     }
3506                 }
3507                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3508                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3509
3510             }
3511             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3512
3513             if (!utf8_to_bytes(s, &len)) {
3514                 if (fail_ok)
3515                     return FALSE;
3516                 else {
3517                     if (PL_op)
3518                         Perl_croak(aTHX_ "Wide character in %s",
3519                                    OP_DESC(PL_op));
3520                     else
3521                         Perl_croak(aTHX_ "Wide character");
3522                 }
3523             }
3524             SvCUR_set(sv, len);
3525         }
3526     }
3527     SvUTF8_off(sv);
3528     return TRUE;
3529 }
3530
3531 /*
3532 =for apidoc sv_utf8_encode
3533
3534 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3535 flag off so that it looks like octets again.
3536
3537 =cut
3538 */
3539
3540 void
3541 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3542 {
3543     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3544
3545     if (SvIsCOW(sv)) {
3546         sv_force_normal_flags(sv, 0);
3547     }
3548     if (SvREADONLY(sv)) {
3549         Perl_croak_no_modify(aTHX);
3550     }
3551     (void) sv_utf8_upgrade(sv);
3552     SvUTF8_off(sv);
3553 }
3554
3555 /*
3556 =for apidoc sv_utf8_decode
3557
3558 If the PV of the SV is an octet sequence in UTF-8
3559 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3560 so that it looks like a character. If the PV contains only single-byte
3561 characters, the C<SvUTF8> flag stays off.
3562 Scans PV for validity and returns false if the PV is invalid UTF-8.
3563
3564 =cut
3565 */
3566
3567 bool
3568 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3569 {
3570     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3571
3572     if (SvPOKp(sv)) {
3573         const U8 *start, *c;
3574         const U8 *e;
3575
3576         /* The octets may have got themselves encoded - get them back as
3577          * bytes
3578          */
3579         if (!sv_utf8_downgrade(sv, TRUE))
3580             return FALSE;
3581
3582         /* it is actually just a matter of turning the utf8 flag on, but
3583          * we want to make sure everything inside is valid utf8 first.
3584          */
3585         c = start = (const U8 *) SvPVX_const(sv);
3586         if (!is_utf8_string(c, SvCUR(sv)+1))
3587             return FALSE;
3588         e = (const U8 *) SvEND(sv);
3589         while (c < e) {
3590             const U8 ch = *c++;
3591             if (!UTF8_IS_INVARIANT(ch)) {
3592                 SvUTF8_on(sv);
3593                 break;
3594             }
3595         }
3596         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3597             /* adjust pos to the start of a UTF8 char sequence */
3598             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3599             if (mg) {
3600                 I32 pos = mg->mg_len;
3601                 if (pos > 0) {
3602                     for (c = start + pos; c > start; c--) {
3603                         if (UTF8_IS_START(*c))
3604                             break;
3605                     }
3606                     mg->mg_len  = c - start;
3607                 }
3608             }
3609             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3610                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3611         }
3612     }
3613     return TRUE;
3614 }
3615
3616 /*
3617 =for apidoc sv_setsv
3618
3619 Copies the contents of the source SV C<ssv> into the destination SV
3620 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3621 function if the source SV needs to be reused. Does not handle 'set' magic.
3622 Loosely speaking, it performs a copy-by-value, obliterating any previous
3623 content of the destination.
3624
3625 You probably want to use one of the assortment of wrappers, such as
3626 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3627 C<SvSetMagicSV_nosteal>.
3628
3629 =for apidoc sv_setsv_flags
3630
3631 Copies the contents of the source SV C<ssv> into the destination SV
3632 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3633 function if the source SV needs to be reused. Does not handle 'set' magic.
3634 Loosely speaking, it performs a copy-by-value, obliterating any previous
3635 content of the destination.
3636 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3637 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3638 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3639 and C<sv_setsv_nomg> are implemented in terms of this function.
3640
3641 You probably want to use one of the assortment of wrappers, such as
3642 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3643 C<SvSetMagicSV_nosteal>.
3644
3645 This is the primary function for copying scalars, and most other
3646 copy-ish functions and macros use this underneath.
3647
3648 =cut
3649 */
3650
3651 static void
3652 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3653 {
3654     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3655     HV *old_stash = NULL;
3656
3657     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3658
3659     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3660         const char * const name = GvNAME(sstr);
3661         const STRLEN len = GvNAMELEN(sstr);
3662         {
3663             if (dtype >= SVt_PV) {
3664                 SvPV_free(dstr);
3665                 SvPV_set(dstr, 0);
3666                 SvLEN_set(dstr, 0);
3667                 SvCUR_set(dstr, 0);
3668             }
3669             SvUPGRADE(dstr, SVt_PVGV);
3670             (void)SvOK_off(dstr);
3671             /* FIXME - why are we doing this, then turning it off and on again
3672                below?  */
3673             isGV_with_GP_on(dstr);
3674         }
3675         GvSTASH(dstr) = GvSTASH(sstr);
3676         if (GvSTASH(dstr))
3677             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3678         gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3679         SvFAKE_on(dstr);        /* can coerce to non-glob */
3680     }
3681
3682     if(GvGP(MUTABLE_GV(sstr))) {
3683         /* If source has method cache entry, clear it */
3684         if(GvCVGEN(sstr)) {
3685             SvREFCNT_dec(GvCV(sstr));
3686             GvCV_set(sstr, NULL);
3687             GvCVGEN(sstr) = 0;
3688         }
3689         /* If source has a real method, then a method is
3690            going to change */
3691         else if(
3692          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3693         ) {
3694             mro_changes = 1;
3695         }
3696     }
3697
3698     /* If dest already had a real method, that's a change as well */
3699     if(
3700         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3701      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3702     ) {
3703         mro_changes = 1;
3704     }
3705
3706     /* We don’t need to check the name of the destination if it was not a
3707        glob to begin with. */
3708     if(dtype == SVt_PVGV) {
3709         const char * const name = GvNAME((const GV *)dstr);
3710         if(
3711             strEQ(name,"ISA")
3712          /* The stash may have been detached from the symbol table, so
3713             check its name. */
3714          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3715          && GvAV((const GV *)sstr)
3716         )
3717             mro_changes = 2;
3718         else {
3719             const STRLEN len = GvNAMELEN(dstr);
3720             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3721              || (len == 1 && name[0] == ':')) {
3722                 mro_changes = 3;
3723
3724                 /* Set aside the old stash, so we can reset isa caches on
3725                    its subclasses. */
3726                 if((old_stash = GvHV(dstr)))
3727                     /* Make sure we do not lose it early. */
3728                     SvREFCNT_inc_simple_void_NN(
3729                      sv_2mortal((SV *)old_stash)
3730                     );
3731             }
3732         }
3733     }
3734
3735     gp_free(MUTABLE_GV(dstr));
3736     isGV_with_GP_off(dstr);
3737     (void)SvOK_off(dstr);
3738     isGV_with_GP_on(dstr);
3739     GvINTRO_off(dstr);          /* one-shot flag */
3740     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3741     if (SvTAINTED(sstr))
3742         SvTAINT(dstr);
3743     if (GvIMPORTED(dstr) != GVf_IMPORTED
3744         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3745         {
3746             GvIMPORTED_on(dstr);
3747         }
3748     GvMULTI_on(dstr);
3749     if(mro_changes == 2) {
3750         MAGIC *mg;
3751         SV * const sref = (SV *)GvAV((const GV *)dstr);
3752         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3753             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3754                 AV * const ary = newAV();
3755                 av_push(ary, mg->mg_obj); /* takes the refcount */
3756                 mg->mg_obj = (SV *)ary;
3757             }
3758             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3759         }
3760         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3761         mro_isa_changed_in(GvSTASH(dstr));
3762     }
3763     else if(mro_changes == 3) {
3764         HV * const stash = GvHV(dstr);
3765         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3766             mro_package_moved(
3767                 stash, old_stash,
3768                 (GV *)dstr, 0
3769             );
3770     }
3771     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3772     return;
3773 }
3774
3775 static void
3776 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3777 {
3778     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3779     SV *dref = NULL;
3780     const int intro = GvINTRO(dstr);
3781     SV **location;
3782     U8 import_flag = 0;
3783     const U32 stype = SvTYPE(sref);
3784
3785     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3786
3787     if (intro) {
3788         GvINTRO_off(dstr);      /* one-shot flag */
3789         GvLINE(dstr) = CopLINE(PL_curcop);
3790         GvEGV(dstr) = MUTABLE_GV(dstr);
3791     }
3792     GvMULTI_on(dstr);
3793     switch (stype) {
3794     case SVt_PVCV:
3795         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3796         import_flag = GVf_IMPORTED_CV;
3797         goto common;
3798     case SVt_PVHV:
3799         location = (SV **) &GvHV(dstr);
3800         import_flag = GVf_IMPORTED_HV;
3801         goto common;
3802     case SVt_PVAV:
3803         location = (SV **) &GvAV(dstr);
3804         import_flag = GVf_IMPORTED_AV;
3805         goto common;
3806     case SVt_PVIO:
3807         location = (SV **) &GvIOp(dstr);
3808         goto common;
3809     case SVt_PVFM:
3810         location = (SV **) &GvFORM(dstr);
3811         goto common;
3812     default:
3813         location = &GvSV(dstr);
3814         import_flag = GVf_IMPORTED_SV;
3815     common:
3816         if (intro) {
3817             if (stype == SVt_PVCV) {
3818                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3819                 if (GvCVGEN(dstr)) {
3820                     SvREFCNT_dec(GvCV(dstr));
3821                     GvCV_set(dstr, NULL);
3822                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3823                 }
3824             }
3825             SAVEGENERICSV(*location);
3826         }
3827         else
3828             dref = *location;
3829         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3830             CV* const cv = MUTABLE_CV(*location);
3831             if (cv) {
3832                 if (!GvCVGEN((const GV *)dstr) &&
3833                     (CvROOT(cv) || CvXSUB(cv)))
3834                     {
3835                         /* Redefining a sub - warning is mandatory if
3836                            it was a const and its value changed. */
3837                         if (CvCONST(cv) && CvCONST((const CV *)sref)
3838                             && cv_const_sv(cv)
3839                             == cv_const_sv((const CV *)sref)) {
3840                             NOOP;
3841                             /* They are 2 constant subroutines generated from
3842                                the same constant. This probably means that
3843                                they are really the "same" proxy subroutine
3844                                instantiated in 2 places. Most likely this is
3845                                when a constant is exported twice.  Don't warn.
3846                             */
3847                         }
3848                         else if (ckWARN(WARN_REDEFINE)
3849                                  || (CvCONST(cv)
3850                                      && (!CvCONST((const CV *)sref)
3851                                          || sv_cmp(cv_const_sv(cv),
3852                                                    cv_const_sv((const CV *)
3853                                                                sref))))) {
3854                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3855                                         (const char *)
3856                                         (CvCONST(cv)
3857                                          ? "Constant subroutine %s::%s redefined"
3858                                          : "Subroutine %s::%s redefined"),
3859                                         HvNAME_get(GvSTASH((const GV *)dstr)),
3860                                         GvENAME(MUTABLE_GV(dstr)));
3861                         }
3862                     }
3863                 if (!intro)
3864                     cv_ckproto_len(cv, (const GV *)dstr,
3865                                    SvPOK(sref) ? SvPVX_const(sref) : NULL,
3866                                    SvPOK(sref) ? SvCUR(sref) : 0);
3867             }
3868             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3869             GvASSUMECV_on(dstr);
3870             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3871         }
3872         *location = sref;
3873         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3874             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3875             GvFLAGS(dstr) |= import_flag;
3876         }
3877         if (stype == SVt_PVHV) {
3878             const char * const name = GvNAME((GV*)dstr);
3879             const STRLEN len = GvNAMELEN(dstr);
3880             if (
3881                 (
3882                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3883                 || (len == 1 && name[0] == ':')
3884                 )
3885              && (!dref || HvENAME_get(dref))
3886             ) {
3887                 mro_package_moved(
3888                     (HV *)sref, (HV *)dref,
3889                     (GV *)dstr, 0
3890                 );
3891             }
3892         }
3893         else if (
3894             stype == SVt_PVAV && sref != dref
3895          && strEQ(GvNAME((GV*)dstr), "ISA")
3896          /* The stash may have been detached from the symbol table, so
3897             check its name before doing anything. */
3898          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3899         ) {
3900             MAGIC *mg;
3901             MAGIC * const omg = dref && SvSMAGICAL(dref)
3902                                  ? mg_find(dref, PERL_MAGIC_isa)
3903                                  : NULL;
3904             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3905                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3906                     AV * const ary = newAV();
3907                     av_push(ary, mg->mg_obj); /* takes the refcount */
3908                     mg->mg_obj = (SV *)ary;
3909                 }
3910                 if (omg) {
3911                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3912                         SV **svp = AvARRAY((AV *)omg->mg_obj);
3913                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3914                         while (items--)
3915                             av_push(
3916                              (AV *)mg->mg_obj,
3917                              SvREFCNT_inc_simple_NN(*svp++)
3918                             );
3919                     }
3920                     else
3921                         av_push(
3922                          (AV *)mg->mg_obj,
3923                          SvREFCNT_inc_simple_NN(omg->mg_obj)
3924                         );
3925                 }
3926                 else
3927                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3928             }
3929             else
3930             {
3931                 sv_magic(
3932                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3933                 );
3934                 mg = mg_find(sref, PERL_MAGIC_isa);
3935             }
3936             /* Since the *ISA assignment could have affected more than
3937                one stash, don’t call mro_isa_changed_in directly, but let
3938                magic_clearisa do it for us, as it already has the logic for
3939                dealing with globs vs arrays of globs. */
3940             assert(mg);
3941             Perl_magic_clearisa(aTHX_ NULL, mg);
3942         }
3943         break;
3944     }
3945     SvREFCNT_dec(dref);
3946     if (SvTAINTED(sstr))
3947         SvTAINT(dstr);
3948     return;
3949 }
3950
3951 void
3952 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3953 {
3954     dVAR;
3955     register U32 sflags;
3956     register int dtype;
3957     register svtype stype;
3958
3959     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3960
3961     if (sstr == dstr)
3962         return;
3963
3964     if (SvIS_FREED(dstr)) {
3965         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3966                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3967     }
3968     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3969     if (!sstr)
3970         sstr = &PL_sv_undef;
3971     if (SvIS_FREED(sstr)) {
3972         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3973                    (void*)sstr, (void*)dstr);
3974     }
3975     stype = SvTYPE(sstr);
3976     dtype = SvTYPE(dstr);
3977
3978     (void)SvAMAGIC_off(dstr);
3979     if ( SvVOK(dstr) )
3980     {
3981         /* need to nuke the magic */
3982         mg_free(dstr);
3983     }
3984
3985     /* There's a lot of redundancy below but we're going for speed here */
3986
3987     switch (stype) {
3988     case SVt_NULL:
3989       undef_sstr:
3990         if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3991             (void)SvOK_off(dstr);
3992             return;
3993         }
3994         break;
3995     case SVt_IV:
3996         if (SvIOK(sstr)) {
3997             switch (dtype) {
3998             case SVt_NULL:
3999                 sv_upgrade(dstr, SVt_IV);
4000                 break;
4001             case SVt_NV:
4002             case SVt_PV:
4003                 sv_upgrade(dstr, SVt_PVIV);
4004                 break;
4005             case SVt_PVGV:
4006             case SVt_PVLV:
4007                 goto end_of_first_switch;
4008             }
4009             (void)SvIOK_only(dstr);
4010             SvIV_set(dstr,  SvIVX(sstr));
4011             if (SvIsUV(sstr))
4012                 SvIsUV_on(dstr);
4013             /* SvTAINTED can only be true if the SV has taint magic, which in
4014                turn means that the SV type is PVMG (or greater). This is the
4015                case statement for SVt_IV, so this cannot be true (whatever gcov
4016                may say).  */
4017             assert(!SvTAINTED(sstr));
4018             return;
4019         }
4020         if (!SvROK(sstr))
4021             goto undef_sstr;
4022         if (dtype < SVt_PV && dtype != SVt_IV)
4023             sv_upgrade(dstr, SVt_IV);
4024         break;
4025
4026     case SVt_NV:
4027         if (SvNOK(sstr)) {
4028             switch (dtype) {
4029             case SVt_NULL:
4030             case SVt_IV:
4031                 sv_upgrade(dstr, SVt_NV);
4032                 break;
4033             case SVt_PV:
4034             case SVt_PVIV:
4035                 sv_upgrade(dstr, SVt_PVNV);
4036                 break;
4037             case SVt_PVGV:
4038             case SVt_PVLV:
4039                 goto end_of_first_switch;
4040             }
4041             SvNV_set(dstr, SvNVX(sstr));
4042             (void)SvNOK_only(dstr);
4043             /* SvTAINTED can only be true if the SV has taint magic, which in
4044                turn means that the SV type is PVMG (or greater). This is the
4045                case statement for SVt_NV, so this cannot be true (whatever gcov
4046                may say).  */
4047             assert(!SvTAINTED(sstr));
4048             return;
4049         }
4050         goto undef_sstr;
4051
4052     case SVt_PVFM:
4053 #ifdef PERL_OLD_COPY_ON_WRITE
4054         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4055             if (dtype < SVt_PVIV)
4056                 sv_upgrade(dstr, SVt_PVIV);
4057             break;
4058         }
4059         /* Fall through */
4060 #endif
4061     case SVt_PV:
4062         if (dtype < SVt_PV)
4063             sv_upgrade(dstr, SVt_PV);
4064         break;
4065     case SVt_PVIV:
4066         if (dtype < SVt_PVIV)
4067             sv_upgrade(dstr, SVt_PVIV);
4068         break;
4069     case SVt_PVNV:
4070         if (dtype < SVt_PVNV)
4071             sv_upgrade(dstr, SVt_PVNV);
4072         break;
4073     default:
4074         {
4075         const char * const type = sv_reftype(sstr,0);
4076         if (PL_op)
4077             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4078         else
4079             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4080         }
4081         break;
4082
4083     case SVt_REGEXP:
4084         if (dtype < SVt_REGEXP)
4085             sv_upgrade(dstr, SVt_REGEXP);
4086         break;
4087
4088         /* case SVt_BIND: */
4089     case SVt_PVLV:
4090     case SVt_PVGV:
4091         /* SvVALID means that this PVGV is playing at being an FBM.  */
4092
4093     case SVt_PVMG:
4094         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4095             mg_get(sstr);
4096             if (SvTYPE(sstr) != stype)
4097                 stype = SvTYPE(sstr);
4098         }
4099         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4100                     glob_assign_glob(dstr, sstr, dtype);
4101                     return;
4102         }
4103         if (stype == SVt_PVLV)
4104             SvUPGRADE(dstr, SVt_PVNV);
4105         else
4106             SvUPGRADE(dstr, (svtype)stype);
4107     }
4108  end_of_first_switch:
4109
4110     /* dstr may have been upgraded.  */
4111     dtype = SvTYPE(dstr);
4112     sflags = SvFLAGS(sstr);
4113
4114     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
4115         /* Assigning to a subroutine sets the prototype.  */
4116         if (SvOK(sstr)) {
4117             STRLEN len;
4118             const char *const ptr = SvPV_const(sstr, len);
4119
4120             SvGROW(dstr, len + 1);
4121             Copy(ptr, SvPVX(dstr), len + 1, char);
4122             SvCUR_set(dstr, len);
4123             SvPOK_only(dstr);
4124             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4125         } else {
4126             SvOK_off(dstr);
4127         }
4128     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
4129         const char * const type = sv_reftype(dstr,0);
4130         if (PL_op)
4131             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4132         else
4133             Perl_croak(aTHX_ "Cannot copy to %s", type);
4134     } else if (sflags & SVf_ROK) {
4135         if (isGV_with_GP(dstr)
4136             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4137             sstr = SvRV(sstr);
4138             if (sstr == dstr) {
4139                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4140                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4141                 {
4142                     GvIMPORTED_on(dstr);
4143                 }
4144                 GvMULTI_on(dstr);
4145                 return;
4146             }
4147             glob_assign_glob(dstr, sstr, dtype);
4148             return;
4149         }
4150
4151         if (dtype >= SVt_PV) {
4152             if (isGV_with_GP(dstr)) {
4153                 glob_assign_ref(dstr, sstr);
4154                 return;
4155             }
4156             if (SvPVX_const(dstr)) {
4157                 SvPV_free(dstr);
4158                 SvLEN_set(dstr, 0);
4159                 SvCUR_set(dstr, 0);
4160             }
4161         }
4162         (void)SvOK_off(dstr);
4163         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4164         SvFLAGS(dstr) |= sflags & SVf_ROK;
4165         assert(!(sflags & SVp_NOK));
4166         assert(!(sflags & SVp_IOK));
4167         assert(!(sflags & SVf_NOK));
4168         assert(!(sflags & SVf_IOK));
4169     }
4170     else if (isGV_with_GP(dstr)) {
4171         if (!(sflags & SVf_OK)) {
4172             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4173                            "Undefined value assigned to typeglob");
4174         }
4175         else {
4176             GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4177             if (dstr != (const SV *)gv) {
4178                 const char * const name = GvNAME((const GV *)dstr);
4179                 const STRLEN len = GvNAMELEN(dstr);
4180                 HV *old_stash = NULL;
4181                 bool reset_isa = FALSE;
4182                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4183                  || (len == 1 && name[0] == ':')) {
4184                     /* Set aside the old stash, so we can reset isa caches
4185                        on its subclasses. */
4186                     if((old_stash = GvHV(dstr))) {
4187                         /* Make sure we do not lose it early. */
4188                         SvREFCNT_inc_simple_void_NN(
4189                          sv_2mortal((SV *)old_stash)
4190                         );
4191                     }
4192                     reset_isa = TRUE;
4193                 }
4194
4195                 if (GvGP(dstr))
4196                     gp_free(MUTABLE_GV(dstr));
4197                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4198
4199                 if (reset_isa) {
4200                     HV * const stash = GvHV(dstr);
4201                     if(
4202                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4203                     )
4204                         mro_package_moved(
4205                          stash, old_stash,
4206                          (GV *)dstr, 0
4207                         );
4208                 }
4209             }
4210         }
4211     }
4212     else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4213         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4214     }
4215     else if (sflags & SVp_POK) {
4216         bool isSwipe = 0;
4217
4218         /*
4219          * Check to see if we can just swipe the string.  If so, it's a
4220          * possible small lose on short strings, but a big win on long ones.
4221          * It might even be a win on short strings if SvPVX_const(dstr)
4222          * has to be allocated and SvPVX_const(sstr) has to be freed.
4223          * Likewise if we can set up COW rather than doing an actual copy, we
4224          * drop to the else clause, as the swipe code and the COW setup code
4225          * have much in common.
4226          */
4227
4228         /* Whichever path we take through the next code, we want this true,
4229            and doing it now facilitates the COW check.  */
4230         (void)SvPOK_only(dstr);
4231
4232         if (
4233             /* If we're already COW then this clause is not true, and if COW
4234                is allowed then we drop down to the else and make dest COW
4235                with us.  If caller hasn't said that we're allowed to COW
4236                shared hash keys then we don't do the COW setup, even if the
4237                source scalar is a shared hash key scalar.  */
4238             (((flags & SV_COW_SHARED_HASH_KEYS)
4239                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4240                : 1 /* If making a COW copy is forbidden then the behaviour we
4241                        desire is as if the source SV isn't actually already
4242                        COW, even if it is.  So we act as if the source flags
4243                        are not COW, rather than actually testing them.  */
4244               )
4245 #ifndef PERL_OLD_COPY_ON_WRITE
4246              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4247                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4248                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4249                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4250                 but in turn, it's somewhat dead code, never expected to go
4251                 live, but more kept as a placeholder on how to do it better
4252                 in a newer implementation.  */
4253              /* If we are COW and dstr is a suitable target then we drop down
4254                 into the else and make dest a COW of us.  */
4255              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4256 #endif
4257              )
4258             &&
4259             !(isSwipe =
4260                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4261                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4262                  (!(flags & SV_NOSTEAL)) &&
4263                                         /* and we're allowed to steal temps */
4264                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4265                  SvLEN(sstr))             /* and really is a string */
4266 #ifdef PERL_OLD_COPY_ON_WRITE
4267             && ((flags & SV_COW_SHARED_HASH_KEYS)
4268                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4269                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4270                      && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4271                 : 1)
4272 #endif
4273             ) {
4274             /* Failed the swipe test, and it's not a shared hash key either.
4275                Have to copy the string.  */
4276             STRLEN len = SvCUR(sstr);
4277             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4278             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4279             SvCUR_set(dstr, len);
4280             *SvEND(dstr) = '\0';
4281         } else {
4282             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4283                be true in here.  */
4284             /* Either it's a shared hash key, or it's suitable for
4285                copy-on-write or we can swipe the string.  */
4286             if (DEBUG_C_TEST) {
4287                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4288                 sv_dump(sstr);
4289                 sv_dump(dstr);
4290             }
4291 #ifdef PERL_OLD_COPY_ON_WRITE
4292             if (!isSwipe) {
4293                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4294                     != (SVf_FAKE | SVf_READONLY)) {
4295                     SvREADONLY_on(sstr);
4296                     SvFAKE_on(sstr);
4297                     /* Make the source SV into a loop of 1.
4298                        (about to become 2) */
4299                     SV_COW_NEXT_SV_SET(sstr, sstr);
4300                 }
4301             }
4302 #endif
4303             /* Initial code is common.  */
4304             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4305                 SvPV_free(dstr);
4306             }
4307
4308             if (!isSwipe) {
4309                 /* making another shared SV.  */
4310                 STRLEN cur = SvCUR(sstr);
4311                 STRLEN len = SvLEN(sstr);
4312 #ifdef PERL_OLD_COPY_ON_WRITE
4313                 if (len) {
4314                     assert (SvTYPE(dstr) >= SVt_PVIV);
4315                     /* SvIsCOW_normal */
4316                     /* splice us in between source and next-after-source.  */
4317                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4318                     SV_COW_NEXT_SV_SET(sstr, dstr);
4319                     SvPV_set(dstr, SvPVX_mutable(sstr));
4320                 } else
4321 #endif
4322                 {
4323                     /* SvIsCOW_shared_hash */
4324                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4325                                           "Copy on write: Sharing hash\n"));
4326
4327                     assert (SvTYPE(dstr) >= SVt_PV);
4328                     SvPV_set(dstr,
4329                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4330                 }
4331                 SvLEN_set(dstr, len);
4332                 SvCUR_set(dstr, cur);
4333                 SvREADONLY_on(dstr);
4334                 SvFAKE_on(dstr);
4335             }
4336             else
4337                 {       /* Passes the swipe test.  */
4338                 SvPV_set(dstr, SvPVX_mutable(sstr));
4339                 SvLEN_set(dstr, SvLEN(sstr));
4340                 SvCUR_set(dstr, SvCUR(sstr));
4341
4342                 SvTEMP_off(dstr);
4343                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4344                 SvPV_set(sstr, NULL);
4345                 SvLEN_set(sstr, 0);
4346                 SvCUR_set(sstr, 0);
4347                 SvTEMP_off(sstr);
4348             }
4349         }
4350         if (sflags & SVp_NOK) {
4351             SvNV_set(dstr, SvNVX(sstr));
4352         }
4353         if (sflags & SVp_IOK) {
4354             SvIV_set(dstr, SvIVX(sstr));
4355             /* Must do this otherwise some other overloaded use of 0x80000000
4356                gets confused. I guess SVpbm_VALID */
4357             if (sflags & SVf_IVisUV)
4358                 SvIsUV_on(dstr);
4359         }
4360         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4361         {
4362             const MAGIC * const smg = SvVSTRING_mg(sstr);
4363             if (smg) {
4364                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4365                          smg->mg_ptr, smg->mg_len);
4366                 SvRMAGICAL_on(dstr);
4367             }
4368         }
4369     }
4370     else if (sflags & (SVp_IOK|SVp_NOK)) {
4371         (void)SvOK_off(dstr);
4372         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4373         if (sflags & SVp_IOK) {
4374             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4375             SvIV_set(dstr, SvIVX(sstr));
4376         }
4377         if (sflags & SVp_NOK) {
4378             SvNV_set(dstr, SvNVX(sstr));
4379         }
4380     }
4381     else {
4382         if (isGV_with_GP(sstr)) {
4383             /* This stringification rule for globs is spread in 3 places.
4384                This feels bad. FIXME.  */
4385             const U32 wasfake = sflags & SVf_FAKE;
4386
4387             /* FAKE globs can get coerced, so need to turn this off
4388                temporarily if it is on.  */
4389             SvFAKE_off(sstr);
4390             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4391             SvFLAGS(sstr) |= wasfake;
4392         }
4393         else
4394             (void)SvOK_off(dstr);
4395     }
4396     if (SvTAINTED(sstr))
4397         SvTAINT(dstr);
4398 }
4399
4400 /*
4401 =for apidoc sv_setsv_mg
4402
4403 Like C<sv_setsv>, but also handles 'set' magic.
4404
4405 =cut
4406 */
4407
4408 void
4409 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4410 {
4411     PERL_ARGS_ASSERT_SV_SETSV_MG;
4412
4413     sv_setsv(dstr,sstr);
4414     SvSETMAGIC(dstr);
4415 }
4416
4417 #ifdef PERL_OLD_COPY_ON_WRITE
4418 SV *
4419 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4420 {
4421     STRLEN cur = SvCUR(sstr);
4422     STRLEN len = SvLEN(sstr);
4423     register char *new_pv;
4424
4425     PERL_ARGS_ASSERT_SV_SETSV_COW;
4426
4427     if (DEBUG_C_TEST) {
4428         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4429                       (void*)sstr, (void*)dstr);
4430         sv_dump(sstr);
4431         if (dstr)
4432                     sv_dump(dstr);
4433     }
4434
4435     if (dstr) {
4436         if (SvTHINKFIRST(dstr))
4437             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4438         else if (SvPVX_const(dstr))
4439             Safefree(SvPVX_const(dstr));
4440     }
4441     else
4442         new_SV(dstr);
4443     SvUPGRADE(dstr, SVt_PVIV);
4444
4445     assert (SvPOK(sstr));
4446     assert (SvPOKp(sstr));
4447     assert (!SvIOK(sstr));
4448     assert (!SvIOKp(sstr));
4449     assert (!SvNOK(sstr));
4450     assert (!SvNOKp(sstr));
4451
4452     if (SvIsCOW(sstr)) {
4453
4454         if (SvLEN(sstr) == 0) {
4455             /* source is a COW shared hash key.  */
4456             DEBUG_C(PerlIO_printf(Perl_debug_log,
4457                                   "Fast copy on write: Sharing hash\n"));
4458             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4459             goto common_exit;
4460         }
4461         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4462     } else {
4463         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4464         SvUPGRADE(sstr, SVt_PVIV);
4465         SvREADONLY_on(sstr);
4466         SvFAKE_on(sstr);
4467         DEBUG_C(PerlIO_printf(Perl_debug_log,
4468                               "Fast copy on write: Converting sstr to COW\n"));
4469         SV_COW_NEXT_SV_SET(dstr, sstr);
4470     }
4471     SV_COW_NEXT_SV_SET(sstr, dstr);
4472     new_pv = SvPVX_mutable(sstr);
4473
4474   common_exit:
4475     SvPV_set(dstr, new_pv);
4476     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4477     if (SvUTF8(sstr))
4478         SvUTF8_on(dstr);
4479     SvLEN_set(dstr, len);
4480     SvCUR_set(dstr, cur);
4481     if (DEBUG_C_TEST) {
4482         sv_dump(dstr);
4483     }
4484     return dstr;
4485 }
4486 #endif
4487
4488 /*
4489 =for apidoc sv_setpvn
4490
4491 Copies a string into an SV.  The C<len> parameter indicates the number of
4492 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4493 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4494
4495 =cut
4496 */
4497
4498 void
4499 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4500 {
4501     dVAR;
4502     register char *dptr;
4503
4504     PERL_ARGS_ASSERT_SV_SETPVN;
4505
4506     SV_CHECK_THINKFIRST_COW_DROP(sv);
4507     if (!ptr) {
4508         (void)SvOK_off(sv);
4509         return;
4510     }
4511     else {
4512         /* len is STRLEN which is unsigned, need to copy to signed */
4513         const IV iv = len;
4514         if (iv < 0)
4515             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4516     }
4517     SvUPGRADE(sv, SVt_PV);
4518
4519     dptr = SvGROW(sv, len + 1);
4520     Move(ptr,dptr,len,char);
4521     dptr[len] = '\0';
4522     SvCUR_set(sv, len);
4523     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4524     SvTAINT(sv);
4525 }
4526
4527 /*
4528 =for apidoc sv_setpvn_mg
4529
4530 Like C<sv_setpvn>, but also handles 'set' magic.
4531
4532 =cut
4533 */
4534
4535 void
4536 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4537 {
4538     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4539
4540     sv_setpvn(sv,ptr,len);
4541     SvSETMAGIC(sv);
4542 }
4543
4544 /*
4545 =for apidoc sv_setpv
4546
4547 Copies a string into an SV.  The string must be null-terminated.  Does not
4548 handle 'set' magic.  See C<sv_setpv_mg>.
4549
4550 =cut
4551 */
4552
4553 void
4554 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4555 {
4556     dVAR;
4557     register STRLEN len;
4558
4559     PERL_ARGS_ASSERT_SV_SETPV;
4560
4561     SV_CHECK_THINKFIRST_COW_DROP(sv);
4562     if (!ptr) {
4563         (void)SvOK_off(sv);
4564         return;
4565     }
4566     len = strlen(ptr);
4567     SvUPGRADE(sv, SVt_PV);
4568
4569     SvGROW(sv, len + 1);
4570     Move(ptr,SvPVX(sv),len+1,char);
4571     SvCUR_set(sv, len);
4572     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4573     SvTAINT(sv);
4574 }
4575
4576 /*
4577 =for apidoc sv_setpv_mg
4578
4579 Like C<sv_setpv>, but also handles 'set' magic.
4580
4581 =cut
4582 */
4583
4584 void
4585 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4586 {
4587     PERL_ARGS_ASSERT_SV_SETPV_MG;
4588
4589     sv_setpv(sv,ptr);
4590     SvSETMAGIC(sv);
4591 }
4592
4593 /*
4594 =for apidoc sv_usepvn_flags
4595
4596 Tells an SV to use C<ptr> to find its string value.  Normally the
4597 string is stored inside the SV but sv_usepvn allows the SV to use an
4598 outside string.  The C<ptr> should point to memory that was allocated
4599 by C<malloc>.  The string length, C<len>, must be supplied.  By default
4600 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4601 so that pointer should not be freed or used by the programmer after
4602 giving it to sv_usepvn, and neither should any pointers from "behind"
4603 that pointer (e.g. ptr + 1) be used.
4604
4605 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4606 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4607 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4608 C<len>, and already meets the requirements for storing in C<SvPVX>)
4609
4610 =cut
4611 */
4612
4613 void
4614 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4615 {
4616     dVAR;
4617     STRLEN allocate;
4618
4619     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4620
4621     SV_CHECK_THINKFIRST_COW_DROP(sv);
4622     SvUPGRADE(sv, SVt_PV);
4623     if (!ptr) {
4624         (void)SvOK_off(sv);
4625         if (flags & SV_SMAGIC)
4626             SvSETMAGIC(sv);
4627         return;
4628     }
4629     if (SvPVX_const(sv))
4630         SvPV_free(sv);
4631
4632 #ifdef DEBUGGING
4633     if (flags & SV_HAS_TRAILING_NUL)
4634         assert(ptr[len] == '\0');
4635 #endif
4636
4637     allocate = (flags & SV_HAS_TRAILING_NUL)
4638         ? len + 1 :
4639 #ifdef Perl_safesysmalloc_size
4640         len + 1;
4641 #else
4642         PERL_STRLEN_ROUNDUP(len + 1);
4643 #endif
4644     if (flags & SV_HAS_TRAILING_NUL) {
4645         /* It's long enough - do nothing.
4646            Specifically Perl_newCONSTSUB is relying on this.  */
4647     } else {
4648 #ifdef DEBUGGING
4649         /* Force a move to shake out bugs in callers.  */
4650         char *new_ptr = (char*)safemalloc(allocate);
4651         Copy(ptr, new_ptr, len, char);
4652         PoisonFree(ptr,len,char);
4653         Safefree(ptr);
4654         ptr = new_ptr;
4655 #else
4656         ptr = (char*) saferealloc (ptr, allocate);
4657 #endif
4658     }
4659 #ifdef Perl_safesysmalloc_size
4660     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4661 #else
4662     SvLEN_set(sv, allocate);
4663 #endif
4664     SvCUR_set(sv, len);
4665     SvPV_set(sv, ptr);
4666     if (!(flags & SV_HAS_TRAILING_NUL)) {
4667         ptr[len] = '\0';
4668     }
4669     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4670     SvTAINT(sv);
4671     if (flags & SV_SMAGIC)
4672         SvSETMAGIC(sv);
4673 }
4674
4675 #ifdef PERL_OLD_COPY_ON_WRITE
4676 /* Need to do this *after* making the SV normal, as we need the buffer
4677    pointer to remain valid until after we've copied it.  If we let go too early,
4678    another thread could invalidate it by unsharing last of the same hash key
4679    (which it can do by means other than releasing copy-on-write Svs)
4680    or by changing the other copy-on-write SVs in the loop.  */
4681 STATIC void
4682 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4683 {
4684     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4685
4686     { /* this SV was SvIsCOW_normal(sv) */
4687          /* we need to find the SV pointing to us.  */
4688         SV *current = SV_COW_NEXT_SV(after);
4689
4690         if (current == sv) {
4691             /* The SV we point to points back to us (there were only two of us
4692                in the loop.)
4693                Hence other SV is no longer copy on write either.  */
4694             SvFAKE_off(after);
4695             SvREADONLY_off(after);
4696         } else {
4697             /* We need to follow the pointers around the loop.  */
4698             SV *next;
4699             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4700                 assert (next);
4701                 current = next;
4702                  /* don't loop forever if the structure is bust, and we have
4703                     a pointer into a closed loop.  */
4704                 assert (current != after);
4705                 assert (SvPVX_const(current) == pvx);
4706             }
4707             /* Make the SV before us point to the SV after us.  */
4708             SV_COW_NEXT_SV_SET(current, after);
4709         }
4710     }
4711 }
4712 #endif
4713 /*
4714 =for apidoc sv_force_normal_flags
4715
4716 Undo various types of fakery on an SV: if the PV is a shared string, make
4717 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4718 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4719 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4720 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4721 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4722 set to some other value.) In addition, the C<flags> parameter gets passed to
4723 C<sv_unref_flags()> when unreffing. C<sv_force_normal> calls this function
4724 with flags set to 0.
4725
4726 =cut
4727 */
4728
4729 void
4730 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4731 {
4732     dVAR;
4733
4734     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4735
4736 #ifdef PERL_OLD_COPY_ON_WRITE
4737     if (SvREADONLY(sv)) {
4738         if (SvFAKE(sv)) {
4739             const char * const pvx = SvPVX_const(sv);
4740             const STRLEN len = SvLEN(sv);
4741             const STRLEN cur = SvCUR(sv);
4742             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4743                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4744                we'll fail an assertion.  */
4745             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4746
4747             if (DEBUG_C_TEST) {
4748                 PerlIO_printf(Perl_debug_log,
4749                               "Copy on write: Force normal %ld\n",
4750                               (long) flags);
4751                 sv_dump(sv);
4752             }
4753             SvFAKE_off(sv);
4754             SvREADONLY_off(sv);
4755             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4756             SvPV_set(sv, NULL);
4757             SvLEN_set(sv, 0);
4758             if (flags & SV_COW_DROP_PV) {
4759                 /* OK, so we don't need to copy our buffer.  */
4760                 SvPOK_off(sv);
4761             } else {
4762                 SvGROW(sv, cur + 1);
4763                 Move(pvx,SvPVX(sv),cur,char);
4764                 SvCUR_set(sv, cur);
4765                 *SvEND(sv) = '\0';
4766             }
4767             if (len) {
4768                 sv_release_COW(sv, pvx, next);
4769             } else {
4770                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4771             }
4772             if (DEBUG_C_TEST) {
4773                 sv_dump(sv);
4774             }
4775         }
4776         else if (IN_PERL_RUNTIME)
4777             Perl_croak_no_modify(aTHX);
4778     }
4779 #else
4780     if (SvREADONLY(sv)) {
4781         if (SvFAKE(sv)) {
4782             const char * const pvx = SvPVX_const(sv);
4783             const STRLEN len = SvCUR(sv);
4784             SvFAKE_off(sv);
4785             SvREADONLY_off(sv);
4786             SvPV_set(sv, NULL);
4787             SvLEN_set(sv, 0);
4788             SvGROW(sv, len + 1);
4789             Move(pvx,SvPVX(sv),len,char);
4790             *SvEND(sv) = '\0';
4791             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4792         }
4793         else if (IN_PERL_RUNTIME)
4794             Perl_croak_no_modify(aTHX);
4795     }
4796 #endif
4797     if (SvROK(sv))
4798         sv_unref_flags(sv, flags);
4799     else if (SvFAKE(sv) && isGV_with_GP(sv))
4800         sv_unglob(sv);
4801     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4802         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
4803            to sv_unglob. We only need it here, so inline it.  */
4804         const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4805         SV *const temp = newSV_type(new_type);
4806         void *const temp_p = SvANY(sv);
4807
4808         if (new_type == SVt_PVMG) {
4809             SvMAGIC_set(temp, SvMAGIC(sv));
4810             SvMAGIC_set(sv, NULL);
4811             SvSTASH_set(temp, SvSTASH(sv));
4812             SvSTASH_set(sv, NULL);
4813         }
4814         SvCUR_set(temp, SvCUR(sv));
4815         /* Remember that SvPVX is in the head, not the body. */
4816         if (SvLEN(temp)) {
4817             SvLEN_set(temp, SvLEN(sv));
4818             /* This signals "buffer is owned by someone else" in sv_clear,
4819                which is the least effort way to stop it freeing the buffer.
4820             */
4821             SvLEN_set(sv, SvLEN(sv)+1);
4822         } else {
4823             /* Their buffer is already owned by someone else. */
4824             SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4825             SvLEN_set(temp, SvCUR(sv)+1);
4826         }
4827
4828         /* Now swap the rest of the bodies. */
4829
4830         SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4831         SvFLAGS(sv) |= new_type;
4832         SvANY(sv) = SvANY(temp);
4833
4834         SvFLAGS(temp) &= ~(SVTYPEMASK);
4835         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4836         SvANY(temp) = temp_p;
4837
4838         SvREFCNT_dec(temp);
4839     }
4840 }
4841
4842 /*
4843 =for apidoc sv_chop
4844
4845 Efficient removal of characters from the beginning of the string buffer.
4846 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4847 the string buffer.  The C<ptr> becomes the first character of the adjusted
4848 string. Uses the "OOK hack".
4849 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4850 refer to the same chunk of data.
4851
4852 =cut
4853 */
4854
4855 void
4856 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4857 {
4858     STRLEN delta;
4859     STRLEN old_delta;
4860     U8 *p;
4861 #ifdef DEBUGGING
4862     const U8 *real_start;
4863 #endif
4864     STRLEN max_delta;
4865
4866     PERL_ARGS_ASSERT_SV_CHOP;
4867
4868     if (!ptr || !SvPOKp(sv))
4869         return;
4870     delta = ptr - SvPVX_const(sv);
4871     if (!delta) {
4872         /* Nothing to do.  */
4873         return;
4874     }
4875     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4876        nothing uses the value of ptr any more.  */
4877     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4878     if (ptr <= SvPVX_const(sv))
4879         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4880                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4881     SV_CHECK_THINKFIRST(sv);
4882     if (delta > max_delta)
4883         Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4884                    SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4885                    SvPVX_const(sv) + max_delta);
4886
4887     if (!SvOOK(sv)) {
4888         if (!SvLEN(sv)) { /* make copy of shared string */
4889             const char *pvx = SvPVX_const(sv);
4890             const STRLEN len = SvCUR(sv);
4891             SvGROW(sv, len + 1);
4892             Move(pvx,SvPVX(sv),len,char);
4893             *SvEND(sv) = '\0';
4894         }
4895         SvFLAGS(sv) |= SVf_OOK;
4896         old_delta = 0;
4897     } else {
4898         SvOOK_offset(sv, old_delta);
4899     }
4900     SvLEN_set(sv, SvLEN(sv) - delta);
4901     SvCUR_set(sv, SvCUR(sv) - delta);
4902     SvPV_set(sv, SvPVX(sv) + delta);
4903
4904     p = (U8 *)SvPVX_const(sv);
4905
4906     delta += old_delta;
4907
4908 #ifdef DEBUGGING
4909     real_start = p - delta;
4910 #endif
4911
4912     assert(delta);
4913     if (delta < 0x100) {
4914         *--p = (U8) delta;
4915     } else {
4916         *--p = 0;
4917         p -= sizeof(STRLEN);
4918         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4919     }
4920
4921 #ifdef DEBUGGING
4922     /* Fill the preceding buffer with sentinals to verify that no-one is
4923        using it.  */
4924     while (p > real_start) {
4925         --p;
4926         *p = (U8)PTR2UV(p);
4927     }
4928 #endif
4929 }
4930
4931 /*
4932 =for apidoc sv_catpvn
4933
4934 Concatenates the string onto the end of the string which is in the SV.  The
4935 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4936 status set, then the bytes appended should be valid UTF-8.
4937 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4938
4939 =for apidoc sv_catpvn_flags
4940
4941 Concatenates the string onto the end of the string which is in the SV.  The
4942 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4943 status set, then the bytes appended should be valid UTF-8.
4944 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4945 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4946 in terms of this function.
4947
4948 =cut
4949 */
4950
4951 void
4952 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4953 {
4954     dVAR;
4955     STRLEN dlen;
4956     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4957
4958     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4959
4960     SvGROW(dsv, dlen + slen + 1);
4961     if (sstr == dstr)
4962         sstr = SvPVX_const(dsv);
4963     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4964     SvCUR_set(dsv, SvCUR(dsv) + slen);
4965     *SvEND(dsv) = '\0';
4966     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4967     SvTAINT(dsv);
4968     if (flags & SV_SMAGIC)
4969         SvSETMAGIC(dsv);
4970 }
4971
4972 /*
4973 =for apidoc sv_catsv
4974
4975 Concatenates the string from SV C<ssv> onto the end of the string in
4976 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4977 not 'set' magic.  See C<sv_catsv_mg>.
4978
4979 =for apidoc sv_catsv_flags
4980
4981 Concatenates the string from SV C<ssv> onto the end of the string in
4982 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4983 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4984 and C<sv_catsv_nomg> are implemented in terms of this function.
4985
4986 =cut */
4987
4988 void
4989 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4990 {
4991     dVAR;
4992
4993     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4994
4995    if (ssv) {
4996         STRLEN slen;
4997         const char *spv = SvPV_flags_const(ssv, slen, flags);
4998         if (spv) {
4999             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5000                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5001                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5002                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
5003                 dsv->sv_flags doesn't have that bit set.
5004                 Andy Dougherty  12 Oct 2001
5005             */
5006             const I32 sutf8 = DO_UTF8(ssv);
5007             I32 dutf8;
5008
5009             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5010                 mg_get(dsv);
5011             dutf8 = DO_UTF8(dsv);
5012
5013             if (dutf8 != sutf8) {
5014                 if (dutf8) {
5015                     /* Not modifying source SV, so taking a temporary copy. */
5016                     SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
5017
5018                     sv_utf8_upgrade(csv);
5019                     spv = SvPV_const(csv, slen);
5020                 }
5021                 else
5022                     /* Leave enough space for the cat that's about to happen */
5023                     sv_utf8_upgrade_flags_grow(dsv, 0, slen);
5024             }
5025             sv_catpvn_nomg(dsv, spv, slen);
5026         }
5027     }
5028     if (flags & SV_SMAGIC)
5029         SvSETMAGIC(dsv);
5030 }
5031
5032 /*
5033 =for apidoc sv_catpv
5034
5035 Concatenates the string onto the end of the string which is in the SV.
5036 If the SV has the UTF-8 status set, then the bytes appended should be
5037 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
5038
5039 =cut */
5040
5041 void
5042 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
5043 {
5044     dVAR;
5045     register STRLEN len;
5046     STRLEN tlen;
5047     char *junk;
5048
5049     PERL_ARGS_ASSERT_SV_CATPV;
5050
5051     if (!ptr)
5052         return;
5053     junk = SvPV_force(sv, tlen);
5054     len = strlen(ptr);
5055     SvGROW(sv, tlen + len + 1);
5056     if (ptr == junk)
5057         ptr = SvPVX_const(sv);
5058     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5059     SvCUR_set(sv, SvCUR(sv) + len);
5060     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5061     SvTAINT(sv);
5062 }
5063
5064 /*
5065 =for apidoc sv_catpv_flags
5066
5067 Concatenates the string onto the end of the string which is in the SV.
5068 If the SV has the UTF-8 status set, then the bytes appended should
5069 be valid UTF-8.  If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get>
5070 on the SVs if appropriate, else not.
5071
5072 =cut
5073 */
5074
5075 void
5076 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5077 {
5078     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5079     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5080 }
5081
5082 /*
5083 =for apidoc sv_catpv_mg
5084
5085 Like C<sv_catpv>, but also handles 'set' magic.
5086
5087 =cut
5088 */
5089
5090 void
5091 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
5092 {
5093     PERL_ARGS_ASSERT_SV_CATPV_MG;
5094
5095     sv_catpv(sv,ptr);
5096     SvSETMAGIC(sv);
5097 }
5098
5099 /*
5100 =for apidoc newSV
5101
5102 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5103 bytes of preallocated string space the SV should have.  An extra byte for a
5104 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
5105 space is allocated.)  The reference count for the new SV is set to 1.
5106
5107 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5108 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5109 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5110 L<perlhack/PERL_MEM_LOG>).  The older API is still there for use in XS
5111 modules supporting older perls.
5112
5113 =cut
5114 */
5115
5116 SV *
5117 Perl_newSV(pTHX_ const STRLEN len)
5118 {
5119     dVAR;
5120     register SV *sv;
5121
5122     new_SV(sv);
5123     if (len) {
5124         sv_upgrade(sv, SVt_PV);
5125         SvGROW(sv, len + 1);
5126     }
5127     return sv;
5128 }
5129 /*
5130 =for apidoc sv_magicext
5131
5132 Adds magic to an SV, upgrading it if necessary. Applies the
5133 supplied vtable and returns a pointer to the magic added.
5134
5135 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5136 In particular, you can add magic to SvREADONLY SVs, and add more than
5137 one instance of the same 'how'.
5138
5139 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5140 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5141 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5142 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5143
5144 (This is now used as a subroutine by C<sv_magic>.)
5145
5146 =cut
5147 */
5148 MAGIC *
5149 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5150                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5151 {
5152     dVAR;
5153     MAGIC* mg;
5154
5155     PERL_ARGS_ASSERT_SV_MAGICEXT;
5156
5157     SvUPGRADE(sv, SVt_PVMG);
5158     Newxz(mg, 1, MAGIC);
5159     mg->mg_moremagic = SvMAGIC(sv);
5160     SvMAGIC_set(sv, mg);
5161
5162     /* Sometimes a magic contains a reference loop, where the sv and
5163        object refer to each other.  To prevent a reference loop that
5164        would prevent such objects being freed, we look for such loops
5165        and if we find one we avoid incrementing the object refcount.
5166
5167        Note we cannot do this to avoid self-tie loops as intervening RV must
5168        have its REFCNT incremented to keep it in existence.
5169
5170     */
5171     if (!obj || obj == sv ||
5172         how == PERL_MAGIC_arylen ||
5173         how == PERL_MAGIC_symtab ||
5174         (SvTYPE(obj) == SVt_PVGV &&
5175             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5176              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5177              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5178     {
5179         mg->mg_obj = obj;
5180     }
5181     else {
5182         mg->mg_obj = SvREFCNT_inc_simple(obj);
5183         mg->mg_flags |= MGf_REFCOUNTED;
5184     }
5185
5186     /* Normal self-ties simply pass a null object, and instead of
5187        using mg_obj directly, use the SvTIED_obj macro to produce a
5188        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5189        with an RV obj pointing to the glob containing the PVIO.  In
5190        this case, to avoid a reference loop, we need to weaken the
5191        reference.
5192     */
5193
5194     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5195         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5196     {
5197       sv_rvweaken(obj);
5198     }
5199
5200     mg->mg_type = how;
5201     mg->mg_len = namlen;
5202     if (name) {
5203         if (namlen > 0)
5204             mg->mg_ptr = savepvn(name, namlen);
5205         else if (namlen == HEf_SVKEY) {
5206             /* Yes, this is casting away const. This is only for the case of
5207                HEf_SVKEY. I think we need to document this aberation of the
5208                constness of the API, rather than making name non-const, as
5209                that change propagating outwards a long way.  */
5210             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5211         } else
5212             mg->mg_ptr = (char *) name;
5213     }
5214     mg->mg_virtual = (MGVTBL *) vtable;
5215
5216     mg_magical(sv);
5217     if (SvGMAGICAL(sv))
5218         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5219     return mg;
5220 }
5221
5222 /*
5223 =for apidoc sv_magic
5224
5225 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5226 then adds a new magic item of type C<how> to the head of the magic list.
5227
5228 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5229 handling of the C<name> and C<namlen> arguments.
5230
5231 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5232 to add more than one instance of the same 'how'.
5233
5234 =cut
5235 */
5236
5237 void
5238 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5239              const char *const name, const I32 namlen)
5240 {
5241     dVAR;
5242     const MGVTBL *vtable;
5243     MAGIC* mg;
5244
5245     PERL_ARGS_ASSERT_SV_MAGIC;
5246
5247 #ifdef PERL_OLD_COPY_ON_WRITE
5248     if (SvIsCOW(sv))
5249         sv_force_normal_flags(sv, 0);
5250 #endif
5251     if (SvREADONLY(sv)) {
5252         if (
5253             /* its okay to attach magic to shared strings; the subsequent
5254              * upgrade to PVMG will unshare the string */
5255             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5256
5257             && IN_PERL_RUNTIME
5258             && how != PERL_MAGIC_regex_global
5259             && how != PERL_MAGIC_bm
5260             && how != PERL_MAGIC_fm
5261             && how != PERL_MAGIC_sv
5262             && how != PERL_MAGIC_backref
5263            )
5264         {
5265             Perl_croak_no_modify(aTHX);
5266         }
5267     }
5268     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5269         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5270             /* sv_magic() refuses to add a magic of the same 'how' as an
5271                existing one
5272              */
5273             if (how == PERL_MAGIC_taint) {
5274                 mg->mg_len |= 1;
5275                 /* Any scalar which already had taint magic on which someone
5276                    (erroneously?) did SvIOK_on() or similar will now be
5277                    incorrectly sporting public "OK" flags.  */
5278                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5279             }
5280             return;
5281         }
5282     }
5283
5284     switch (how) {
5285     case PERL_MAGIC_sv:
5286         vtable = &PL_vtbl_sv;
5287         break;
5288     case PERL_MAGIC_overload:
5289         vtable = &PL_vtbl_amagic;
5290         break;
5291     case PERL_MAGIC_overload_elem:
5292         vtable = &PL_vtbl_amagicelem;
5293         break;
5294     case PERL_MAGIC_overload_table:
5295         vtable = &PL_vtbl_ovrld;
5296         break;
5297     case PERL_MAGIC_bm:
5298         vtable = &PL_vtbl_bm;
5299         break;
5300     case PERL_MAGIC_regdata:
5301         vtable = &PL_vtbl_regdata;
5302         break;
5303     case PERL_MAGIC_regdatum:
5304         vtable = &PL_vtbl_regdatum;
5305         break;
5306     case PERL_MAGIC_env:
5307         vtable = &PL_vtbl_env;
5308         break;
5309     case PERL_MAGIC_fm:
5310         vtable = &PL_vtbl_fm;
5311         break;
5312     case PERL_MAGIC_envelem:
5313         vtable = &PL_vtbl_envelem;
5314         break;
5315     case PERL_MAGIC_regex_global:
5316         vtable = &PL_vtbl_mglob;
5317         break;
5318     case PERL_MAGIC_isa:
5319         vtable = &PL_vtbl_isa;
5320         break;
5321     case PERL_MAGIC_isaelem:
5322         vtable = &PL_vtbl_isaelem;
5323         break;
5324     case PERL_MAGIC_nkeys:
5325         vtable = &PL_vtbl_nkeys;
5326         break;
5327     case PERL_MAGIC_dbfile:
5328         vtable = NULL;
5329         break;
5330     case PERL_MAGIC_dbline:
5331         vtable = &PL_vtbl_dbline;
5332         break;
5333 #ifdef USE_LOCALE_COLLATE
5334     case PERL_MAGIC_collxfrm:
5335         vtable = &PL_vtbl_collxfrm;
5336         break;
5337 #endif /* USE_LOCALE_COLLATE */
5338     case PERL_MAGIC_tied:
5339         vtable = &PL_vtbl_pack;
5340         break;
5341     case PERL_MAGIC_tiedelem:
5342     case PERL_MAGIC_tiedscalar:
5343         vtable = &PL_vtbl_packelem;
5344         break;
5345     case PERL_MAGIC_qr:
5346         vtable = &PL_vtbl_regexp;
5347         break;
5348     case PERL_MAGIC_sig:
5349         vtable = &PL_vtbl_sig;
5350         break;
5351     case PERL_MAGIC_sigelem:
5352         vtable = &PL_vtbl_sigelem;
5353         break;
5354     case PERL_MAGIC_taint:
5355         vtable = &PL_vtbl_taint;
5356         break;
5357     case PERL_MAGIC_uvar:
5358         vtable = &PL_vtbl_uvar;
5359         break;
5360     case PERL_MAGIC_vec:
5361         vtable = &PL_vtbl_vec;
5362         break;
5363     case PERL_MAGIC_arylen_p:
5364     case PERL_MAGIC_rhash:
5365     case PERL_MAGIC_symtab:
5366     case PERL_MAGIC_vstring:
5367     case PERL_MAGIC_checkcall:
5368         vtable = NULL;
5369         break;
5370     case PERL_MAGIC_utf8:
5371         vtable = &PL_vtbl_utf8;
5372         break;
5373     case PERL_MAGIC_substr:
5374         vtable = &PL_vtbl_substr;
5375         break;
5376     case PERL_MAGIC_defelem:
5377         vtable = &PL_vtbl_defelem;
5378         break;
5379     case PERL_MAGIC_arylen:
5380         vtable = &PL_vtbl_arylen;
5381         break;
5382     case PERL_MAGIC_pos:
5383         vtable = &PL_vtbl_pos;
5384         break;
5385     case PERL_MAGIC_backref:
5386         vtable = &PL_vtbl_backref;
5387         break;
5388     case PERL_MAGIC_hintselem:
5389         vtable = &PL_vtbl_hintselem;
5390         break;
5391     case PERL_MAGIC_hints:
5392         vtable = &PL_vtbl_hints;
5393         break;
5394     case PERL_MAGIC_ext:
5395         /* Reserved for use by extensions not perl internals.           */
5396         /* Useful for attaching extension internal data to perl vars.   */
5397         /* Note that multiple extensions may clash if magical scalars   */
5398         /* etc holding private data from one are passed to another.     */
5399         vtable = NULL;
5400         break;
5401     default:
5402         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5403     }
5404
5405     /* Rest of work is done else where */
5406     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5407
5408     switch (how) {
5409     case PERL_MAGIC_taint:
5410         mg->mg_len = 1;
5411         break;
5412     case PERL_MAGIC_ext:
5413     case PERL_MAGIC_dbfile:
5414         SvRMAGICAL_on(sv);
5415         break;
5416     }
5417 }
5418
5419 static int
5420 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5421 {
5422     MAGIC* mg;
5423     MAGIC** mgp;
5424
5425     assert(flags <= 1);
5426
5427     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5428         return 0;
5429     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5430     for (mg = *mgp; mg; mg = *mgp) {
5431         const MGVTBL* const virt = mg->mg_virtual;
5432         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5433             *mgp = mg->mg_moremagic;
5434             if (virt && virt->svt_free)
5435                 virt->svt_free(aTHX_ sv, mg);
5436             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5437                 if (mg->mg_len > 0)
5438                     Safefree(mg->mg_ptr);
5439                 else if (mg->mg_len == HEf_SVKEY)
5440                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5441                 else if (mg->mg_type == PERL_MAGIC_utf8)
5442                     Safefree(mg->mg_ptr);
5443             }
5444             if (mg->mg_flags & MGf_REFCOUNTED)
5445                 SvREFCNT_dec(mg->mg_obj);
5446             Safefree(mg);
5447         }
5448         else
5449             mgp = &mg->mg_moremagic;
5450     }
5451     if (SvMAGIC(sv)) {
5452         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5453             mg_magical(sv);     /*    else fix the flags now */
5454     }
5455     else {
5456         SvMAGICAL_off(sv);
5457         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5458     }
5459     return 0;
5460 }
5461
5462 /*
5463 =for apidoc sv_unmagic
5464
5465 Removes all magic of type C<type> from an SV.
5466
5467 =cut
5468 */
5469
5470 int
5471 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5472 {
5473     PERL_ARGS_ASSERT_SV_UNMAGIC;
5474     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5475 }
5476
5477 /*
5478 =for apidoc sv_unmagicext
5479
5480 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5481
5482 =cut
5483 */
5484
5485 int
5486 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5487 {
5488     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5489     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5490 }
5491
5492 /*
5493 =for apidoc sv_rvweaken
5494
5495 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5496 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5497 push a back-reference to this RV onto the array of backreferences
5498 associated with that magic. If the RV is magical, set magic will be
5499 called after the RV is cleared.
5500
5501 =cut
5502 */
5503
5504 SV *
5505 Perl_sv_rvweaken(pTHX_ SV *const sv)
5506 {
5507     SV *tsv;
5508
5509     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5510
5511     if (!SvOK(sv))  /* let undefs pass */
5512         return sv;
5513     if (!SvROK(sv))
5514         Perl_croak(aTHX_ "Can't weaken a nonreference");
5515     else if (SvWEAKREF(sv)) {
5516         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5517         return sv;
5518     }
5519     tsv = SvRV(sv);
5520     Perl_sv_add_backref(aTHX_ tsv, sv);
5521     SvWEAKREF_on(sv);
5522     SvREFCNT_dec(tsv);
5523     return sv;
5524 }
5525
5526 /* Give tsv backref magic if it hasn't already got it, then push a
5527  * back-reference to sv onto the array associated with the backref magic.
5528  *
5529  * As an optimisation, if there's only one backref and it's not an AV,
5530  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5531  * allocate an AV. (Whether the slot holds an AV tells us whether this is
5532  * active.)
5533  */
5534
5535 /* A discussion about the backreferences array and its refcount:
5536  *
5537  * The AV holding the backreferences is pointed to either as the mg_obj of
5538  * PERL_MAGIC_backref, or in the specific case of a HV, from the
5539  * xhv_backreferences field. The array is created with a refcount
5540  * of 2. This means that if during global destruction the array gets
5541  * picked on before its parent to have its refcount decremented by the
5542  * random zapper, it won't actually be freed, meaning it's still there for
5543  * when its parent gets freed.
5544  *
5545  * When the parent SV is freed, the extra ref is killed by
5546  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
5547  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5548  *
5549  * When a single backref SV is stored directly, it is not reference
5550  * counted.
5551  */
5552
5553 void
5554 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5555 {
5556     dVAR;
5557     SV **svp;
5558     AV *av = NULL;
5559     MAGIC *mg = NULL;
5560
5561     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5562
5563     /* find slot to store array or singleton backref */
5564
5565     if (SvTYPE(tsv) == SVt_PVHV) {
5566         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5567     } else {
5568         if (! ((mg =
5569             (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5570         {
5571             sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5572             mg = mg_find(tsv, PERL_MAGIC_backref);
5573         }
5574         svp = &(mg->mg_obj);
5575     }
5576
5577     /* create or retrieve the array */
5578
5579     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
5580         || (*svp && SvTYPE(*svp) != SVt_PVAV)
5581     ) {
5582         /* create array */
5583         av = newAV();
5584         AvREAL_off(av);
5585         SvREFCNT_inc_simple_void(av);
5586         /* av now has a refcnt of 2; see discussion above */
5587         if (*svp) {
5588             /* move single existing backref to the array */
5589             av_extend(av, 1);
5590             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5591         }
5592         *svp = (SV*)av;
5593         if (mg)
5594             mg->mg_flags |= MGf_REFCOUNTED;
5595     }
5596     else
5597         av = MUTABLE_AV(*svp);
5598
5599     if (!av) {
5600         /* optimisation: store single backref directly in HvAUX or mg_obj */
5601         *svp = sv;
5602         return;
5603     }
5604     /* push new backref */
5605     assert(SvTYPE(av) == SVt_PVAV);
5606     if (AvFILLp(av) >= AvMAX(av)) {
5607         av_extend(av, AvFILLp(av)+1);
5608     }
5609     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5610 }
5611
5612 /* delete a back-reference to ourselves from the backref magic associated
5613  * with the SV we point to.
5614  */
5615
5616 void
5617 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5618 {
5619     dVAR;
5620     SV **svp = NULL;
5621
5622     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5623
5624     if (SvTYPE(tsv) == SVt_PVHV) {
5625         if (SvOOK(tsv))
5626             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5627     }
5628     else {
5629         MAGIC *const mg
5630             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5631         svp =  mg ? &(mg->mg_obj) : NULL;
5632     }
5633
5634     if (!svp || !*svp)
5635         Perl_croak(aTHX_ "panic: del_backref");
5636
5637     if (SvTYPE(*svp) == SVt_PVAV) {
5638 #ifdef DEBUGGING
5639         int count = 1;
5640 #endif
5641         AV * const av = (AV*)*svp;
5642         SSize_t fill;
5643         assert(!SvIS_FREED(av));
5644         fill = AvFILLp(av);
5645         assert(fill > -1);
5646         svp = AvARRAY(av);
5647         /* for an SV with N weak references to it, if all those
5648          * weak refs are deleted, then sv_del_backref will be called
5649          * N times and O(N^2) compares will be done within the backref
5650          * array. To ameliorate this potential slowness, we:
5651          * 1) make sure this code is as tight as possible;
5652          * 2) when looking for SV, look for it at both the head and tail of the
5653          *    array first before searching the rest, since some create/destroy
5654          *    patterns will cause the backrefs to be freed in order.
5655          */
5656         if (*svp == sv) {
5657             AvARRAY(av)++;
5658             AvMAX(av)--;
5659         }
5660         else {
5661             SV **p = &svp[fill];
5662             SV *const topsv = *p;
5663             if (topsv != sv) {
5664 #ifdef DEBUGGING
5665                 count = 0;
5666 #endif
5667                 while (--p > svp) {
5668                     if (*p == sv) {
5669                         /* We weren't the last entry.
5670                            An unordered list has this property that you
5671                            can take the last element off the end to fill
5672                            the hole, and it's still an unordered list :-)
5673                         */
5674                         *p = topsv;
5675 #ifdef DEBUGGING
5676                         count++;
5677 #else
5678                         break; /* should only be one */
5679 #endif
5680                     }
5681                 }
5682             }
5683         }
5684         assert(count ==1);
5685         AvFILLp(av) = fill-1;
5686     }
5687     else {
5688         /* optimisation: only a single backref, stored directly */
5689         if (*svp != sv)
5690             Perl_croak(aTHX_ "panic: del_backref");
5691         *svp = NULL;
5692     }
5693
5694 }
5695
5696 void
5697 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5698 {
5699     SV **svp;
5700     SV **last;
5701     bool is_array;
5702
5703     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5704
5705     if (!av)
5706         return;
5707
5708     /* after multiple passes through Perl_sv_clean_all() for a thinngy
5709      * that has badly leaked, the backref array may have gotten freed,
5710      * since we only protect it against 1 round of cleanup */
5711     if (SvIS_FREED(av)) {
5712         if (PL_in_clean_all) /* All is fair */
5713             return;
5714         Perl_croak(aTHX_
5715                    "panic: magic_killbackrefs (freed backref AV/SV)");
5716     }
5717
5718
5719     is_array = (SvTYPE(av) == SVt_PVAV);
5720     if (is_array) {
5721         assert(!SvIS_FREED(av));
5722         svp = AvARRAY(av);
5723         if (svp)
5724             last = svp + AvFILLp(av);
5725     }
5726     else {
5727         /* optimisation: only a single backref, stored directly */
5728         svp = (SV**)&av;
5729         last = svp;
5730     }
5731
5732     if (svp) {
5733         while (svp <= last) {
5734             if (*svp) {
5735                 SV *const referrer = *svp;
5736                 if (SvWEAKREF(referrer)) {
5737                     /* XXX Should we check that it hasn't changed? */
5738                     assert(SvROK(referrer));
5739                     SvRV_set(referrer, 0);
5740                     SvOK_off(referrer);
5741                     SvWEAKREF_off(referrer);
5742                     SvSETMAGIC(referrer);
5743                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5744                            SvTYPE(referrer) == SVt_PVLV) {
5745                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5746                     /* You lookin' at me?  */
5747                     assert(GvSTASH(referrer));
5748                     assert(GvSTASH(referrer) == (const HV *)sv);
5749                     GvSTASH(referrer) = 0;
5750                 } else if (SvTYPE(referrer) == SVt_PVCV ||
5751                            SvTYPE(referrer) == SVt_PVFM) {
5752                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5753                         /* You lookin' at me?  */
5754                         assert(CvSTASH(referrer));
5755                         assert(CvSTASH(referrer) == (const HV *)sv);
5756                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5757                     }
5758                     else {
5759                         assert(SvTYPE(sv) == SVt_PVGV);
5760                         /* You lookin' at me?  */
5761                         assert(CvGV(referrer));
5762                         assert(CvGV(referrer) == (const GV *)sv);
5763                         anonymise_cv_maybe(MUTABLE_GV(sv),
5764                                                 MUTABLE_CV(referrer));
5765                     }
5766
5767                 } else {
5768                     Perl_croak(aTHX_
5769                                "panic: magic_killbackrefs (flags=%"UVxf")",
5770                                (UV)SvFLAGS(referrer));
5771                 }
5772
5773                 if (is_array)
5774                     *svp = NULL;
5775             }
5776             svp++;
5777         }
5778     }
5779     if (is_array) {
5780         AvFILLp(av) = -1;
5781         SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5782     }
5783     return;
5784 }
5785
5786 /*
5787 =for apidoc sv_insert
5788
5789 Inserts a string at the specified offset/length within the SV. Similar to
5790 the Perl substr() function. Handles get magic.
5791
5792 =for apidoc sv_insert_flags
5793
5794 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5795
5796 =cut
5797 */
5798
5799 void
5800 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5801 {
5802     dVAR;
5803     register char *big;
5804     register char *mid;
5805     register char *midend;
5806     register char *bigend;
5807     register I32 i;
5808     STRLEN curlen;
5809
5810     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5811
5812     if (!bigstr)
5813         Perl_croak(aTHX_ "Can't modify non-existent substring");
5814     SvPV_force_flags(bigstr, curlen, flags);
5815     (void)SvPOK_only_UTF8(bigstr);
5816     if (offset + len > curlen) {
5817         SvGROW(bigstr, offset+len+1);
5818         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5819         SvCUR_set(bigstr, offset+len);
5820     }
5821
5822     SvTAINT(bigstr);
5823     i = littlelen - len;
5824     if (i > 0) {                        /* string might grow */
5825         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5826         mid = big + offset + len;
5827         midend = bigend = big + SvCUR(bigstr);
5828         bigend += i;
5829         *bigend = '\0';
5830         while (midend > mid)            /* shove everything down */
5831             *--bigend = *--midend;
5832         Move(little,big+offset,littlelen,char);
5833         SvCUR_set(bigstr, SvCUR(bigstr) + i);
5834         SvSETMAGIC(bigstr);
5835         return;
5836     }
5837     else if (i == 0) {
5838         Move(little,SvPVX(bigstr)+offset,len,char);
5839         SvSETMAGIC(bigstr);
5840         return;
5841     }
5842
5843     big = SvPVX(bigstr);
5844     mid = big + offset;
5845     midend = mid + len;
5846     bigend = big + SvCUR(bigstr);
5847
5848     if (midend > bigend)
5849         Perl_croak(aTHX_ "panic: sv_insert");
5850
5851     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5852         if (littlelen) {
5853             Move(little, mid, littlelen,char);
5854             mid += littlelen;
5855         }
5856         i = bigend - midend;
5857         if (i > 0) {
5858             Move(midend, mid, i,char);
5859             mid += i;
5860         }
5861         *mid = '\0';
5862         SvCUR_set(bigstr, mid - big);
5863     }
5864     else if ((i = mid - big)) { /* faster from front */
5865         midend -= littlelen;
5866         mid = midend;
5867         Move(big, midend - i, i, char);
5868         sv_chop(bigstr,midend-i);
5869         if (littlelen)
5870             Move(little, mid, littlelen,char);
5871     }
5872     else if (littlelen) {
5873         midend -= littlelen;
5874         sv_chop(bigstr,midend);
5875         Move(little,midend,littlelen,char);
5876     }
5877     else {
5878         sv_chop(bigstr,midend);
5879     }
5880     SvSETMAGIC(bigstr);
5881 }
5882
5883 /*
5884 =for apidoc sv_replace
5885
5886 Make the first argument a copy of the second, then delete the original.
5887 The target SV physically takes over ownership of the body of the source SV
5888 and inherits its flags; however, the target keeps any magic it owns,
5889 and any magic in the source is discarded.
5890 Note that this is a rather specialist SV copying operation; most of the
5891 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5892
5893 =cut
5894 */
5895
5896 void
5897 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5898 {
5899     dVAR;
5900     const U32 refcnt = SvREFCNT(sv);
5901
5902     PERL_ARGS_ASSERT_SV_REPLACE;
5903
5904     SV_CHECK_THINKFIRST_COW_DROP(sv);
5905     if (SvREFCNT(nsv) != 1) {
5906         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5907                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5908     }
5909     if (SvMAGICAL(sv)) {
5910         if (SvMAGICAL(nsv))
5911             mg_free(nsv);
5912         else
5913             sv_upgrade(nsv, SVt_PVMG);
5914         SvMAGIC_set(nsv, SvMAGIC(sv));
5915         SvFLAGS(nsv) |= SvMAGICAL(sv);
5916         SvMAGICAL_off(sv);
5917         SvMAGIC_set(sv, NULL);
5918     }
5919     SvREFCNT(sv) = 0;
5920     sv_clear(sv);
5921     assert(!SvREFCNT(sv));
5922 #ifdef DEBUG_LEAKING_SCALARS
5923     sv->sv_flags  = nsv->sv_flags;
5924     sv->sv_any    = nsv->sv_any;
5925     sv->sv_refcnt = nsv->sv_refcnt;
5926     sv->sv_u      = nsv->sv_u;
5927 #else
5928     StructCopy(nsv,sv,SV);
5929 #endif
5930     if(SvTYPE(sv) == SVt_IV) {
5931         SvANY(sv)
5932             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5933     }
5934
5935
5936 #ifdef PERL_OLD_COPY_ON_WRITE
5937     if (SvIsCOW_normal(nsv)) {
5938         /* We need to follow the pointers around the loop to make the
5939            previous SV point to sv, rather than nsv.  */
5940         SV *next;
5941         SV *current = nsv;
5942         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5943             assert(next);
5944             current = next;
5945             assert(SvPVX_const(current) == SvPVX_const(nsv));
5946         }
5947         /* Make the SV before us point to the SV after us.  */
5948         if (DEBUG_C_TEST) {
5949             PerlIO_printf(Perl_debug_log, "previous is\n");
5950             sv_dump(current);
5951             PerlIO_printf(Perl_debug_log,
5952                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5953                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5954         }
5955         SV_COW_NEXT_SV_SET(current, sv);
5956     }
5957 #endif
5958     SvREFCNT(sv) = refcnt;
5959     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5960     SvREFCNT(nsv) = 0;
5961     del_SV(nsv);
5962 }
5963
5964 /* We're about to free a GV which has a CV that refers back to us.
5965  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5966  * field) */
5967
5968 STATIC void
5969 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5970 {
5971     char *stash;
5972     SV *gvname;
5973     GV *anongv;
5974
5975     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5976
5977     /* be assertive! */
5978     assert(SvREFCNT(gv) == 0);
5979     assert(isGV(gv) && isGV_with_GP(gv));
5980     assert(GvGP(gv));
5981     assert(!CvANON(cv));
5982     assert(CvGV(cv) == gv);
5983
5984     /* will the CV shortly be freed by gp_free() ? */
5985     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
5986         SvANY(cv)->xcv_gv = NULL;
5987         return;
5988     }
5989
5990     /* if not, anonymise: */
5991     stash  = GvSTASH(gv) && HvNAME(GvSTASH(gv))
5992               ? HvENAME(GvSTASH(gv)) : NULL;
5993     gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
5994                                         stash ? stash : "__ANON__");
5995     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
5996     SvREFCNT_dec(gvname);
5997
5998     CvANON_on(cv);
5999     CvCVGV_RC_on(cv);
6000     SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6001 }
6002
6003
6004 /*
6005 =for apidoc sv_clear
6006
6007 Clear an SV: call any destructors, free up any memory used by the body,
6008 and free the body itself. The SV's head is I<not> freed, although
6009 its type is set to all 1's so that it won't inadvertently be assumed
6010 to be live during global destruction etc.
6011 This function should only be called when REFCNT is zero. Most of the time
6012 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6013 instead.
6014
6015 =cut
6016 */
6017
6018 void
6019 Perl_sv_clear(pTHX_ SV *const orig_sv)
6020 {
6021     dVAR;
6022     HV *stash;
6023     U32 type;
6024     const struct body_details *sv_type_details;
6025     SV* iter_sv = NULL;
6026     SV* next_sv = NULL;
6027     register SV *sv = orig_sv;
6028     STRLEN hash_index;
6029
6030     PERL_ARGS_ASSERT_SV_CLEAR;
6031
6032     /* within this loop, sv is the SV currently being freed, and
6033      * iter_sv is the most recent AV or whatever that's being iterated
6034      * over to provide more SVs */
6035
6036     while (sv) {
6037
6038         type = SvTYPE(sv);
6039
6040         assert(SvREFCNT(sv) == 0);
6041         assert(SvTYPE(sv) != SVTYPEMASK);
6042
6043         if (type <= SVt_IV) {
6044             /* See the comment in sv.h about the collusion between this
6045              * early return and the overloading of the NULL slots in the
6046              * size table.  */
6047             if (SvROK(sv))
6048                 goto free_rv;
6049             SvFLAGS(sv) &= SVf_BREAK;
6050             SvFLAGS(sv) |= SVTYPEMASK;
6051             goto free_head;
6052         }
6053
6054         assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6055
6056         if (type >= SVt_PVMG) {
6057             if (SvOBJECT(sv)) {
6058                 if (!curse(sv, 1)) goto get_next_sv;
6059                 type = SvTYPE(sv); /* destructor may have changed it */
6060             }
6061             /* Free back-references before magic, in case the magic calls
6062              * Perl code that has weak references to sv. */
6063             if (type == SVt_PVHV) {
6064                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6065                 if (SvMAGIC(sv))
6066                     mg_free(sv);
6067             }
6068             else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6069                 SvREFCNT_dec(SvOURSTASH(sv));
6070             } else if (SvMAGIC(sv)) {
6071                 /* Free back-references before other types of magic. */
6072                 sv_unmagic(sv, PERL_MAGIC_backref);
6073                 mg_free(sv);
6074             }
6075             if (type == SVt_PVMG && SvPAD_TYPED(sv))
6076                 SvREFCNT_dec(SvSTASH(sv));
6077         }
6078         switch (type) {
6079             /* case SVt_BIND: */
6080         case SVt_PVIO:
6081             if (IoIFP(sv) &&
6082                 IoIFP(sv) != PerlIO_stdin() &&
6083                 IoIFP(sv) != PerlIO_stdout() &&
6084                 IoIFP(sv) != PerlIO_stderr() &&
6085                 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6086             {
6087                 io_close(MUTABLE_IO(sv), FALSE);
6088             }
6089             if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6090                 PerlDir_close(IoDIRP(sv));
6091             IoDIRP(sv) = (DIR*)NULL;
6092             Safefree(IoTOP_NAME(sv));
6093             Safefree(IoFMT_NAME(sv));
6094             Safefree(IoBOTTOM_NAME(sv));
6095             goto freescalar;
6096         case SVt_REGEXP:
6097             /* FIXME for plugins */
6098             pregfree2((REGEXP*) sv);
6099             goto freescalar;
6100         case SVt_PVCV:
6101         case SVt_PVFM:
6102             cv_undef(MUTABLE_CV(sv));
6103             /* If we're in a stash, we don't own a reference to it.
6104              * However it does have a back reference to us, which needs to
6105              * be cleared.  */
6106             if ((stash = CvSTASH(sv)))
6107                 sv_del_backref(MUTABLE_SV(stash), sv);
6108             goto freescalar;
6109         case SVt_PVHV:
6110             if (PL_last_swash_hv == (const HV *)sv) {
6111                 PL_last_swash_hv = NULL;
6112             }
6113             if (HvTOTALKEYS((HV*)sv) > 0) {
6114                 const char *name;
6115                 /* this statement should match the one at the beginning of
6116                  * hv_undef_flags() */
6117                 if (   PL_phase != PERL_PHASE_DESTRUCT
6118                     && (name = HvNAME((HV*)sv)))
6119                 {
6120                     if (PL_stashcache)
6121                         (void)hv_delete(PL_stashcache, name,
6122                             HvNAMELEN_get((HV*)sv), G_DISCARD);
6123                     hv_name_set((HV*)sv, NULL, 0, 0);
6124                 }
6125
6126                 /* save old iter_sv in unused SvSTASH field */
6127                 assert(!SvOBJECT(sv));
6128                 SvSTASH(sv) = (HV*)iter_sv;
6129                 iter_sv = sv;
6130
6131                 /* XXX ideally we should save the old value of hash_index
6132                  * too, but I can't think of any place to hide it. The
6133                  * effect of not saving it is that for freeing hashes of
6134                  * hashes, we become quadratic in scanning the HvARRAY of
6135                  * the top hash looking for new entries to free; but
6136                  * hopefully this will be dwarfed by the freeing of all
6137                  * the nested hashes. */
6138                 hash_index = 0;
6139                 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6140                 goto get_next_sv; /* process this new sv */
6141             }
6142             /* free empty hash */
6143             Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6144             assert(!HvARRAY((HV*)sv));
6145             break;
6146         case SVt_PVAV:
6147             {
6148                 AV* av = MUTABLE_AV(sv);
6149                 if (PL_comppad == av) {
6150                     PL_comppad = NULL;
6151                     PL_curpad = NULL;
6152                 }
6153                 if (AvREAL(av) && AvFILLp(av) > -1) {
6154                     next_sv = AvARRAY(av)[AvFILLp(av)--];
6155                     /* save old iter_sv in top-most slot of AV,
6156                      * and pray that it doesn't get wiped in the meantime */
6157                     AvARRAY(av)[AvMAX(av)] = iter_sv;
6158                     iter_sv = sv;
6159                     goto get_next_sv; /* process this new sv */
6160                 }
6161                 Safefree(AvALLOC(av));
6162             }
6163
6164             break;
6165         case SVt_PVLV:
6166             if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6167                 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6168                 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6169                 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6170             }
6171             else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
6172                 SvREFCNT_dec(LvTARG(sv));
6173         case SVt_PVGV:
6174             if (isGV_with_GP(sv)) {
6175                 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6176                    && HvENAME_get(stash))
6177                     mro_method_changed_in(stash);
6178                 gp_free(MUTABLE_GV(sv));
6179                 if (GvNAME_HEK(sv))
6180                     unshare_hek(GvNAME_HEK(sv));
6181                 /* If we're in a stash, we don't own a reference to it.
6182                  * However it does have a back reference to us, which
6183                  * needs to be cleared.  */
6184                 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6185                         sv_del_backref(MUTABLE_SV(stash), sv);
6186             }
6187             /* FIXME. There are probably more unreferenced pointers to SVs
6188              * in the interpreter struct that we should check and tidy in
6189              * a similar fashion to this:  */
6190             if ((const GV *)sv == PL_last_in_gv)
6191                 PL_last_in_gv = NULL;
6192         case SVt_PVMG:
6193         case SVt_PVNV:
6194         case SVt_PVIV:
6195         case SVt_PV:
6196           freescalar:
6197             /* Don't bother with SvOOK_off(sv); as we're only going to
6198              * free it.  */
6199             if (SvOOK(sv)) {
6200                 STRLEN offset;
6201                 SvOOK_offset(sv, offset);
6202                 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6203                 /* Don't even bother with turning off the OOK flag.  */
6204             }
6205             if (SvROK(sv)) {
6206             free_rv:
6207                 {
6208                     SV * const target = SvRV(sv);
6209                     if (SvWEAKREF(sv))
6210                         sv_del_backref(target, sv);
6211                     else
6212                         next_sv = target;
6213                 }
6214             }
6215 #ifdef PERL_OLD_COPY_ON_WRITE
6216             else if (SvPVX_const(sv)
6217                      && !(SvTYPE(sv) == SVt_PVIO
6218                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6219             {
6220                 if (SvIsCOW(sv)) {
6221                     if (DEBUG_C_TEST) {
6222                         PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6223                         sv_dump(sv);
6224                     }
6225                     if (SvLEN(sv)) {
6226                         sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6227                     } else {
6228                         unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6229                     }
6230
6231                     SvFAKE_off(sv);
6232                 } else if (SvLEN(sv)) {
6233                     Safefree(SvPVX_const(sv));
6234                 }
6235             }
6236 #else
6237             else if (SvPVX_const(sv) && SvLEN(sv)
6238                      && !(SvTYPE(sv) == SVt_PVIO
6239                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6240                 Safefree(SvPVX_mutable(sv));
6241             else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6242                 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6243                 SvFAKE_off(sv);
6244             }
6245 #endif
6246             break;
6247         case SVt_NV:
6248             break;
6249         }
6250
6251       free_body:
6252
6253         SvFLAGS(sv) &= SVf_BREAK;
6254         SvFLAGS(sv) |= SVTYPEMASK;
6255
6256         sv_type_details = bodies_by_type + type;
6257         if (sv_type_details->arena) {
6258             del_body(((char *)SvANY(sv) + sv_type_details->offset),
6259                      &PL_body_roots[type]);
6260         }
6261         else if (sv_type_details->body_size) {
6262             safefree(SvANY(sv));
6263         }
6264
6265       free_head:
6266         /* caller is responsible for freeing the head of the original sv */
6267         if (sv != orig_sv && !SvREFCNT(sv))
6268             del_SV(sv);
6269
6270         /* grab and free next sv, if any */
6271       get_next_sv:
6272         while (1) {
6273             sv = NULL;
6274             if (next_sv) {
6275                 sv = next_sv;
6276                 next_sv = NULL;
6277             }
6278             else if (!iter_sv) {
6279                 break;
6280             } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6281                 AV *const av = (AV*)iter_sv;
6282                 if (AvFILLp(av) > -1) {
6283                     sv = AvARRAY(av)[AvFILLp(av)--];
6284                 }
6285                 else { /* no more elements of current AV to free */
6286                     sv = iter_sv;
6287                     type = SvTYPE(sv);
6288                     /* restore previous value, squirrelled away */
6289                     iter_sv = AvARRAY(av)[AvMAX(av)];
6290                     Safefree(AvALLOC(av));
6291                     goto free_body;
6292                 }
6293             } else if (SvTYPE(iter_sv) == SVt_PVHV) {
6294                 sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
6295                 if (!sv) { /* no more elements of current HV to free */
6296                     sv = iter_sv;
6297                     type = SvTYPE(sv);
6298                     /* Restore previous value of iter_sv, squirrelled away */
6299                     assert(!SvOBJECT(sv));
6300                     iter_sv = (SV*)SvSTASH(sv);
6301
6302                     /* ideally we should restore the old hash_index here,
6303                      * but we don't currently save the old value */
6304                     hash_index = 0;
6305
6306                     /* free any remaining detritus from the hash struct */
6307                     Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6308                     assert(!HvARRAY((HV*)sv));
6309                     goto free_body;
6310                 }
6311             }
6312
6313             /* unrolled SvREFCNT_dec and sv_free2 follows: */
6314
6315             if (!sv)
6316                 continue;
6317             if (!SvREFCNT(sv)) {
6318                 sv_free(sv);
6319                 continue;
6320             }
6321             if (--(SvREFCNT(sv)))
6322                 continue;
6323 #ifdef DEBUGGING
6324             if (SvTEMP(sv)) {
6325                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6326                          "Attempt to free temp prematurely: SV 0x%"UVxf
6327                          pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6328                 continue;
6329             }
6330 #endif
6331             if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6332                 /* make sure SvREFCNT(sv)==0 happens very seldom */
6333                 SvREFCNT(sv) = (~(U32)0)/2;
6334                 continue;
6335             }
6336             break;
6337         } /* while 1 */
6338
6339     } /* while sv */
6340 }
6341
6342 /* This routine curses the sv itself, not the object referenced by sv. So
6343    sv does not have to be ROK. */
6344
6345 static bool
6346 S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
6347     dVAR;
6348
6349     PERL_ARGS_ASSERT_CURSE;
6350     assert(SvOBJECT(sv));
6351
6352     if (PL_defstash &&  /* Still have a symbol table? */
6353         SvDESTROYABLE(sv))
6354     {
6355         dSP;
6356         HV* stash;
6357         do {
6358             CV* destructor;
6359             stash = SvSTASH(sv);
6360             destructor = StashHANDLER(stash,DESTROY);
6361             if (destructor
6362                 /* A constant subroutine can have no side effects, so
6363                    don't bother calling it.  */
6364                 && !CvCONST(destructor)
6365                 /* Don't bother calling an empty destructor */
6366                 && (CvISXSUB(destructor)
6367                 || (CvSTART(destructor)
6368                     && (CvSTART(destructor)->op_next->op_type
6369                                         != OP_LEAVESUB))))
6370             {
6371                 SV* const tmpref = newRV(sv);
6372                 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
6373                 ENTER;
6374                 PUSHSTACKi(PERLSI_DESTROY);
6375                 EXTEND(SP, 2);
6376                 PUSHMARK(SP);
6377                 PUSHs(tmpref);
6378                 PUTBACK;
6379                 call_sv(MUTABLE_SV(destructor),
6380                             G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6381                 POPSTACK;
6382                 SPAGAIN;
6383                 LEAVE;
6384                 if(SvREFCNT(tmpref) < 2) {
6385                     /* tmpref is not kept alive! */
6386                     SvREFCNT(sv)--;
6387                     SvRV_set(tmpref, NULL);
6388                     SvROK_off(tmpref);
6389                 }
6390                 SvREFCNT_dec(tmpref);
6391             }
6392         } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
6393
6394
6395         if (check_refcnt && SvREFCNT(sv)) {
6396             if (PL_in_clean_objs)
6397                 Perl_croak(aTHX_
6398                     "DESTROY created new reference to dead object '%s'",
6399                     HvNAME_get(stash));
6400             /* DESTROY gave object new lease on life */
6401             return FALSE;
6402         }
6403     }
6404
6405     if (SvOBJECT(sv)) {
6406         SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
6407         SvOBJECT_off(sv);       /* Curse the object. */
6408         if (SvTYPE(sv) != SVt_PVIO)
6409             --PL_sv_objcount;/* XXX Might want something more general */
6410     }
6411     return TRUE;
6412 }
6413
6414 /*
6415 =for apidoc sv_newref
6416
6417 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6418 instead.
6419
6420 =cut
6421 */
6422
6423 SV *
6424 Perl_sv_newref(pTHX_ SV *const sv)
6425 {
6426     PERL_UNUSED_CONTEXT;
6427     if (sv)
6428         (SvREFCNT(sv))++;
6429     return sv;
6430 }
6431
6432 /*
6433 =for apidoc sv_free
6434
6435 Decrement an SV's reference count, and if it drops to zero, call
6436 C<sv_clear> to invoke destructors and free up any memory used by
6437 the body; finally, deallocate the SV's head itself.
6438 Normally called via a wrapper macro C<SvREFCNT_dec>.
6439
6440 =cut
6441 */
6442
6443 void
6444 Perl_sv_free(pTHX_ SV *const sv)
6445 {
6446     dVAR;
6447     if (!sv)
6448         return;
6449     if (SvREFCNT(sv) == 0) {
6450         if (SvFLAGS(sv) & SVf_BREAK)
6451             /* this SV's refcnt has been artificially decremented to
6452              * trigger cleanup */
6453             return;
6454         if (PL_in_clean_all) /* All is fair */
6455             return;
6456         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6457             /* make sure SvREFCNT(sv)==0 happens very seldom */
6458             SvREFCNT(sv) = (~(U32)0)/2;
6459             return;
6460         }
6461         if (ckWARN_d(WARN_INTERNAL)) {
6462 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6463             Perl_dump_sv_child(aTHX_ sv);
6464 #else
6465   #ifdef DEBUG_LEAKING_SCALARS
6466             sv_dump(sv);
6467   #endif
6468 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6469             if (PL_warnhook == PERL_WARNHOOK_FATAL
6470                 || ckDEAD(packWARN(WARN_INTERNAL))) {
6471                 /* Don't let Perl_warner cause us to escape our fate:  */
6472                 abort();
6473             }
6474 #endif
6475             /* This may not return:  */
6476             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6477                         "Attempt to free unreferenced scalar: SV 0x%"UVxf
6478                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6479 #endif
6480         }
6481 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6482         abort();
6483 #endif
6484         return;
6485     }
6486     if (--(SvREFCNT(sv)) > 0)
6487         return;
6488     Perl_sv_free2(aTHX_ sv);
6489 }
6490
6491 void
6492 Perl_sv_free2(pTHX_ SV *const sv)
6493 {
6494     dVAR;
6495
6496     PERL_ARGS_ASSERT_SV_FREE2;
6497
6498 #ifdef DEBUGGING
6499     if (SvTEMP(sv)) {
6500         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6501                          "Attempt to free temp prematurely: SV 0x%"UVxf
6502                          pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6503         return;
6504     }
6505 #endif
6506     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6507         /* make sure SvREFCNT(sv)==0 happens very seldom */
6508         SvREFCNT(sv) = (~(U32)0)/2;
6509         return;
6510     }
6511     sv_clear(sv);
6512     if (! SvREFCNT(sv))
6513         del_SV(sv);
6514 }
6515
6516 /*
6517 =for apidoc sv_len
6518
6519 Returns the length of the string in the SV. Handles magic and type
6520 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6521
6522 =cut
6523 */
6524
6525 STRLEN
6526 Perl_sv_len(pTHX_ register SV *const sv)
6527 {
6528     STRLEN len;
6529
6530     if (!sv)
6531         return 0;
6532
6533     if (SvGMAGICAL(sv))
6534         len = mg_length(sv);
6535     else
6536         (void)SvPV_const(sv, len);
6537     return len;
6538 }
6539
6540 /*
6541 =for apidoc sv_len_utf8
6542
6543 Returns the number of characters in the string in an SV, counting wide
6544 UTF-8 bytes as a single character. Handles magic and type coercion.
6545
6546 =cut
6547 */
6548
6549 /*
6550  * The length is cached in PERL_MAGIC_utf8, in the mg_len field.  Also the
6551  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6552  * (Note that the mg_len is not the length of the mg_ptr field.
6553  * This allows the cache to store the character length of the string without
6554  * needing to malloc() extra storage to attach to the mg_ptr.)
6555  *
6556  */
6557
6558 STRLEN
6559 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6560 {
6561     if (!sv)
6562         return 0;
6563
6564     if (SvGMAGICAL(sv))
6565         return mg_length(sv);
6566     else
6567     {
6568         STRLEN len;
6569         const U8 *s = (U8*)SvPV_const(sv, len);
6570
6571         if (PL_utf8cache) {
6572             STRLEN ulen;
6573             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6574
6575             if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6576                 if (mg->mg_len != -1)
6577                     ulen = mg->mg_len;
6578                 else {
6579                     /* We can use the offset cache for a headstart.
6580                        The longer value is stored in the first pair.  */
6581                     STRLEN *cache = (STRLEN *) mg->mg_ptr;
6582
6583                     ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6584                                                        s + len);
6585                 }
6586
6587                 if (PL_utf8cache < 0) {
6588                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6589                     assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6590                 }
6591             }
6592             else {
6593                 ulen = Perl_utf8_length(aTHX_ s, s + len);
6594                 utf8_mg_len_cache_update(sv, &mg, ulen);
6595             }
6596             return ulen;
6597         }
6598         return Perl_utf8_length(aTHX_ s, s + len);
6599     }
6600 }
6601
6602 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6603    offset.  */
6604 static STRLEN
6605 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6606                       STRLEN *const uoffset_p, bool *const at_end)
6607 {
6608     const U8 *s = start;
6609     STRLEN uoffset = *uoffset_p;
6610
6611     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6612
6613     while (s < send && uoffset) {
6614         --uoffset;
6615         s += UTF8SKIP(s);
6616     }
6617     if (s == send) {
6618         *at_end = TRUE;
6619     }
6620     else if (s > send) {
6621         *at_end = TRUE;
6622         /* This is the existing behaviour. Possibly it should be a croak, as
6623            it's actually a bounds error  */
6624         s = send;
6625     }
6626     *uoffset_p -= uoffset;
6627     return s - start;
6628 }
6629
6630 /* Given the length of the string in both bytes and UTF-8 characters, decide
6631    whether to walk forwards or backwards to find the byte corresponding to
6632    the passed in UTF-8 offset.  */
6633 static STRLEN
6634 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6635                     STRLEN uoffset, const STRLEN uend)
6636 {
6637     STRLEN backw = uend - uoffset;
6638
6639     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6640
6641     if (uoffset < 2 * backw) {
6642         /* The assumption is that going forwards is twice the speed of going
6643            forward (that's where the 2 * backw comes from).
6644            (The real figure of course depends on the UTF-8 data.)  */
6645         const U8 *s = start;
6646
6647         while (s < send && uoffset--)
6648             s += UTF8SKIP(s);
6649         assert (s <= send);
6650         if (s > send)
6651             s = send;
6652         return s - start;
6653     }
6654
6655     while (backw--) {
6656         send--;
6657         while (UTF8_IS_CONTINUATION(*send))
6658             send--;
6659     }
6660     return send - start;
6661 }
6662
6663 /* For the string representation of the given scalar, find the byte
6664    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
6665    give another position in the string, *before* the sought offset, which
6666    (which is always true, as 0, 0 is a valid pair of positions), which should
6667    help reduce the amount of linear searching.
6668    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6669    will be used to reduce the amount of linear searching. The cache will be
6670    created if necessary, and the found value offered to it for update.  */
6671 static STRLEN
6672 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6673                     const U8 *const send, STRLEN uoffset,
6674                     STRLEN uoffset0, STRLEN boffset0)
6675 {
6676     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
6677     bool found = FALSE;
6678     bool at_end = FALSE;
6679
6680     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6681
6682     assert (uoffset >= uoffset0);
6683
6684     if (!uoffset)
6685         return 0;
6686
6687     if (!SvREADONLY(sv)
6688         && PL_utf8cache
6689         && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6690                      (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6691         if ((*mgp)->mg_ptr) {
6692             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6693             if (cache[0] == uoffset) {
6694                 /* An exact match. */
6695                 return cache[1];
6696             }
6697             if (cache[2] == uoffset) {
6698                 /* An exact match. */
6699                 return cache[3];
6700             }
6701
6702             if (cache[0] < uoffset) {
6703                 /* The cache already knows part of the way.   */
6704                 if (cache[0] > uoffset0) {
6705                     /* The cache knows more than the passed in pair  */
6706                     uoffset0 = cache[0];
6707                     boffset0 = cache[1];
6708                 }
6709                 if ((*mgp)->mg_len != -1) {
6710                     /* And we know the end too.  */
6711                     boffset = boffset0
6712                         + sv_pos_u2b_midway(start + boffset0, send,
6713                                               uoffset - uoffset0,
6714                                               (*mgp)->mg_len - uoffset0);
6715                 } else {
6716                     uoffset -= uoffset0;
6717                     boffset = boffset0
6718                         + sv_pos_u2b_forwards(start + boffset0,
6719                                               send, &uoffset, &at_end);
6720                     uoffset += uoffset0;
6721                 }
6722             }
6723             else if (cache[2] < uoffset) {
6724                 /* We're between the two cache entries.  */
6725                 if (cache[2] > uoffset0) {
6726                     /* and the cache knows more than the passed in pair  */
6727                     uoffset0 = cache[2];
6728                     boffset0 = cache[3];
6729                 }
6730
6731                 boffset = boffset0
6732                     + sv_pos_u2b_midway(start + boffset0,
6733                                           start + cache[1],
6734                                           uoffset - uoffset0,
6735                                           cache[0] - uoffset0);
6736             } else {
6737                 boffset = boffset0
6738                     + sv_pos_u2b_midway(start + boffset0,
6739                                           start + cache[3],
6740                                           uoffset - uoffset0,
6741                                           cache[2] - uoffset0);
6742             }
6743             found = TRUE;
6744         }
6745         else if ((*mgp)->mg_len != -1) {
6746             /* If we can take advantage of a passed in offset, do so.  */
6747             /* In fact, offset0 is either 0, or less than offset, so don't
6748                need to worry about the other possibility.  */
6749             boffset = boffset0
6750                 + sv_pos_u2b_midway(start + boffset0, send,
6751                                       uoffset - uoffset0,
6752                                       (*mgp)->mg_len - uoffset0);
6753             found = TRUE;
6754         }
6755     }
6756
6757     if (!found || PL_utf8cache < 0) {
6758         STRLEN real_boffset;
6759         uoffset -= uoffset0;
6760         real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6761                                                       send, &uoffset, &at_end);
6762         uoffset += uoffset0;
6763
6764         if (found && PL_utf8cache < 0)
6765             assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6766                                        real_boffset, sv);
6767         boffset = real_boffset;
6768     }
6769
6770     if (PL_utf8cache) {
6771         if (at_end)
6772             utf8_mg_len_cache_update(sv, mgp, uoffset);
6773         else
6774             utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6775     }
6776     return boffset;
6777 }
6778
6779
6780 /*
6781 =for apidoc sv_pos_u2b_flags
6782
6783 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6784 the start of the string, to a count of the equivalent number of bytes; if
6785 lenp is non-zero, it does the same to lenp, but this time starting from
6786 the offset, rather than from the start of the string. Handles type coercion.
6787 I<flags> is passed to C<SvPV_flags>, and usually should be
6788 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6789
6790 =cut
6791 */
6792
6793 /*
6794  * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6795  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6796  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6797  *
6798  */
6799
6800 STRLEN
6801 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6802                       U32 flags)
6803 {
6804     const U8 *start;
6805     STRLEN len;
6806     STRLEN boffset;
6807
6808     PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6809
6810     start = (U8*)SvPV_flags(sv, len, flags);
6811     if (len) {
6812         const U8 * const send = start + len;
6813         MAGIC *mg = NULL;
6814         boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6815
6816         if (lenp
6817             && *lenp /* don't bother doing work for 0, as its bytes equivalent
6818                         is 0, and *lenp is already set to that.  */) {
6819             /* Convert the relative offset to absolute.  */
6820             const STRLEN uoffset2 = uoffset + *lenp;
6821             const STRLEN boffset2
6822                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6823                                       uoffset, boffset) - boffset;
6824
6825             *lenp = boffset2;
6826         }
6827     } else {
6828         if (lenp)
6829             *lenp = 0;
6830         boffset = 0;
6831     }
6832
6833     return boffset;
6834 }
6835
6836 /*
6837 =for apidoc sv_pos_u2b
6838
6839 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6840 the start of the string, to a count of the equivalent number of bytes; if
6841 lenp is non-zero, it does the same to lenp, but this time starting from
6842 the offset, rather than from the start of the string. Handles magic and
6843 type coercion.
6844
6845 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6846 than 2Gb.
6847
6848 =cut
6849 */
6850
6851 /*
6852  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6853  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6854  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6855  *
6856  */
6857
6858 /* This function is subject to size and sign problems */
6859
6860 void
6861 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6862 {
6863     PERL_ARGS_ASSERT_SV_POS_U2B;
6864
6865     if (lenp) {
6866         STRLEN ulen = (STRLEN)*lenp;
6867         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6868                                          SV_GMAGIC|SV_CONST_RETURN);
6869         *lenp = (I32)ulen;
6870     } else {
6871         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6872                                          SV_GMAGIC|SV_CONST_RETURN);
6873     }
6874 }
6875
6876 static void
6877 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6878                            const STRLEN ulen)
6879 {
6880     PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6881     if (SvREADONLY(sv))
6882         return;
6883
6884     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6885                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6886         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6887     }
6888     assert(*mgp);
6889
6890     (*mgp)->mg_len = ulen;
6891     /* For now, treat "overflowed" as "still unknown". See RT #72924.  */
6892     if (ulen != (STRLEN) (*mgp)->mg_len)
6893         (*mgp)->mg_len = -1;
6894 }
6895
6896 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6897    byte length pairing. The (byte) length of the total SV is passed in too,
6898    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6899    may not have updated SvCUR, so we can't rely on reading it directly.
6900
6901    The proffered utf8/byte length pairing isn't used if the cache already has
6902    two pairs, and swapping either for the proffered pair would increase the
6903    RMS of the intervals between known byte offsets.
6904
6905    The cache itself consists of 4 STRLEN values
6906    0: larger UTF-8 offset
6907    1: corresponding byte offset
6908    2: smaller UTF-8 offset
6909    3: corresponding byte offset
6910
6911    Unused cache pairs have the value 0, 0.
6912    Keeping the cache "backwards" means that the invariant of
6913    cache[0] >= cache[2] is maintained even with empty slots, which means that
6914    the code that uses it doesn't need to worry if only 1 entry has actually
6915    been set to non-zero.  It also makes the "position beyond the end of the
6916    cache" logic much simpler, as the first slot is always the one to start
6917    from.
6918 */
6919 static void
6920 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6921                            const STRLEN utf8, const STRLEN blen)
6922 {
6923     STRLEN *cache;
6924
6925     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6926
6927     if (SvREADONLY(sv))
6928         return;
6929
6930     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6931                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6932         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6933                            0);
6934         (*mgp)->mg_len = -1;
6935     }
6936     assert(*mgp);
6937
6938     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6939         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6940         (*mgp)->mg_ptr = (char *) cache;
6941     }
6942     assert(cache);
6943
6944     if (PL_utf8cache < 0 && SvPOKp(sv)) {
6945         /* SvPOKp() because it's possible that sv has string overloading, and
6946            therefore is a reference, hence SvPVX() is actually a pointer.
6947            This cures the (very real) symptoms of RT 69422, but I'm not actually
6948            sure whether we should even be caching the results of UTF-8
6949            operations on overloading, given that nothing stops overloading
6950            returning a different value every time it's called.  */
6951         const U8 *start = (const U8 *) SvPVX_const(sv);
6952         const STRLEN realutf8 = utf8_length(start, start + byte);
6953
6954         assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6955                                    sv);
6956     }
6957
6958     /* Cache is held with the later position first, to simplify the code
6959        that deals with unbounded ends.  */
6960
6961     ASSERT_UTF8_CACHE(cache);
6962     if (cache[1] == 0) {
6963         /* Cache is totally empty  */
6964         cache[0] = utf8;
6965         cache[1] = byte;
6966     } else if (cache[3] == 0) {
6967         if (byte > cache[1]) {
6968             /* New one is larger, so goes first.  */
6969             cache[2] = cache[0];
6970             cache[3] = cache[1];
6971             cache[0] = utf8;
6972             cache[1] = byte;
6973         } else {
6974             cache[2] = utf8;
6975             cache[3] = byte;
6976         }
6977     } else {
6978 #define THREEWAY_SQUARE(a,b,c,d) \
6979             ((float)((d) - (c))) * ((float)((d) - (c))) \
6980             + ((float)((c) - (b))) * ((float)((c) - (b))) \
6981                + ((float)((b) - (a))) * ((float)((b) - (a)))
6982
6983         /* Cache has 2 slots in use, and we know three potential pairs.
6984            Keep the two that give the lowest RMS distance. Do the
6985            calculation in bytes simply because we always know the byte
6986            length.  squareroot has the same ordering as the positive value,
6987            so don't bother with the actual square root.  */
6988         const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6989         if (byte > cache[1]) {
6990             /* New position is after the existing pair of pairs.  */
6991             const float keep_earlier
6992                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6993             const float keep_later
6994                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6995
6996             if (keep_later < keep_earlier) {
6997                 if (keep_later < existing) {
6998                     cache[2] = cache[0];
6999                     cache[3] = cache[1];
7000                     cache[0] = utf8;
7001                     cache[1] = byte;
7002                 }
7003             }
7004             else {
7005                 if (keep_earlier < existing) {
7006                     cache[0] = utf8;
7007                     cache[1] = byte;
7008                 }
7009             }
7010         }
7011         else if (byte > cache[3]) {
7012             /* New position is between the existing pair of pairs.  */
7013             const float keep_earlier
7014                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
7015             const float keep_later
7016                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7017
7018             if (keep_later < keep_earlier) {
7019                 if (keep_later < existing) {
7020                     cache[2] = utf8;
7021                     cache[3] = byte;
7022                 }
7023             }
7024             else {
7025                 if (keep_earlier < existing) {
7026                     cache[0] = utf8;
7027                     cache[1] = byte;
7028                 }
7029             }
7030         }
7031         else {
7032             /* New position is before the existing pair of pairs.  */
7033             const float keep_earlier
7034                 = THREEWAY_SQUARE(0, byte, cache[3], blen);
7035             const float keep_later
7036                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7037
7038             if (keep_later < keep_earlier) {
7039                 if (keep_later < existing) {
7040                     cache[2] = utf8;
7041                     cache[3] = byte;
7042                 }
7043             }
7044             else {
7045                 if (keep_earlier < existing) {
7046                     cache[0] = cache[2];
7047                     cache[1] = cache[3];
7048                     cache[2] = utf8;
7049                     cache[3] = byte;
7050                 }
7051             }
7052         }
7053     }
7054     ASSERT_UTF8_CACHE(cache);
7055 }
7056
7057 /* We already know all of the way, now we may be able to walk back.  The same
7058    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
7059    backward is half the speed of walking forward. */
7060 static STRLEN
7061 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
7062                     const U8 *end, STRLEN endu)
7063 {
7064     const STRLEN forw = target - s;
7065     STRLEN backw = end - target;
7066
7067     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
7068
7069     if (forw < 2 * backw) {
7070         return utf8_length(s, target);
7071     }
7072
7073     while (end > target) {
7074         end--;
7075         while (UTF8_IS_CONTINUATION(*end)) {
7076             end--;
7077         }
7078         endu--;
7079     }
7080     return endu;
7081 }
7082
7083 /*
7084 =for apidoc sv_pos_b2u
7085
7086 Converts the value pointed to by offsetp from a count of bytes from the
7087 start of the string, to a count of the equivalent number of UTF-8 chars.
7088 Handles magic and type coercion.
7089
7090 =cut
7091 */
7092
7093 /*
7094  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
7095  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7096  * byte offsets.
7097  *
7098  */
7099 void
7100 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
7101 {
7102     const U8* s;
7103     const STRLEN byte = *offsetp;
7104     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
7105     STRLEN blen;
7106     MAGIC* mg = NULL;
7107     const U8* send;
7108     bool found = FALSE;
7109
7110     PERL_ARGS_ASSERT_SV_POS_B2U;
7111
7112     if (!sv)
7113         return;
7114
7115     s = (const U8*)SvPV_const(sv, blen);
7116
7117     if (blen < byte)
7118         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
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     char *tpv   = NULL;
7235     SV* svrecode = NULL;
7236
7237     if (!sv1) {
7238         pv1 = "";
7239         cur1 = 0;
7240     }
7241     else {
7242         /* if pv1 and pv2 are the same, second SvPV_const call may
7243          * invalidate pv1 (if we are handling magic), so we may need to
7244          * make a copy */
7245         if (sv1 == sv2 && flags & SV_GMAGIC
7246          && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7247             pv1 = SvPV_const(sv1, cur1);
7248             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7249         }
7250         pv1 = SvPV_flags_const(sv1, cur1, flags);
7251     }
7252
7253     if (!sv2){
7254         pv2 = "";
7255         cur2 = 0;
7256     }
7257     else
7258         pv2 = SvPV_flags_const(sv2, cur2, flags);
7259
7260     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7261         /* Differing utf8ness.
7262          * Do not UTF8size the comparands as a side-effect. */
7263          if (PL_encoding) {
7264               if (SvUTF8(sv1)) {
7265                    svrecode = newSVpvn(pv2, cur2);
7266                    sv_recode_to_utf8(svrecode, PL_encoding);
7267                    pv2 = SvPV_const(svrecode, cur2);
7268               }
7269               else {
7270                    svrecode = newSVpvn(pv1, cur1);
7271                    sv_recode_to_utf8(svrecode, PL_encoding);
7272                    pv1 = SvPV_const(svrecode, cur1);
7273               }
7274               /* Now both are in UTF-8. */
7275               if (cur1 != cur2) {
7276                    SvREFCNT_dec(svrecode);
7277                    return FALSE;
7278               }
7279          }
7280          else {
7281               if (SvUTF8(sv1)) {
7282                   /* sv1 is the UTF-8 one  */
7283                   return bytes_cmp_utf8((const U8*)pv2, cur2,
7284                                         (const U8*)pv1, cur1) == 0;
7285               }
7286               else {
7287                   /* sv2 is the UTF-8 one  */
7288                   return bytes_cmp_utf8((const U8*)pv1, cur1,
7289                                         (const U8*)pv2, cur2) == 0;
7290               }
7291          }
7292     }
7293
7294     if (cur1 == cur2)
7295         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7296
7297     SvREFCNT_dec(svrecode);
7298     if (tpv)
7299         Safefree(tpv);
7300
7301     return eq;
7302 }
7303
7304 /*
7305 =for apidoc sv_cmp
7306
7307 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
7308 string in C<sv1> is less than, equal to, or greater than the string in
7309 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7310 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
7311
7312 =for apidoc sv_cmp_flags
7313
7314 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
7315 string in C<sv1> is less than, equal to, or greater than the string in
7316 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7317 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7318 also C<sv_cmp_locale_flags>.
7319
7320 =cut
7321 */
7322
7323 I32
7324 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
7325 {
7326     return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7327 }
7328
7329 I32
7330 Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7331                   const U32 flags)
7332 {
7333     dVAR;
7334     STRLEN cur1, cur2;
7335     const char *pv1, *pv2;
7336     char *tpv = NULL;
7337     I32  cmp;
7338     SV *svrecode = NULL;
7339
7340     if (!sv1) {
7341         pv1 = "";
7342         cur1 = 0;
7343     }
7344     else
7345         pv1 = SvPV_flags_const(sv1, cur1, flags);
7346
7347     if (!sv2) {
7348         pv2 = "";
7349         cur2 = 0;
7350     }
7351     else
7352         pv2 = SvPV_flags_const(sv2, cur2, flags);
7353
7354     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7355         /* Differing utf8ness.
7356          * Do not UTF8size the comparands as a side-effect. */
7357         if (SvUTF8(sv1)) {
7358             if (PL_encoding) {
7359                  svrecode = newSVpvn(pv2, cur2);
7360                  sv_recode_to_utf8(svrecode, PL_encoding);
7361                  pv2 = SvPV_const(svrecode, cur2);
7362             }
7363             else {
7364                 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7365                                                    (const U8*)pv1, cur1);
7366                 return retval ? retval < 0 ? -1 : +1 : 0;
7367             }
7368         }
7369         else {
7370             if (PL_encoding) {
7371                  svrecode = newSVpvn(pv1, cur1);
7372                  sv_recode_to_utf8(svrecode, PL_encoding);
7373                  pv1 = SvPV_const(svrecode, cur1);
7374             }
7375             else {
7376                 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7377                                                   (const U8*)pv2, cur2);
7378                 return retval ? retval < 0 ? -1 : +1 : 0;
7379             }
7380         }
7381     }
7382
7383     if (!cur1) {
7384         cmp = cur2 ? -1 : 0;
7385     } else if (!cur2) {
7386         cmp = 1;
7387     } else {
7388         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7389
7390         if (retval) {
7391             cmp = retval < 0 ? -1 : 1;
7392         } else if (cur1 == cur2) {
7393             cmp = 0;
7394         } else {
7395             cmp = cur1 < cur2 ? -1 : 1;
7396         }
7397     }
7398
7399     SvREFCNT_dec(svrecode);
7400     if (tpv)
7401         Safefree(tpv);
7402
7403     return cmp;
7404 }
7405
7406 /*
7407 =for apidoc sv_cmp_locale
7408
7409 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7410 'use bytes' aware, handles get magic, and will coerce its args to strings
7411 if necessary.  See also C<sv_cmp>.
7412
7413 =for apidoc sv_cmp_locale_flags
7414
7415 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7416 'use bytes' aware and will coerce its args to strings if necessary. If the
7417 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7418
7419 =cut
7420 */
7421
7422 I32
7423 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
7424 {
7425     return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7426 }
7427
7428 I32
7429 Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7430                          const U32 flags)
7431 {
7432     dVAR;
7433 #ifdef USE_LOCALE_COLLATE
7434
7435     char *pv1, *pv2;
7436     STRLEN len1, len2;
7437     I32 retval;
7438
7439     if (PL_collation_standard)
7440         goto raw_compare;
7441
7442     len1 = 0;
7443     pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7444     len2 = 0;
7445     pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7446
7447     if (!pv1 || !len1) {
7448         if (pv2 && len2)
7449             return -1;
7450         else
7451             goto raw_compare;
7452     }
7453     else {
7454         if (!pv2 || !len2)
7455             return 1;
7456     }
7457
7458     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7459
7460     if (retval)
7461         return retval < 0 ? -1 : 1;
7462
7463     /*
7464      * When the result of collation is equality, that doesn't mean
7465      * that there are no differences -- some locales exclude some
7466      * characters from consideration.  So to avoid false equalities,
7467      * we use the raw string as a tiebreaker.
7468      */
7469
7470   raw_compare:
7471     /*FALLTHROUGH*/
7472
7473 #endif /* USE_LOCALE_COLLATE */
7474
7475     return sv_cmp(sv1, sv2);
7476 }
7477
7478
7479 #ifdef USE_LOCALE_COLLATE
7480
7481 /*
7482 =for apidoc sv_collxfrm
7483
7484 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7485 C<sv_collxfrm_flags>.
7486
7487 =for apidoc sv_collxfrm_flags
7488
7489 Add Collate Transform magic to an SV if it doesn't already have it. If the
7490 flags contain SV_GMAGIC, it handles get-magic.
7491
7492 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7493 scalar data of the variable, but transformed to such a format that a normal
7494 memory comparison can be used to compare the data according to the locale
7495 settings.
7496
7497 =cut
7498 */
7499
7500 char *
7501 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7502 {
7503     dVAR;
7504     MAGIC *mg;
7505
7506     PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7507
7508     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7509     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7510         const char *s;
7511         char *xf;
7512         STRLEN len, xlen;
7513
7514         if (mg)
7515             Safefree(mg->mg_ptr);
7516         s = SvPV_flags_const(sv, len, flags);
7517         if ((xf = mem_collxfrm(s, len, &xlen))) {
7518             if (! mg) {
7519 #ifdef PERL_OLD_COPY_ON_WRITE
7520                 if (SvIsCOW(sv))
7521                     sv_force_normal_flags(sv, 0);
7522 #endif
7523                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7524                                  0, 0);
7525                 assert(mg);
7526             }
7527             mg->mg_ptr = xf;
7528             mg->mg_len = xlen;
7529         }
7530         else {
7531             if (mg) {
7532                 mg->mg_ptr = NULL;
7533                 mg->mg_len = -1;
7534             }
7535         }
7536     }
7537     if (mg && mg->mg_ptr) {
7538         *nxp = mg->mg_len;
7539         return mg->mg_ptr + sizeof(PL_collation_ix);
7540     }
7541     else {
7542         *nxp = 0;
7543         return NULL;
7544     }
7545 }
7546
7547 #endif /* USE_LOCALE_COLLATE */
7548
7549 static char *
7550 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7551 {
7552     SV * const tsv = newSV(0);
7553     ENTER;
7554     SAVEFREESV(tsv);
7555     sv_gets(tsv, fp, 0);
7556     sv_utf8_upgrade_nomg(tsv);
7557     SvCUR_set(sv,append);
7558     sv_catsv(sv,tsv);
7559     LEAVE;
7560     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7561 }
7562
7563 static char *
7564 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7565 {
7566     I32 bytesread;
7567     const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7568       /* Grab the size of the record we're getting */
7569     char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7570 #ifdef VMS
7571     int fd;
7572 #endif
7573
7574     /* Go yank in */
7575 #ifdef VMS
7576     /* VMS wants read instead of fread, because fread doesn't respect */
7577     /* RMS record boundaries. This is not necessarily a good thing to be */
7578     /* doing, but we've got no other real choice - except avoid stdio
7579        as implementation - perhaps write a :vms layer ?
7580     */
7581     fd = PerlIO_fileno(fp);
7582     if (fd != -1) {
7583         bytesread = PerlLIO_read(fd, buffer, recsize);
7584     }
7585     else /* in-memory file from PerlIO::Scalar */
7586 #endif
7587     {
7588         bytesread = PerlIO_read(fp, buffer, recsize);
7589     }
7590
7591     if (bytesread < 0)
7592         bytesread = 0;
7593     SvCUR_set(sv, bytesread + append);
7594     buffer[bytesread] = '\0';
7595     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7596 }
7597
7598 /*
7599 =for apidoc sv_gets
7600
7601 Get a line from the filehandle and store it into the SV, optionally
7602 appending to the currently-stored string.
7603
7604 =cut
7605 */
7606
7607 char *
7608 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7609 {
7610     dVAR;
7611     const char *rsptr;
7612     STRLEN rslen;
7613     register STDCHAR rslast;
7614     register STDCHAR *bp;
7615     register I32 cnt;
7616     I32 i = 0;
7617     I32 rspara = 0;
7618
7619     PERL_ARGS_ASSERT_SV_GETS;
7620
7621     if (SvTHINKFIRST(sv))
7622         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7623     /* XXX. If you make this PVIV, then copy on write can copy scalars read
7624        from <>.
7625        However, perlbench says it's slower, because the existing swipe code
7626        is faster than copy on write.
7627        Swings and roundabouts.  */
7628     SvUPGRADE(sv, SVt_PV);
7629
7630     SvSCREAM_off(sv);
7631
7632     if (append) {
7633         if (PerlIO_isutf8(fp)) {
7634             if (!SvUTF8(sv)) {
7635                 sv_utf8_upgrade_nomg(sv);
7636                 sv_pos_u2b(sv,&append,0);
7637             }
7638         } else if (SvUTF8(sv)) {
7639             return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
7640         }
7641     }
7642
7643     SvPOK_only(sv);
7644     if (!append) {
7645         SvCUR_set(sv,0);
7646     }
7647     if (PerlIO_isutf8(fp))
7648         SvUTF8_on(sv);
7649
7650     if (IN_PERL_COMPILETIME) {
7651         /* we always read code in line mode */
7652         rsptr = "\n";
7653         rslen = 1;
7654     }
7655     else if (RsSNARF(PL_rs)) {
7656         /* If it is a regular disk file use size from stat() as estimate
7657            of amount we are going to read -- may result in mallocing
7658            more memory than we really need if the layers below reduce
7659            the size we read (e.g. CRLF or a gzip layer).
7660          */
7661         Stat_t st;
7662         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
7663             const Off_t offset = PerlIO_tell(fp);
7664             if (offset != (Off_t) -1 && st.st_size + append > offset) {
7665                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7666             }
7667         }
7668         rsptr = NULL;
7669         rslen = 0;
7670     }
7671     else if (RsRECORD(PL_rs)) {
7672         return S_sv_gets_read_record(aTHX_ sv, fp, append);
7673     }
7674     else if (RsPARA(PL_rs)) {
7675         rsptr = "\n\n";
7676         rslen = 2;
7677         rspara = 1;
7678     }
7679     else {
7680         /* Get $/ i.e. PL_rs into same encoding as stream wants */
7681         if (PerlIO_isutf8(fp)) {
7682             rsptr = SvPVutf8(PL_rs, rslen);
7683         }
7684         else {
7685             if (SvUTF8(PL_rs)) {
7686                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7687                     Perl_croak(aTHX_ "Wide character in $/");
7688                 }
7689             }
7690             rsptr = SvPV_const(PL_rs, rslen);
7691         }
7692     }
7693
7694     rslast = rslen ? rsptr[rslen - 1] : '\0';
7695
7696     if (rspara) {               /* have to do this both before and after */
7697         do {                    /* to make sure file boundaries work right */
7698             if (PerlIO_eof(fp))
7699                 return 0;
7700             i = PerlIO_getc(fp);
7701             if (i != '\n') {
7702                 if (i == -1)
7703                     return 0;
7704                 PerlIO_ungetc(fp,i);
7705                 break;
7706             }
7707         } while (i != EOF);
7708     }
7709
7710     /* See if we know enough about I/O mechanism to cheat it ! */
7711
7712     /* This used to be #ifdef test - it is made run-time test for ease
7713        of abstracting out stdio interface. One call should be cheap
7714        enough here - and may even be a macro allowing compile
7715        time optimization.
7716      */
7717
7718     if (PerlIO_fast_gets(fp)) {
7719
7720     /*
7721      * We're going to steal some values from the stdio struct
7722      * and put EVERYTHING in the innermost loop into registers.
7723      */
7724     register STDCHAR *ptr;
7725     STRLEN bpx;
7726     I32 shortbuffered;
7727
7728 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7729     /* An ungetc()d char is handled separately from the regular
7730      * buffer, so we getc() it back out and stuff it in the buffer.
7731      */
7732     i = PerlIO_getc(fp);
7733     if (i == EOF) return 0;
7734     *(--((*fp)->_ptr)) = (unsigned char) i;
7735     (*fp)->_cnt++;
7736 #endif
7737
7738     /* Here is some breathtakingly efficient cheating */
7739
7740     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
7741     /* make sure we have the room */
7742     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7743         /* Not room for all of it
7744            if we are looking for a separator and room for some
7745          */
7746         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7747             /* just process what we have room for */
7748             shortbuffered = cnt - SvLEN(sv) + append + 1;
7749             cnt -= shortbuffered;
7750         }
7751         else {
7752             shortbuffered = 0;
7753             /* remember that cnt can be negative */
7754             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7755         }
7756     }
7757     else
7758         shortbuffered = 0;
7759     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
7760     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7761     DEBUG_P(PerlIO_printf(Perl_debug_log,
7762         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7763     DEBUG_P(PerlIO_printf(Perl_debug_log,
7764         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7765                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7766                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7767     for (;;) {
7768       screamer:
7769         if (cnt > 0) {
7770             if (rslen) {
7771                 while (cnt > 0) {                    /* this     |  eat */
7772                     cnt--;
7773                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
7774                         goto thats_all_folks;        /* screams  |  sed :-) */
7775                 }
7776             }
7777             else {
7778                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
7779                 bp += cnt;                           /* screams  |  dust */
7780                 ptr += cnt;                          /* louder   |  sed :-) */
7781                 cnt = 0;
7782                 assert (!shortbuffered);
7783                 goto cannot_be_shortbuffered;
7784             }
7785         }
7786
7787         if (shortbuffered) {            /* oh well, must extend */
7788             cnt = shortbuffered;
7789             shortbuffered = 0;
7790             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7791             SvCUR_set(sv, bpx);
7792             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7793             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7794             continue;
7795         }
7796
7797     cannot_be_shortbuffered:
7798         DEBUG_P(PerlIO_printf(Perl_debug_log,
7799                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7800                               PTR2UV(ptr),(long)cnt));
7801         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7802
7803         DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7804             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7805             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7806             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7807
7808         /* This used to call 'filbuf' in stdio form, but as that behaves like
7809            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7810            another abstraction.  */
7811         i   = PerlIO_getc(fp);          /* get more characters */
7812
7813         DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7814             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7815             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7816             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7817
7818         cnt = PerlIO_get_cnt(fp);
7819         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
7820         DEBUG_P(PerlIO_printf(Perl_debug_log,
7821             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7822
7823         if (i == EOF)                   /* all done for ever? */
7824             goto thats_really_all_folks;
7825
7826         bpx = bp - (STDCHAR*)SvPVX_const(sv);   /* box up before relocation */
7827         SvCUR_set(sv, bpx);
7828         SvGROW(sv, bpx + cnt + 2);
7829         bp = (STDCHAR*)SvPVX_const(sv) + bpx;   /* unbox after relocation */
7830
7831         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
7832
7833         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
7834             goto thats_all_folks;
7835     }
7836
7837 thats_all_folks:
7838     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7839           memNE((char*)bp - rslen, rsptr, rslen))
7840         goto screamer;                          /* go back to the fray */
7841 thats_really_all_folks:
7842     if (shortbuffered)
7843         cnt += shortbuffered;
7844         DEBUG_P(PerlIO_printf(Perl_debug_log,
7845             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7846     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
7847     DEBUG_P(PerlIO_printf(Perl_debug_log,
7848         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7849         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7850         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7851     *bp = '\0';
7852     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));      /* set length */
7853     DEBUG_P(PerlIO_printf(Perl_debug_log,
7854         "Screamer: done, len=%ld, string=|%.*s|\n",
7855         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7856     }
7857    else
7858     {
7859        /*The big, slow, and stupid way. */
7860 #ifdef USE_HEAP_INSTEAD_OF_STACK        /* Even slower way. */
7861         STDCHAR *buf = NULL;
7862         Newx(buf, 8192, STDCHAR);
7863         assert(buf);
7864 #else
7865         STDCHAR buf[8192];
7866 #endif
7867
7868 screamer2:
7869         if (rslen) {
7870             register const STDCHAR * const bpe = buf + sizeof(buf);
7871             bp = buf;
7872             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7873                 ; /* keep reading */
7874             cnt = bp - buf;
7875         }
7876         else {
7877             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7878             /* Accommodate broken VAXC compiler, which applies U8 cast to
7879              * both args of ?: operator, causing EOF to change into 255
7880              */
7881             if (cnt > 0)
7882                  i = (U8)buf[cnt - 1];
7883             else
7884                  i = EOF;
7885         }
7886
7887         if (cnt < 0)
7888             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
7889         if (append)
7890              sv_catpvn(sv, (char *) buf, cnt);
7891         else
7892              sv_setpvn(sv, (char *) buf, cnt);
7893
7894         if (i != EOF &&                 /* joy */
7895             (!rslen ||
7896              SvCUR(sv) < rslen ||
7897              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7898         {
7899             append = -1;
7900             /*
7901              * If we're reading from a TTY and we get a short read,
7902              * indicating that the user hit his EOF character, we need
7903              * to notice it now, because if we try to read from the TTY
7904              * again, the EOF condition will disappear.
7905              *
7906              * The comparison of cnt to sizeof(buf) is an optimization
7907              * that prevents unnecessary calls to feof().
7908              *
7909              * - jik 9/25/96
7910              */
7911             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7912                 goto screamer2;
7913         }
7914
7915 #ifdef USE_HEAP_INSTEAD_OF_STACK
7916         Safefree(buf);
7917 #endif
7918     }
7919
7920     if (rspara) {               /* have to do this both before and after */
7921         while (i != EOF) {      /* to make sure file boundaries work right */
7922             i = PerlIO_getc(fp);
7923             if (i != '\n') {
7924                 PerlIO_ungetc(fp,i);
7925                 break;
7926             }
7927         }
7928     }
7929
7930     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7931 }
7932
7933 /*
7934 =for apidoc sv_inc
7935
7936 Auto-increment of the value in the SV, doing string to numeric conversion
7937 if necessary. Handles 'get' magic and operator overloading.
7938
7939 =cut
7940 */
7941
7942 void
7943 Perl_sv_inc(pTHX_ register SV *const sv)
7944 {
7945     if (!sv)
7946         return;
7947     SvGETMAGIC(sv);
7948     sv_inc_nomg(sv);
7949 }
7950
7951 /*
7952 =for apidoc sv_inc_nomg
7953
7954 Auto-increment of the value in the SV, doing string to numeric conversion
7955 if necessary. Handles operator overloading. Skips handling 'get' magic.
7956
7957 =cut
7958 */
7959
7960 void
7961 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7962 {
7963     dVAR;
7964     register char *d;
7965     int flags;
7966
7967     if (!sv)
7968         return;
7969     if (SvTHINKFIRST(sv)) {
7970         if (SvIsCOW(sv))
7971             sv_force_normal_flags(sv, 0);
7972         if (SvREADONLY(sv)) {
7973             if (IN_PERL_RUNTIME)
7974                 Perl_croak_no_modify(aTHX);
7975         }
7976         if (SvROK(sv)) {
7977             IV i;
7978             if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
7979                 return;
7980             i = PTR2IV(SvRV(sv));
7981             sv_unref(sv);
7982             sv_setiv(sv, i);
7983         }
7984     }
7985     flags = SvFLAGS(sv);
7986     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7987         /* It's (privately or publicly) a float, but not tested as an
7988            integer, so test it to see. */
7989         (void) SvIV(sv);
7990         flags = SvFLAGS(sv);
7991     }
7992     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7993         /* It's publicly an integer, or privately an integer-not-float */
7994 #ifdef PERL_PRESERVE_IVUV
7995       oops_its_int:
7996 #endif
7997         if (SvIsUV(sv)) {
7998             if (SvUVX(sv) == UV_MAX)
7999                 sv_setnv(sv, UV_MAX_P1);
8000             else
8001                 (void)SvIOK_only_UV(sv);
8002                 SvUV_set(sv, SvUVX(sv) + 1);
8003         } else {
8004             if (SvIVX(sv) == IV_MAX)
8005                 sv_setuv(sv, (UV)IV_MAX + 1);
8006             else {
8007                 (void)SvIOK_only(sv);
8008                 SvIV_set(sv, SvIVX(sv) + 1);
8009             }
8010         }
8011         return;
8012     }
8013     if (flags & SVp_NOK) {
8014         const NV was = SvNVX(sv);
8015         if (NV_OVERFLOWS_INTEGERS_AT &&
8016             was >= NV_OVERFLOWS_INTEGERS_AT) {
8017             Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8018                            "Lost precision when incrementing %" NVff " by 1",
8019                            was);
8020         }
8021         (void)SvNOK_only(sv);
8022         SvNV_set(sv, was + 1.0);
8023         return;
8024     }
8025
8026     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
8027         if ((flags & SVTYPEMASK) < SVt_PVIV)
8028             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
8029         (void)SvIOK_only(sv);
8030         SvIV_set(sv, 1);
8031         return;
8032     }
8033     d = SvPVX(sv);
8034     while (isALPHA(*d)) d++;
8035     while (isDIGIT(*d)) d++;
8036     if (d < SvEND(sv)) {
8037 #ifdef PERL_PRESERVE_IVUV
8038         /* Got to punt this as an integer if needs be, but we don't issue
8039            warnings. Probably ought to make the sv_iv_please() that does
8040            the conversion if possible, and silently.  */
8041         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8042         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8043             /* Need to try really hard to see if it's an integer.
8044                9.22337203685478e+18 is an integer.
8045                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8046                so $a="9.22337203685478e+18"; $a+0; $a++
8047                needs to be the same as $a="9.22337203685478e+18"; $a++
8048                or we go insane. */
8049
8050             (void) sv_2iv(sv);
8051             if (SvIOK(sv))
8052                 goto oops_its_int;
8053
8054             /* sv_2iv *should* have made this an NV */
8055             if (flags & SVp_NOK) {
8056                 (void)SvNOK_only(sv);
8057                 SvNV_set(sv, SvNVX(sv) + 1.0);
8058                 return;
8059             }
8060             /* I don't think we can get here. Maybe I should assert this
8061                And if we do get here I suspect that sv_setnv will croak. NWC
8062                Fall through. */
8063 #if defined(USE_LONG_DOUBLE)
8064             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",
8065                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8066 #else
8067             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8068                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8069 #endif
8070         }
8071 #endif /* PERL_PRESERVE_IVUV */
8072         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
8073         return;
8074     }
8075     d--;
8076     while (d >= SvPVX_const(sv)) {
8077         if (isDIGIT(*d)) {
8078             if (++*d <= '9')
8079                 return;
8080             *(d--) = '0';
8081         }
8082         else {
8083 #ifdef EBCDIC
8084             /* MKS: The original code here died if letters weren't consecutive.
8085              * at least it didn't have to worry about non-C locales.  The
8086              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
8087              * arranged in order (although not consecutively) and that only
8088              * [A-Za-z] are accepted by isALPHA in the C locale.
8089              */
8090             if (*d != 'z' && *d != 'Z') {
8091                 do { ++*d; } while (!isALPHA(*d));
8092                 return;
8093             }
8094             *(d--) -= 'z' - 'a';
8095 #else
8096             ++*d;
8097             if (isALPHA(*d))
8098                 return;
8099             *(d--) -= 'z' - 'a' + 1;
8100 #endif
8101         }
8102     }
8103     /* oh,oh, the number grew */
8104     SvGROW(sv, SvCUR(sv) + 2);
8105     SvCUR_set(sv, SvCUR(sv) + 1);
8106     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
8107         *d = d[-1];
8108     if (isDIGIT(d[1]))
8109         *d = '1';
8110     else
8111         *d = d[1];
8112 }
8113
8114 /*
8115 =for apidoc sv_dec
8116
8117 Auto-decrement of the value in the SV, doing string to numeric conversion
8118 if necessary. Handles 'get' magic and operator overloading.
8119
8120 =cut
8121 */
8122
8123 void
8124 Perl_sv_dec(pTHX_ register SV *const sv)
8125 {
8126     dVAR;
8127     if (!sv)
8128         return;
8129     SvGETMAGIC(sv);
8130     sv_dec_nomg(sv);
8131 }
8132
8133 /*
8134 =for apidoc sv_dec_nomg
8135
8136 Auto-decrement of the value in the SV, doing string to numeric conversion
8137 if necessary. Handles operator overloading. Skips handling 'get' magic.
8138
8139 =cut
8140 */
8141
8142 void
8143 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
8144 {
8145     dVAR;
8146     int flags;
8147
8148     if (!sv)
8149         return;
8150     if (SvTHINKFIRST(sv)) {
8151         if (SvIsCOW(sv))
8152             sv_force_normal_flags(sv, 0);
8153         if (SvREADONLY(sv)) {
8154             if (IN_PERL_RUNTIME)
8155                 Perl_croak_no_modify(aTHX);
8156         }
8157         if (SvROK(sv)) {
8158             IV i;
8159             if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
8160                 return;
8161             i = PTR2IV(SvRV(sv));
8162             sv_unref(sv);
8163             sv_setiv(sv, i);
8164         }
8165     }
8166     /* Unlike sv_inc we don't have to worry about string-never-numbers
8167        and keeping them magic. But we mustn't warn on punting */
8168     flags = SvFLAGS(sv);
8169     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8170         /* It's publicly an integer, or privately an integer-not-float */
8171 #ifdef PERL_PRESERVE_IVUV
8172       oops_its_int:
8173 #endif
8174         if (SvIsUV(sv)) {
8175             if (SvUVX(sv) == 0) {
8176                 (void)SvIOK_only(sv);
8177                 SvIV_set(sv, -1);
8178             }
8179             else {
8180                 (void)SvIOK_only_UV(sv);
8181                 SvUV_set(sv, SvUVX(sv) - 1);
8182             }
8183         } else {
8184             if (SvIVX(sv) == IV_MIN) {
8185                 sv_setnv(sv, (NV)IV_MIN);
8186                 goto oops_its_num;
8187             }
8188             else {
8189                 (void)SvIOK_only(sv);
8190                 SvIV_set(sv, SvIVX(sv) - 1);
8191             }
8192         }
8193         return;
8194     }
8195     if (flags & SVp_NOK) {
8196     oops_its_num:
8197         {
8198             const NV was = SvNVX(sv);
8199             if (NV_OVERFLOWS_INTEGERS_AT &&
8200                 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8201                 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8202                                "Lost precision when decrementing %" NVff " by 1",
8203                                was);
8204             }
8205             (void)SvNOK_only(sv);
8206             SvNV_set(sv, was - 1.0);
8207             return;
8208         }
8209     }
8210     if (!(flags & SVp_POK)) {
8211         if ((flags & SVTYPEMASK) < SVt_PVIV)
8212             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8213         SvIV_set(sv, -1);
8214         (void)SvIOK_only(sv);
8215         return;
8216     }
8217 #ifdef PERL_PRESERVE_IVUV
8218     {
8219         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8220         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8221             /* Need to try really hard to see if it's an integer.
8222                9.22337203685478e+18 is an integer.
8223                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8224                so $a="9.22337203685478e+18"; $a+0; $a--
8225                needs to be the same as $a="9.22337203685478e+18"; $a--
8226                or we go insane. */
8227
8228             (void) sv_2iv(sv);
8229             if (SvIOK(sv))
8230                 goto oops_its_int;
8231
8232             /* sv_2iv *should* have made this an NV */
8233             if (flags & SVp_NOK) {
8234                 (void)SvNOK_only(sv);
8235                 SvNV_set(sv, SvNVX(sv) - 1.0);
8236                 return;
8237             }
8238             /* I don't think we can get here. Maybe I should assert this
8239                And if we do get here I suspect that sv_setnv will croak. NWC
8240                Fall through. */
8241 #if defined(USE_LONG_DOUBLE)
8242             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",
8243                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8244 #else
8245             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8246                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8247 #endif
8248         }
8249     }
8250 #endif /* PERL_PRESERVE_IVUV */
8251     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);   /* punt */
8252 }
8253
8254 /* this define is used to eliminate a chunk of duplicated but shared logic
8255  * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8256  * used anywhere but here - yves
8257  */
8258 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8259     STMT_START {      \
8260         EXTEND_MORTAL(1); \
8261         PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8262     } STMT_END
8263
8264 /*
8265 =for apidoc sv_mortalcopy
8266
8267 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8268 The new SV is marked as mortal. It will be destroyed "soon", either by an
8269 explicit call to FREETMPS, or by an implicit call at places such as
8270 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
8271
8272 =cut
8273 */
8274
8275 /* Make a string that will exist for the duration of the expression
8276  * evaluation.  Actually, it may have to last longer than that, but
8277  * hopefully we won't free it until it has been assigned to a
8278  * permanent location. */
8279
8280 SV *
8281 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
8282 {
8283     dVAR;
8284     register SV *sv;
8285
8286     new_SV(sv);
8287     sv_setsv(sv,oldstr);
8288     PUSH_EXTEND_MORTAL__SV_C(sv);
8289     SvTEMP_on(sv);
8290     return sv;
8291 }
8292
8293 /*
8294 =for apidoc sv_newmortal
8295
8296 Creates a new null SV which is mortal.  The reference count of the SV is
8297 set to 1. It will be destroyed "soon", either by an explicit call to
8298 FREETMPS, or by an implicit call at places such as statement boundaries.
8299 See also C<sv_mortalcopy> and C<sv_2mortal>.
8300
8301 =cut
8302 */
8303
8304 SV *
8305 Perl_sv_newmortal(pTHX)
8306 {
8307     dVAR;
8308     register SV *sv;
8309
8310     new_SV(sv);
8311     SvFLAGS(sv) = SVs_TEMP;
8312     PUSH_EXTEND_MORTAL__SV_C(sv);
8313     return sv;
8314 }
8315
8316
8317 /*
8318 =for apidoc newSVpvn_flags
8319
8320 Creates a new SV and copies a string into it.  The reference count for the
8321 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
8322 string.  You are responsible for ensuring that the source string is at least
8323 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
8324 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8325 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8326 returning. If C<SVf_UTF8> is set, C<s> 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 string into it.  The reference count for the
8415 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
8416 string.  You are responsible for ensuring that the source string is at least
8417 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
8418
8419 =cut
8420 */
8421
8422 SV *
8423 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
8424 {
8425     dVAR;
8426     register SV *sv;
8427
8428     new_SV(sv);
8429     sv_setpvn(sv,s,len);
8430     return sv;
8431 }
8432
8433 /*
8434 =for apidoc newSVhek
8435
8436 Creates a new SV from the hash key structure.  It will generate scalars that
8437 point to the shared string table where possible. Returns a new (undefined)
8438 SV if the hek is NULL.
8439
8440 =cut
8441 */
8442
8443 SV *
8444 Perl_newSVhek(pTHX_ const HEK *const hek)
8445 {
8446     dVAR;
8447     if (!hek) {
8448         SV *sv;
8449
8450         new_SV(sv);
8451         return sv;
8452     }
8453
8454     if (HEK_LEN(hek) == HEf_SVKEY) {
8455         return newSVsv(*(SV**)HEK_KEY(hek));
8456     } else {
8457         const int flags = HEK_FLAGS(hek);
8458         if (flags & HVhek_WASUTF8) {
8459             /* Trouble :-)
8460                Andreas would like keys he put in as utf8 to come back as utf8
8461             */
8462             STRLEN utf8_len = HEK_LEN(hek);
8463             SV * const sv = newSV_type(SVt_PV);
8464             char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8465             /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8466             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8467             SvUTF8_on (sv);
8468             return sv;
8469         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
8470             /* We don't have a pointer to the hv, so we have to replicate the
8471                flag into every HEK. This hv is using custom a hasing
8472                algorithm. Hence we can't return a shared string scalar, as
8473                that would contain the (wrong) hash value, and might get passed
8474                into an hv routine with a regular hash.
8475                Similarly, a hash that isn't using shared hash keys has to have
8476                the flag in every key so that we know not to try to call
8477                share_hek_kek on it.  */
8478
8479             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8480             if (HEK_UTF8(hek))
8481                 SvUTF8_on (sv);
8482             return sv;
8483         }
8484         /* This will be overwhelminly the most common case.  */
8485         {
8486             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8487                more efficient than sharepvn().  */
8488             SV *sv;
8489
8490             new_SV(sv);
8491             sv_upgrade(sv, SVt_PV);
8492             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8493             SvCUR_set(sv, HEK_LEN(hek));
8494             SvLEN_set(sv, 0);
8495             SvREADONLY_on(sv);
8496             SvFAKE_on(sv);
8497             SvPOK_on(sv);
8498             if (HEK_UTF8(hek))
8499                 SvUTF8_on(sv);
8500             return sv;
8501         }
8502     }
8503 }
8504
8505 /*
8506 =for apidoc newSVpvn_share
8507
8508 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8509 table. If the string does not already exist in the table, it is created
8510 first.  Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
8511 value is used; otherwise the hash is computed. The string's hash can be later
8512 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
8513 that as the string table is used for shared hash keys these strings will have
8514 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8515
8516 =cut
8517 */
8518
8519 SV *
8520 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8521 {
8522     dVAR;
8523     register SV *sv;
8524     bool is_utf8 = FALSE;
8525     const char *const orig_src = src;
8526
8527     if (len < 0) {
8528         STRLEN tmplen = -len;
8529         is_utf8 = TRUE;
8530         /* See the note in hv.c:hv_fetch() --jhi */
8531         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8532         len = tmplen;
8533     }
8534     if (!hash)
8535         PERL_HASH(hash, src, len);
8536     new_SV(sv);
8537     /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8538        changes here, update it there too.  */
8539     sv_upgrade(sv, SVt_PV);
8540     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8541     SvCUR_set(sv, len);
8542     SvLEN_set(sv, 0);
8543     SvREADONLY_on(sv);
8544     SvFAKE_on(sv);
8545     SvPOK_on(sv);
8546     if (is_utf8)
8547         SvUTF8_on(sv);
8548     if (src != orig_src)
8549         Safefree(src);
8550     return sv;
8551 }
8552
8553 /*
8554 =for apidoc newSVpv_share
8555
8556 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8557 string/length pair.
8558
8559 =cut
8560 */
8561
8562 SV *
8563 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8564 {
8565     return newSVpvn_share(src, strlen(src), hash);
8566 }
8567
8568 #if defined(PERL_IMPLICIT_CONTEXT)
8569
8570 /* pTHX_ magic can't cope with varargs, so this is a no-context
8571  * version of the main function, (which may itself be aliased to us).
8572  * Don't access this version directly.
8573  */
8574
8575 SV *
8576 Perl_newSVpvf_nocontext(const char *const pat, ...)
8577 {
8578     dTHX;
8579     register SV *sv;
8580     va_list args;
8581
8582     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8583
8584     va_start(args, pat);
8585     sv = vnewSVpvf(pat, &args);
8586     va_end(args);
8587     return sv;
8588 }
8589 #endif
8590
8591 /*
8592 =for apidoc newSVpvf
8593
8594 Creates a new SV and initializes it with the string formatted like
8595 C<sprintf>.
8596
8597 =cut
8598 */
8599
8600 SV *
8601 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8602 {
8603     register SV *sv;
8604     va_list args;
8605
8606     PERL_ARGS_ASSERT_NEWSVPVF;
8607
8608     va_start(args, pat);
8609     sv = vnewSVpvf(pat, &args);
8610     va_end(args);
8611     return sv;
8612 }
8613
8614 /* backend for newSVpvf() and newSVpvf_nocontext() */
8615
8616 SV *
8617 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8618 {
8619     dVAR;
8620     register SV *sv;
8621
8622     PERL_ARGS_ASSERT_VNEWSVPVF;
8623
8624     new_SV(sv);
8625     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8626     return sv;
8627 }
8628
8629 /*
8630 =for apidoc newSVnv
8631
8632 Creates a new SV and copies a floating point value into it.
8633 The reference count for the SV is set to 1.
8634
8635 =cut
8636 */
8637
8638 SV *
8639 Perl_newSVnv(pTHX_ const NV n)
8640 {
8641     dVAR;
8642     register SV *sv;
8643
8644     new_SV(sv);
8645     sv_setnv(sv,n);
8646     return sv;
8647 }
8648
8649 /*
8650 =for apidoc newSViv
8651
8652 Creates a new SV and copies an integer into it.  The reference count for the
8653 SV is set to 1.
8654
8655 =cut
8656 */
8657
8658 SV *
8659 Perl_newSViv(pTHX_ const IV i)
8660 {
8661     dVAR;
8662     register SV *sv;
8663
8664     new_SV(sv);
8665     sv_setiv(sv,i);
8666     return sv;
8667 }
8668
8669 /*
8670 =for apidoc newSVuv
8671
8672 Creates a new SV and copies an unsigned integer into it.
8673 The reference count for the SV is set to 1.
8674
8675 =cut
8676 */
8677
8678 SV *
8679 Perl_newSVuv(pTHX_ const UV u)
8680 {
8681     dVAR;
8682     register SV *sv;
8683
8684     new_SV(sv);
8685     sv_setuv(sv,u);
8686     return sv;
8687 }
8688
8689 /*
8690 =for apidoc newSV_type
8691
8692 Creates a new SV, of the type specified.  The reference count for the new SV
8693 is set to 1.
8694
8695 =cut
8696 */
8697
8698 SV *
8699 Perl_newSV_type(pTHX_ const svtype type)
8700 {
8701     register SV *sv;
8702
8703     new_SV(sv);
8704     sv_upgrade(sv, type);
8705     return sv;
8706 }
8707
8708 /*
8709 =for apidoc newRV_noinc
8710
8711 Creates an RV wrapper for an SV.  The reference count for the original
8712 SV is B<not> incremented.
8713
8714 =cut
8715 */
8716
8717 SV *
8718 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8719 {
8720     dVAR;
8721     register SV *sv = newSV_type(SVt_IV);
8722
8723     PERL_ARGS_ASSERT_NEWRV_NOINC;
8724
8725     SvTEMP_off(tmpRef);
8726     SvRV_set(sv, tmpRef);
8727     SvROK_on(sv);
8728     return sv;
8729 }
8730
8731 /* newRV_inc is the official function name to use now.
8732  * newRV_inc is in fact #defined to newRV in sv.h
8733  */
8734
8735 SV *
8736 Perl_newRV(pTHX_ SV *const sv)
8737 {
8738     dVAR;
8739
8740     PERL_ARGS_ASSERT_NEWRV;
8741
8742     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8743 }
8744
8745 /*
8746 =for apidoc newSVsv
8747
8748 Creates a new SV which is an exact duplicate of the original SV.
8749 (Uses C<sv_setsv>).
8750
8751 =cut
8752 */
8753
8754 SV *
8755 Perl_newSVsv(pTHX_ register SV *const old)
8756 {
8757     dVAR;
8758     register SV *sv;
8759
8760     if (!old)
8761         return NULL;
8762     if (SvTYPE(old) == SVTYPEMASK) {
8763         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8764         return NULL;
8765     }
8766     new_SV(sv);
8767     /* SV_GMAGIC is the default for sv_setv()
8768        SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8769        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
8770     sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8771     return sv;
8772 }
8773
8774 /*
8775 =for apidoc sv_reset
8776
8777 Underlying implementation for the C<reset> Perl function.
8778 Note that the perl-level function is vaguely deprecated.
8779
8780 =cut
8781 */
8782
8783 void
8784 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8785 {
8786     dVAR;
8787     char todo[PERL_UCHAR_MAX+1];
8788
8789     PERL_ARGS_ASSERT_SV_RESET;
8790
8791     if (!stash)
8792         return;
8793
8794     if (!*s) {          /* reset ?? searches */
8795         MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8796         if (mg) {
8797             const U32 count = mg->mg_len / sizeof(PMOP**);
8798             PMOP **pmp = (PMOP**) mg->mg_ptr;
8799             PMOP *const *const end = pmp + count;
8800
8801             while (pmp < end) {
8802 #ifdef USE_ITHREADS
8803                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8804 #else
8805                 (*pmp)->op_pmflags &= ~PMf_USED;
8806 #endif
8807                 ++pmp;
8808             }
8809         }
8810         return;
8811     }
8812
8813     /* reset variables */
8814
8815     if (!HvARRAY(stash))
8816         return;
8817
8818     Zero(todo, 256, char);
8819     while (*s) {
8820         I32 max;
8821         I32 i = (unsigned char)*s;
8822         if (s[1] == '-') {
8823             s += 2;
8824         }
8825         max = (unsigned char)*s++;
8826         for ( ; i <= max; i++) {
8827             todo[i] = 1;
8828         }
8829         for (i = 0; i <= (I32) HvMAX(stash); i++) {
8830             HE *entry;
8831             for (entry = HvARRAY(stash)[i];
8832                  entry;
8833                  entry = HeNEXT(entry))
8834             {
8835                 register GV *gv;
8836                 register SV *sv;
8837
8838                 if (!todo[(U8)*HeKEY(entry)])
8839                     continue;
8840                 gv = MUTABLE_GV(HeVAL(entry));
8841                 sv = GvSV(gv);
8842                 if (sv) {
8843                     if (SvTHINKFIRST(sv)) {
8844                         if (!SvREADONLY(sv) && SvROK(sv))
8845                             sv_unref(sv);
8846                         /* XXX Is this continue a bug? Why should THINKFIRST
8847                            exempt us from resetting arrays and hashes?  */
8848                         continue;
8849                     }
8850                     SvOK_off(sv);
8851                     if (SvTYPE(sv) >= SVt_PV) {
8852                         SvCUR_set(sv, 0);
8853                         if (SvPVX_const(sv) != NULL)
8854                             *SvPVX(sv) = '\0';
8855                         SvTAINT(sv);
8856                     }
8857                 }
8858                 if (GvAV(gv)) {
8859                     av_clear(GvAV(gv));
8860                 }
8861                 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8862 #if defined(VMS)
8863                     Perl_die(aTHX_ "Can't reset %%ENV on this system");
8864 #else /* ! VMS */
8865                     hv_clear(GvHV(gv));
8866 #  if defined(USE_ENVIRON_ARRAY)
8867                     if (gv == PL_envgv)
8868                         my_clearenv();
8869 #  endif /* USE_ENVIRON_ARRAY */
8870 #endif /* VMS */
8871                 }
8872             }
8873         }
8874     }
8875 }
8876
8877 /*
8878 =for apidoc sv_2io
8879
8880 Using various gambits, try to get an IO from an SV: the IO slot if its a
8881 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8882 named after the PV if we're a string.
8883
8884 =cut
8885 */
8886
8887 IO*
8888 Perl_sv_2io(pTHX_ SV *const sv)
8889 {
8890     IO* io;
8891     GV* gv;
8892
8893     PERL_ARGS_ASSERT_SV_2IO;
8894
8895     switch (SvTYPE(sv)) {
8896     case SVt_PVIO:
8897         io = MUTABLE_IO(sv);
8898         break;
8899     case SVt_PVGV:
8900     case SVt_PVLV:
8901         if (isGV_with_GP(sv)) {
8902             gv = MUTABLE_GV(sv);
8903             io = GvIO(gv);
8904             if (!io)
8905                 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8906             break;
8907         }
8908         /* FALL THROUGH */
8909     default:
8910         if (!SvOK(sv))
8911             Perl_croak(aTHX_ PL_no_usym, "filehandle");
8912         if (SvROK(sv))
8913             return sv_2io(SvRV(sv));
8914         gv = gv_fetchsv(sv, 0, SVt_PVIO);
8915         if (gv)
8916             io = GvIO(gv);
8917         else
8918             io = 0;
8919         if (!io)
8920             Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8921         break;
8922     }
8923     return io;
8924 }
8925
8926 /*
8927 =for apidoc sv_2cv
8928
8929 Using various gambits, try to get a CV from an SV; in addition, try if
8930 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8931 The flags in C<lref> are passed to gv_fetchsv.
8932
8933 =cut
8934 */
8935
8936 CV *
8937 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8938 {
8939     dVAR;
8940     GV *gv = NULL;
8941     CV *cv = NULL;
8942
8943     PERL_ARGS_ASSERT_SV_2CV;
8944
8945     if (!sv) {
8946         *st = NULL;
8947         *gvp = NULL;
8948         return NULL;
8949     }
8950     switch (SvTYPE(sv)) {
8951     case SVt_PVCV:
8952         *st = CvSTASH(sv);
8953         *gvp = NULL;
8954         return MUTABLE_CV(sv);
8955     case SVt_PVHV:
8956     case SVt_PVAV:
8957         *st = NULL;
8958         *gvp = NULL;
8959         return NULL;
8960     case SVt_PVGV:
8961         if (isGV_with_GP(sv)) {
8962             gv = MUTABLE_GV(sv);
8963             *gvp = gv;
8964             *st = GvESTASH(gv);
8965             goto fix_gv;
8966         }
8967         /* FALL THROUGH */
8968
8969     default:
8970         if (SvROK(sv)) {
8971             SvGETMAGIC(sv);
8972             if (SvAMAGIC(sv))
8973                 sv = amagic_deref_call(sv, to_cv_amg);
8974             /* At this point I'd like to do SPAGAIN, but really I need to
8975                force it upon my callers. Hmmm. This is a mess... */
8976
8977             sv = SvRV(sv);
8978             if (SvTYPE(sv) == SVt_PVCV) {
8979                 cv = MUTABLE_CV(sv);
8980                 *gvp = NULL;
8981                 *st = CvSTASH(cv);
8982                 return cv;
8983             }
8984             else if(isGV_with_GP(sv))
8985                 gv = MUTABLE_GV(sv);
8986             else
8987                 Perl_croak(aTHX_ "Not a subroutine reference");
8988         }
8989         else if (isGV_with_GP(sv)) {
8990             SvGETMAGIC(sv);
8991             gv = MUTABLE_GV(sv);
8992         }
8993         else
8994             gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8995         *gvp = gv;
8996         if (!gv) {
8997             *st = NULL;
8998             return NULL;
8999         }
9000         /* Some flags to gv_fetchsv mean don't really create the GV  */
9001         if (!isGV_with_GP(gv)) {
9002             *st = NULL;
9003             return NULL;
9004         }
9005         *st = GvESTASH(gv);
9006     fix_gv:
9007         if (lref && !GvCVu(gv)) {
9008             SV *tmpsv;
9009             ENTER;
9010             tmpsv = newSV(0);
9011             gv_efullname3(tmpsv, gv, NULL);
9012             /* XXX this is probably not what they think they're getting.
9013              * It has the same effect as "sub name;", i.e. just a forward
9014              * declaration! */
9015             newSUB(start_subparse(FALSE, 0),
9016                    newSVOP(OP_CONST, 0, tmpsv),
9017                    NULL, NULL);
9018             LEAVE;
9019             if (!GvCVu(gv))
9020                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
9021                            SVfARG(SvOK(sv) ? sv : &PL_sv_no));
9022         }
9023         return GvCVu(gv);
9024     }
9025 }
9026
9027 /*
9028 =for apidoc sv_true
9029
9030 Returns true if the SV has a true value by Perl's rules.
9031 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
9032 instead use an in-line version.
9033
9034 =cut
9035 */
9036
9037 I32
9038 Perl_sv_true(pTHX_ register SV *const sv)
9039 {
9040     if (!sv)
9041         return 0;
9042     if (SvPOK(sv)) {
9043         register const XPV* const tXpv = (XPV*)SvANY(sv);
9044         if (tXpv &&
9045                 (tXpv->xpv_cur > 1 ||
9046                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
9047             return 1;
9048         else
9049             return 0;
9050     }
9051     else {
9052         if (SvIOK(sv))
9053             return SvIVX(sv) != 0;
9054         else {
9055             if (SvNOK(sv))
9056                 return SvNVX(sv) != 0.0;
9057             else
9058                 return sv_2bool(sv);
9059         }
9060     }
9061 }
9062
9063 /*
9064 =for apidoc sv_pvn_force
9065
9066 Get a sensible string out of the SV somehow.
9067 A private implementation of the C<SvPV_force> macro for compilers which
9068 can't cope with complex macro expressions. Always use the macro instead.
9069
9070 =for apidoc sv_pvn_force_flags
9071
9072 Get a sensible string out of the SV somehow.
9073 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
9074 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
9075 implemented in terms of this function.
9076 You normally want to use the various wrapper macros instead: see
9077 C<SvPV_force> and C<SvPV_force_nomg>
9078
9079 =cut
9080 */
9081
9082 char *
9083 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
9084 {
9085     dVAR;
9086
9087     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
9088
9089     if (SvTHINKFIRST(sv) && !SvROK(sv))
9090         sv_force_normal_flags(sv, 0);
9091
9092     if (SvPOK(sv)) {
9093         if (lp)
9094             *lp = SvCUR(sv);
9095     }
9096     else {
9097         char *s;
9098         STRLEN len;
9099
9100         if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
9101             const char * const ref = sv_reftype(sv,0);
9102             if (PL_op)
9103                 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
9104                            ref, OP_DESC(PL_op));
9105             else
9106                 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
9107         }
9108         if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
9109             || isGV_with_GP(sv))
9110             /* diag_listed_as: Can't coerce %s to %s in %s */
9111             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
9112                 OP_DESC(PL_op));
9113         s = sv_2pv_flags(sv, &len, flags);
9114         if (lp)
9115             *lp = len;
9116
9117         if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
9118             if (SvROK(sv))
9119                 sv_unref(sv);
9120             SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
9121             SvGROW(sv, len + 1);
9122             Move(s,SvPVX(sv),len,char);
9123             SvCUR_set(sv, len);
9124             SvPVX(sv)[len] = '\0';
9125         }
9126         if (!SvPOK(sv)) {
9127             SvPOK_on(sv);               /* validate pointer */
9128             SvTAINT(sv);
9129             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
9130                                   PTR2UV(sv),SvPVX_const(sv)));
9131         }
9132     }
9133     return SvPVX_mutable(sv);
9134 }
9135
9136 /*
9137 =for apidoc sv_pvbyten_force
9138
9139 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
9140
9141 =cut
9142 */
9143
9144 char *
9145 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
9146 {
9147     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
9148
9149     sv_pvn_force(sv,lp);
9150     sv_utf8_downgrade(sv,0);
9151     *lp = SvCUR(sv);
9152     return SvPVX(sv);
9153 }
9154
9155 /*
9156 =for apidoc sv_pvutf8n_force
9157
9158 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
9159
9160 =cut
9161 */
9162
9163 char *
9164 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9165 {
9166     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9167
9168     sv_pvn_force(sv,lp);
9169     sv_utf8_upgrade(sv);
9170     *lp = SvCUR(sv);
9171     return SvPVX(sv);
9172 }
9173
9174 /*
9175 =for apidoc sv_reftype
9176
9177 Returns a string describing what the SV is a reference to.
9178
9179 =cut
9180 */
9181
9182 const char *
9183 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9184 {
9185     PERL_ARGS_ASSERT_SV_REFTYPE;
9186
9187     /* The fact that I don't need to downcast to char * everywhere, only in ?:
9188        inside return suggests a const propagation bug in g++.  */
9189     if (ob && SvOBJECT(sv)) {
9190         char * const name = HvNAME_get(SvSTASH(sv));
9191         return name ? name : (char *) "__ANON__";
9192     }
9193     else {
9194         switch (SvTYPE(sv)) {
9195         case SVt_NULL:
9196         case SVt_IV:
9197         case SVt_NV:
9198         case SVt_PV:
9199         case SVt_PVIV:
9200         case SVt_PVNV:
9201         case SVt_PVMG:
9202                                 if (SvVOK(sv))
9203                                     return "VSTRING";
9204                                 if (SvROK(sv))
9205                                     return "REF";
9206                                 else
9207                                     return "SCALAR";
9208
9209         case SVt_PVLV:          return (char *)  (SvROK(sv) ? "REF"
9210                                 /* tied lvalues should appear to be
9211                                  * scalars for backwards compatibility */
9212                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9213                                     ? "SCALAR" : "LVALUE");
9214         case SVt_PVAV:          return "ARRAY";
9215         case SVt_PVHV:          return "HASH";
9216         case SVt_PVCV:          return "CODE";
9217         case SVt_PVGV:          return (char *) (isGV_with_GP(sv)
9218                                     ? "GLOB" : "SCALAR");
9219         case SVt_PVFM:          return "FORMAT";
9220         case SVt_PVIO:          return "IO";
9221         case SVt_BIND:          return "BIND";
9222         case SVt_REGEXP:        return "REGEXP";
9223         default:                return "UNKNOWN";
9224         }
9225     }
9226 }
9227
9228 /*
9229 =for apidoc sv_isobject
9230
9231 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9232 object.  If the SV is not an RV, or if the object is not blessed, then this
9233 will return false.
9234
9235 =cut
9236 */
9237
9238 int
9239 Perl_sv_isobject(pTHX_ SV *sv)
9240 {
9241     if (!sv)
9242         return 0;
9243     SvGETMAGIC(sv);
9244     if (!SvROK(sv))
9245         return 0;
9246     sv = SvRV(sv);
9247     if (!SvOBJECT(sv))
9248         return 0;
9249     return 1;
9250 }
9251
9252 /*
9253 =for apidoc sv_isa
9254
9255 Returns a boolean indicating whether the SV is blessed into the specified
9256 class.  This does not check for subtypes; use C<sv_derived_from> to verify
9257 an inheritance relationship.
9258
9259 =cut
9260 */
9261
9262 int
9263 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9264 {
9265     const char *hvname;
9266
9267     PERL_ARGS_ASSERT_SV_ISA;
9268
9269     if (!sv)
9270         return 0;
9271     SvGETMAGIC(sv);
9272     if (!SvROK(sv))
9273         return 0;
9274     sv = SvRV(sv);
9275     if (!SvOBJECT(sv))
9276         return 0;
9277     hvname = HvNAME_get(SvSTASH(sv));
9278     if (!hvname)
9279         return 0;
9280
9281     return strEQ(hvname, name);
9282 }
9283
9284 /*
9285 =for apidoc newSVrv
9286
9287 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
9288 it will be upgraded to one.  If C<classname> is non-null then the new SV will
9289 be blessed in the specified package.  The new SV is returned and its
9290 reference count is 1.
9291
9292 =cut
9293 */
9294
9295 SV*
9296 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9297 {
9298     dVAR;
9299     SV *sv;
9300
9301     PERL_ARGS_ASSERT_NEWSVRV;
9302
9303     new_SV(sv);
9304
9305     SV_CHECK_THINKFIRST_COW_DROP(rv);
9306     (void)SvAMAGIC_off(rv);
9307
9308     if (SvTYPE(rv) >= SVt_PVMG) {
9309         const U32 refcnt = SvREFCNT(rv);
9310         SvREFCNT(rv) = 0;
9311         sv_clear(rv);
9312         SvFLAGS(rv) = 0;
9313         SvREFCNT(rv) = refcnt;
9314
9315         sv_upgrade(rv, SVt_IV);
9316     } else if (SvROK(rv)) {
9317         SvREFCNT_dec(SvRV(rv));
9318     } else {
9319         prepare_SV_for_RV(rv);
9320     }
9321
9322     SvOK_off(rv);
9323     SvRV_set(rv, sv);
9324     SvROK_on(rv);
9325
9326     if (classname) {
9327         HV* const stash = gv_stashpv(classname, GV_ADD);
9328         (void)sv_bless(rv, stash);
9329     }
9330     return sv;
9331 }
9332
9333 /*
9334 =for apidoc sv_setref_pv
9335
9336 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
9337 argument will be upgraded to an RV.  That RV will be modified to point to
9338 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9339 into the SV.  The C<classname> argument indicates the package for the
9340 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9341 will have a reference count of 1, and the RV will be returned.
9342
9343 Do not use with other Perl types such as HV, AV, SV, CV, because those
9344 objects will become corrupted by the pointer copy process.
9345
9346 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9347
9348 =cut
9349 */
9350
9351 SV*
9352 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9353 {
9354     dVAR;
9355
9356     PERL_ARGS_ASSERT_SV_SETREF_PV;
9357
9358     if (!pv) {
9359         sv_setsv(rv, &PL_sv_undef);
9360         SvSETMAGIC(rv);
9361     }
9362     else
9363         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9364     return rv;
9365 }
9366
9367 /*
9368 =for apidoc sv_setref_iv
9369
9370 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
9371 argument will be upgraded to an RV.  That RV will be modified to point to
9372 the new SV.  The C<classname> argument indicates the package for the
9373 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9374 will have a reference count of 1, and the RV will be returned.
9375
9376 =cut
9377 */
9378
9379 SV*
9380 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9381 {
9382     PERL_ARGS_ASSERT_SV_SETREF_IV;
9383
9384     sv_setiv(newSVrv(rv,classname), iv);
9385     return rv;
9386 }
9387
9388 /*
9389 =for apidoc sv_setref_uv
9390
9391 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
9392 argument will be upgraded to an RV.  That RV will be modified to point to
9393 the new SV.  The C<classname> argument indicates the package for the
9394 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9395 will have a reference count of 1, and the RV will be returned.
9396
9397 =cut
9398 */
9399
9400 SV*
9401 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9402 {
9403     PERL_ARGS_ASSERT_SV_SETREF_UV;
9404
9405     sv_setuv(newSVrv(rv,classname), uv);
9406     return rv;
9407 }
9408
9409 /*
9410 =for apidoc sv_setref_nv
9411
9412 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
9413 argument will be upgraded to an RV.  That RV will be modified to point to
9414 the new SV.  The C<classname> argument indicates the package for the
9415 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9416 will have a reference count of 1, and the RV will be returned.
9417
9418 =cut
9419 */
9420
9421 SV*
9422 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9423 {
9424     PERL_ARGS_ASSERT_SV_SETREF_NV;
9425
9426     sv_setnv(newSVrv(rv,classname), nv);
9427     return rv;
9428 }
9429
9430 /*
9431 =for apidoc sv_setref_pvn
9432
9433 Copies a string into a new SV, optionally blessing the SV.  The length of the
9434 string must be specified with C<n>.  The C<rv> argument will be upgraded to
9435 an RV.  That RV will be modified to point to the new SV.  The C<classname>
9436 argument indicates the package for the blessing.  Set C<classname> to
9437 C<NULL> to avoid the blessing.  The new SV will have a reference count
9438 of 1, and the RV will be returned.
9439
9440 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9441
9442 =cut
9443 */
9444
9445 SV*
9446 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9447                    const char *const pv, const STRLEN n)
9448 {
9449     PERL_ARGS_ASSERT_SV_SETREF_PVN;
9450
9451     sv_setpvn(newSVrv(rv,classname), pv, n);
9452     return rv;
9453 }
9454
9455 /*
9456 =for apidoc sv_bless
9457
9458 Blesses an SV into a specified package.  The SV must be an RV.  The package
9459 must be designated by its stash (see C<gv_stashpv()>).  The reference count
9460 of the SV is unaffected.
9461
9462 =cut
9463 */
9464
9465 SV*
9466 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9467 {
9468     dVAR;
9469     SV *tmpRef;
9470
9471     PERL_ARGS_ASSERT_SV_BLESS;
9472
9473     if (!SvROK(sv))
9474         Perl_croak(aTHX_ "Can't bless non-reference value");
9475     tmpRef = SvRV(sv);
9476     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9477         if (SvIsCOW(tmpRef))
9478             sv_force_normal_flags(tmpRef, 0);
9479         if (SvREADONLY(tmpRef))
9480             Perl_croak_no_modify(aTHX);
9481         if (SvOBJECT(tmpRef)) {
9482             if (SvTYPE(tmpRef) != SVt_PVIO)
9483                 --PL_sv_objcount;
9484             SvREFCNT_dec(SvSTASH(tmpRef));
9485         }
9486     }
9487     SvOBJECT_on(tmpRef);
9488     if (SvTYPE(tmpRef) != SVt_PVIO)
9489         ++PL_sv_objcount;
9490     SvUPGRADE(tmpRef, SVt_PVMG);
9491     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9492
9493     if (Gv_AMG(stash))
9494         SvAMAGIC_on(sv);
9495     else
9496         (void)SvAMAGIC_off(sv);
9497
9498     if(SvSMAGICAL(tmpRef))
9499         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9500             mg_set(tmpRef);
9501
9502
9503
9504     return sv;
9505 }
9506
9507 /* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
9508  * as it is after unglobbing it.
9509  */
9510
9511 STATIC void
9512 S_sv_unglob(pTHX_ SV *const sv)
9513 {
9514     dVAR;
9515     void *xpvmg;
9516     HV *stash;
9517     SV * const temp = sv_newmortal();
9518
9519     PERL_ARGS_ASSERT_SV_UNGLOB;
9520
9521     assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9522     SvFAKE_off(sv);
9523     gv_efullname3(temp, MUTABLE_GV(sv), "*");
9524
9525     if (GvGP(sv)) {
9526         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9527            && HvNAME_get(stash))
9528             mro_method_changed_in(stash);
9529         gp_free(MUTABLE_GV(sv));
9530     }
9531     if (GvSTASH(sv)) {
9532         sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9533         GvSTASH(sv) = NULL;
9534     }
9535     GvMULTI_off(sv);
9536     if (GvNAME_HEK(sv)) {
9537         unshare_hek(GvNAME_HEK(sv));
9538     }
9539     isGV_with_GP_off(sv);
9540
9541     if(SvTYPE(sv) == SVt_PVGV) {
9542         /* need to keep SvANY(sv) in the right arena */
9543         xpvmg = new_XPVMG();
9544         StructCopy(SvANY(sv), xpvmg, XPVMG);
9545         del_XPVGV(SvANY(sv));
9546         SvANY(sv) = xpvmg;
9547
9548         SvFLAGS(sv) &= ~SVTYPEMASK;
9549         SvFLAGS(sv) |= SVt_PVMG;
9550     }
9551
9552     /* Intentionally not calling any local SET magic, as this isn't so much a
9553        set operation as merely an internal storage change.  */
9554     sv_setsv_flags(sv, temp, 0);
9555 }
9556
9557 /*
9558 =for apidoc sv_unref_flags
9559
9560 Unsets the RV status of the SV, and decrements the reference count of
9561 whatever was being referenced by the RV.  This can almost be thought of
9562 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
9563 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9564 (otherwise the decrementing is conditional on the reference count being
9565 different from one or the reference being a readonly SV).
9566 See C<SvROK_off>.
9567
9568 =cut
9569 */
9570
9571 void
9572 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9573 {
9574     SV* const target = SvRV(ref);
9575
9576     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9577
9578     if (SvWEAKREF(ref)) {
9579         sv_del_backref(target, ref);
9580         SvWEAKREF_off(ref);
9581         SvRV_set(ref, NULL);
9582         return;
9583     }
9584     SvRV_set(ref, NULL);
9585     SvROK_off(ref);
9586     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9587        assigned to as BEGIN {$a = \"Foo"} will fail.  */
9588     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9589         SvREFCNT_dec(target);
9590     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9591         sv_2mortal(target);     /* Schedule for freeing later */
9592 }
9593
9594 /*
9595 =for apidoc sv_untaint
9596
9597 Untaint an SV. Use C<SvTAINTED_off> instead.
9598 =cut
9599 */
9600
9601 void
9602 Perl_sv_untaint(pTHX_ SV *const sv)
9603 {
9604     PERL_ARGS_ASSERT_SV_UNTAINT;
9605
9606     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9607         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9608         if (mg)
9609             mg->mg_len &= ~1;
9610     }
9611 }
9612
9613 /*
9614 =for apidoc sv_tainted
9615
9616 Test an SV for taintedness. Use C<SvTAINTED> instead.
9617 =cut
9618 */
9619
9620 bool
9621 Perl_sv_tainted(pTHX_ SV *const sv)
9622 {
9623     PERL_ARGS_ASSERT_SV_TAINTED;
9624
9625     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9626         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9627         if (mg && (mg->mg_len & 1) )
9628             return TRUE;
9629     }
9630     return FALSE;
9631 }
9632
9633 /*
9634 =for apidoc sv_setpviv
9635
9636 Copies an integer into the given SV, also updating its string value.
9637 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
9638
9639 =cut
9640 */
9641
9642 void
9643 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9644 {
9645     char buf[TYPE_CHARS(UV)];
9646     char *ebuf;
9647     char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9648
9649     PERL_ARGS_ASSERT_SV_SETPVIV;
9650
9651     sv_setpvn(sv, ptr, ebuf - ptr);
9652 }
9653
9654 /*
9655 =for apidoc sv_setpviv_mg
9656
9657 Like C<sv_setpviv>, but also handles 'set' magic.
9658
9659 =cut
9660 */
9661
9662 void
9663 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9664 {
9665     PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9666
9667     sv_setpviv(sv, iv);
9668     SvSETMAGIC(sv);
9669 }
9670
9671 #if defined(PERL_IMPLICIT_CONTEXT)
9672
9673 /* pTHX_ magic can't cope with varargs, so this is a no-context
9674  * version of the main function, (which may itself be aliased to us).
9675  * Don't access this version directly.
9676  */
9677
9678 void
9679 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9680 {
9681     dTHX;
9682     va_list args;
9683
9684     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9685
9686     va_start(args, pat);
9687     sv_vsetpvf(sv, pat, &args);
9688     va_end(args);
9689 }
9690
9691 /* pTHX_ magic can't cope with varargs, so this is a no-context
9692  * version of the main function, (which may itself be aliased to us).
9693  * Don't access this version directly.
9694  */
9695
9696 void
9697 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9698 {
9699     dTHX;
9700     va_list args;
9701
9702     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9703
9704     va_start(args, pat);
9705     sv_vsetpvf_mg(sv, pat, &args);
9706     va_end(args);
9707 }
9708 #endif
9709
9710 /*
9711 =for apidoc sv_setpvf
9712
9713 Works like C<sv_catpvf> but copies the text into the SV instead of
9714 appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
9715
9716 =cut
9717 */
9718
9719 void
9720 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9721 {
9722     va_list args;
9723
9724     PERL_ARGS_ASSERT_SV_SETPVF;
9725
9726     va_start(args, pat);
9727     sv_vsetpvf(sv, pat, &args);
9728     va_end(args);
9729 }
9730
9731 /*
9732 =for apidoc sv_vsetpvf
9733
9734 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9735 appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
9736
9737 Usually used via its frontend C<sv_setpvf>.
9738
9739 =cut
9740 */
9741
9742 void
9743 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9744 {
9745     PERL_ARGS_ASSERT_SV_VSETPVF;
9746
9747     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9748 }
9749
9750 /*
9751 =for apidoc sv_setpvf_mg
9752
9753 Like C<sv_setpvf>, but also handles 'set' magic.
9754
9755 =cut
9756 */
9757
9758 void
9759 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9760 {
9761     va_list args;
9762
9763     PERL_ARGS_ASSERT_SV_SETPVF_MG;
9764
9765     va_start(args, pat);
9766     sv_vsetpvf_mg(sv, pat, &args);
9767     va_end(args);
9768 }
9769
9770 /*
9771 =for apidoc sv_vsetpvf_mg
9772
9773 Like C<sv_vsetpvf>, but also handles 'set' magic.
9774
9775 Usually used via its frontend C<sv_setpvf_mg>.
9776
9777 =cut
9778 */
9779
9780 void
9781 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9782 {
9783     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9784
9785     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9786     SvSETMAGIC(sv);
9787 }
9788
9789 #if defined(PERL_IMPLICIT_CONTEXT)
9790
9791 /* pTHX_ magic can't cope with varargs, so this is a no-context
9792  * version of the main function, (which may itself be aliased to us).
9793  * Don't access this version directly.
9794  */
9795
9796 void
9797 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9798 {
9799     dTHX;
9800     va_list args;
9801
9802     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9803
9804     va_start(args, pat);
9805     sv_vcatpvf(sv, pat, &args);
9806     va_end(args);
9807 }
9808
9809 /* pTHX_ magic can't cope with varargs, so this is a no-context
9810  * version of the main function, (which may itself be aliased to us).
9811  * Don't access this version directly.
9812  */
9813
9814 void
9815 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9816 {
9817     dTHX;
9818     va_list args;
9819
9820     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9821
9822     va_start(args, pat);
9823     sv_vcatpvf_mg(sv, pat, &args);
9824     va_end(args);
9825 }
9826 #endif
9827
9828 /*
9829 =for apidoc sv_catpvf
9830
9831 Processes its arguments like C<sprintf> and appends the formatted
9832 output to an SV.  If the appended data contains "wide" characters
9833 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9834 and characters >255 formatted with %c), the original SV might get
9835 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
9836 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9837 valid UTF-8; if the original SV was bytes, the pattern should be too.
9838
9839 =cut */
9840
9841 void
9842 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9843 {
9844     va_list args;
9845
9846     PERL_ARGS_ASSERT_SV_CATPVF;
9847
9848     va_start(args, pat);
9849     sv_vcatpvf(sv, pat, &args);
9850     va_end(args);
9851 }
9852
9853 /*
9854 =for apidoc sv_vcatpvf
9855
9856 Processes its arguments like C<vsprintf> and appends the formatted output
9857 to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
9858
9859 Usually used via its frontend C<sv_catpvf>.
9860
9861 =cut
9862 */
9863
9864 void
9865 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9866 {
9867     PERL_ARGS_ASSERT_SV_VCATPVF;
9868
9869     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9870 }
9871
9872 /*
9873 =for apidoc sv_catpvf_mg
9874
9875 Like C<sv_catpvf>, but also handles 'set' magic.
9876
9877 =cut
9878 */
9879
9880 void
9881 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9882 {
9883     va_list args;
9884
9885     PERL_ARGS_ASSERT_SV_CATPVF_MG;
9886
9887     va_start(args, pat);
9888     sv_vcatpvf_mg(sv, pat, &args);
9889     va_end(args);
9890 }
9891
9892 /*
9893 =for apidoc sv_vcatpvf_mg
9894
9895 Like C<sv_vcatpvf>, but also handles 'set' magic.
9896
9897 Usually used via its frontend C<sv_catpvf_mg>.
9898
9899 =cut
9900 */
9901
9902 void
9903 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9904 {
9905     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9906
9907     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9908     SvSETMAGIC(sv);
9909 }
9910
9911 /*
9912 =for apidoc sv_vsetpvfn
9913
9914 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9915 appending it.
9916
9917 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9918
9919 =cut
9920 */
9921
9922 void
9923 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9924                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9925 {
9926     PERL_ARGS_ASSERT_SV_VSETPVFN;
9927
9928     sv_setpvs(sv, "");
9929     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9930 }
9931
9932
9933 /*
9934  * Warn of missing argument to sprintf, and then return a defined value
9935  * to avoid inappropriate "use of uninit" warnings [perl #71000].
9936  */
9937 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9938 STATIC SV*
9939 S_vcatpvfn_missing_argument(pTHX) {
9940     if (ckWARN(WARN_MISSING)) {
9941         Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9942                 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9943     }
9944     return &PL_sv_no;
9945 }
9946
9947
9948 STATIC I32
9949 S_expect_number(pTHX_ char **const pattern)
9950 {
9951     dVAR;
9952     I32 var = 0;
9953
9954     PERL_ARGS_ASSERT_EXPECT_NUMBER;
9955
9956     switch (**pattern) {
9957     case '1': case '2': case '3':
9958     case '4': case '5': case '6':
9959     case '7': case '8': case '9':
9960         var = *(*pattern)++ - '0';
9961         while (isDIGIT(**pattern)) {
9962             const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9963             if (tmp < var)
9964                 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9965             var = tmp;
9966         }
9967     }
9968     return var;
9969 }
9970
9971 STATIC char *
9972 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9973 {
9974     const int neg = nv < 0;
9975     UV uv;
9976
9977     PERL_ARGS_ASSERT_F0CONVERT;
9978
9979     if (neg)
9980         nv = -nv;
9981     if (nv < UV_MAX) {
9982         char *p = endbuf;
9983         nv += 0.5;
9984         uv = (UV)nv;
9985         if (uv & 1 && uv == nv)
9986             uv--;                       /* Round to even */
9987         do {
9988             const unsigned dig = uv % 10;
9989             *--p = '0' + dig;
9990         } while (uv /= 10);
9991         if (neg)
9992             *--p = '-';
9993         *len = endbuf - p;
9994         return p;
9995     }
9996     return NULL;
9997 }
9998
9999
10000 /*
10001 =for apidoc sv_vcatpvfn
10002
10003 Processes its arguments like C<vsprintf> and appends the formatted output
10004 to an SV.  Uses an array of SVs if the C style variable argument list is
10005 missing (NULL).  When running with taint checks enabled, indicates via
10006 C<maybe_tainted> if results are untrustworthy (often due to the use of
10007 locales).
10008
10009 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
10010
10011 =cut
10012 */
10013
10014
10015 #define VECTORIZE_ARGS  vecsv = va_arg(*args, SV*);\
10016                         vecstr = (U8*)SvPV_const(vecsv,veclen);\
10017                         vec_utf8 = DO_UTF8(vecsv);
10018
10019 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
10020
10021 void
10022 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10023                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10024 {
10025     dVAR;
10026     char *p;
10027     char *q;
10028     const char *patend;
10029     STRLEN origlen;
10030     I32 svix = 0;
10031     static const char nullstr[] = "(null)";
10032     SV *argsv = NULL;
10033     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
10034     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
10035     SV *nsv = NULL;
10036     /* Times 4: a decimal digit takes more than 3 binary digits.
10037      * NV_DIG: mantissa takes than many decimal digits.
10038      * Plus 32: Playing safe. */
10039     char ebuf[IV_DIG * 4 + NV_DIG + 32];
10040     /* large enough for "%#.#f" --chip */
10041     /* what about long double NVs? --jhi */
10042
10043     PERL_ARGS_ASSERT_SV_VCATPVFN;
10044     PERL_UNUSED_ARG(maybe_tainted);
10045
10046     /* no matter what, this is a string now */
10047     (void)SvPV_force(sv, origlen);
10048
10049     /* special-case "", "%s", and "%-p" (SVf - see below) */
10050     if (patlen == 0)
10051         return;
10052     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
10053         if (args) {
10054             const char * const s = va_arg(*args, char*);
10055             sv_catpv(sv, s ? s : nullstr);
10056         }
10057         else if (svix < svmax) {
10058             sv_catsv(sv, *svargs);
10059         }
10060         else
10061             S_vcatpvfn_missing_argument(aTHX);
10062         return;
10063     }
10064     if (args && patlen == 3 && pat[0] == '%' &&
10065                 pat[1] == '-' && pat[2] == 'p') {
10066         argsv = MUTABLE_SV(va_arg(*args, void*));
10067         sv_catsv(sv, argsv);
10068         return;
10069     }
10070
10071 #ifndef USE_LONG_DOUBLE
10072     /* special-case "%.<number>[gf]" */
10073     if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
10074          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
10075         unsigned digits = 0;
10076         const char *pp;
10077
10078         pp = pat + 2;
10079         while (*pp >= '0' && *pp <= '9')
10080             digits = 10 * digits + (*pp++ - '0');
10081         if (pp - pat == (int)patlen - 1 && svix < svmax) {
10082             const NV nv = SvNV(*svargs);
10083             if (*pp == 'g') {
10084                 /* Add check for digits != 0 because it seems that some
10085                    gconverts are buggy in this case, and we don't yet have
10086                    a Configure test for this.  */
10087                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
10088                      /* 0, point, slack */
10089                     Gconvert(nv, (int)digits, 0, ebuf);
10090                     sv_catpv(sv, ebuf);
10091                     if (*ebuf)  /* May return an empty string for digits==0 */
10092                         return;
10093                 }
10094             } else if (!digits) {
10095                 STRLEN l;
10096
10097                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
10098                     sv_catpvn(sv, p, l);
10099                     return;
10100                 }
10101             }
10102         }
10103     }
10104 #endif /* !USE_LONG_DOUBLE */
10105
10106     if (!args && svix < svmax && DO_UTF8(*svargs))
10107         has_utf8 = TRUE;
10108
10109     patend = (char*)pat + patlen;
10110     for (p = (char*)pat; p < patend; p = q) {
10111         bool alt = FALSE;
10112         bool left = FALSE;
10113         bool vectorize = FALSE;
10114         bool vectorarg = FALSE;
10115         bool vec_utf8 = FALSE;
10116         char fill = ' ';
10117         char plus = 0;
10118         char intsize = 0;
10119         STRLEN width = 0;
10120         STRLEN zeros = 0;
10121         bool has_precis = FALSE;
10122         STRLEN precis = 0;
10123         const I32 osvix = svix;
10124         bool is_utf8 = FALSE;  /* is this item utf8?   */
10125 #ifdef HAS_LDBL_SPRINTF_BUG
10126         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10127            with sfio - Allen <allens@cpan.org> */
10128         bool fix_ldbl_sprintf_bug = FALSE;
10129 #endif
10130
10131         char esignbuf[4];
10132         U8 utf8buf[UTF8_MAXBYTES+1];
10133         STRLEN esignlen = 0;
10134
10135         const char *eptr = NULL;
10136         const char *fmtstart;
10137         STRLEN elen = 0;
10138         SV *vecsv = NULL;
10139         const U8 *vecstr = NULL;
10140         STRLEN veclen = 0;
10141         char c = 0;
10142         int i;
10143         unsigned base = 0;
10144         IV iv = 0;
10145         UV uv = 0;
10146         /* we need a long double target in case HAS_LONG_DOUBLE but
10147            not USE_LONG_DOUBLE
10148         */
10149 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
10150         long double nv;
10151 #else
10152         NV nv;
10153 #endif
10154         STRLEN have;
10155         STRLEN need;
10156         STRLEN gap;
10157         const char *dotstr = ".";
10158         STRLEN dotstrlen = 1;
10159         I32 efix = 0; /* explicit format parameter index */
10160         I32 ewix = 0; /* explicit width index */
10161         I32 epix = 0; /* explicit precision index */
10162         I32 evix = 0; /* explicit vector index */
10163         bool asterisk = FALSE;
10164
10165         /* echo everything up to the next format specification */
10166         for (q = p; q < patend && *q != '%'; ++q) ;
10167         if (q > p) {
10168             if (has_utf8 && !pat_utf8)
10169                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
10170             else
10171                 sv_catpvn(sv, p, q - p);
10172             p = q;
10173         }
10174         if (q++ >= patend)
10175             break;
10176
10177         fmtstart = q;
10178
10179 /*
10180     We allow format specification elements in this order:
10181         \d+\$              explicit format parameter index
10182         [-+ 0#]+           flags
10183         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
10184         0                  flag (as above): repeated to allow "v02"
10185         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
10186         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10187         [hlqLV]            size
10188     [%bcdefginopsuxDFOUX] format (mandatory)
10189 */
10190
10191         if (args) {
10192 /*
10193         As of perl5.9.3, printf format checking is on by default.
10194         Internally, perl uses %p formats to provide an escape to
10195         some extended formatting.  This block deals with those
10196         extensions: if it does not match, (char*)q is reset and
10197         the normal format processing code is used.
10198
10199         Currently defined extensions are:
10200                 %p              include pointer address (standard)
10201                 %-p     (SVf)   include an SV (previously %_)
10202                 %-<num>p        include an SV with precision <num>
10203                 %<num>p         reserved for future extensions
10204
10205         Robin Barker 2005-07-14
10206
10207                 %1p     (VDf)   removed.  RMB 2007-10-19
10208 */
10209             char* r = q;
10210             bool sv = FALSE;
10211             STRLEN n = 0;
10212             if (*q == '-')
10213                 sv = *q++;
10214             n = expect_number(&q);
10215             if (*q++ == 'p') {
10216                 if (sv) {                       /* SVf */
10217                     if (n) {
10218                         precis = n;
10219                         has_precis = TRUE;
10220                     }
10221                     argsv = MUTABLE_SV(va_arg(*args, void*));
10222                     eptr = SvPV_const(argsv, elen);
10223                     if (DO_UTF8(argsv))
10224                         is_utf8 = TRUE;
10225                     goto string;
10226                 }
10227                 else if (n) {
10228                     Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10229                                      "internal %%<num>p might conflict with future printf extensions");
10230                 }
10231             }
10232             q = r;
10233         }
10234
10235         if ( (width = expect_number(&q)) ) {
10236             if (*q == '$') {
10237                 ++q;
10238                 efix = width;
10239             } else {
10240                 goto gotwidth;
10241             }
10242         }
10243
10244         /* FLAGS */
10245
10246         while (*q) {
10247             switch (*q) {
10248             case ' ':
10249             case '+':
10250                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10251                     q++;
10252                 else
10253                     plus = *q++;
10254                 continue;
10255
10256             case '-':
10257                 left = TRUE;
10258                 q++;
10259                 continue;
10260
10261             case '0':
10262                 fill = *q++;
10263                 continue;
10264
10265             case '#':
10266                 alt = TRUE;
10267                 q++;
10268                 continue;
10269
10270             default:
10271                 break;
10272             }
10273             break;
10274         }
10275
10276       tryasterisk:
10277         if (*q == '*') {
10278             q++;
10279             if ( (ewix = expect_number(&q)) )
10280                 if (*q++ != '$')
10281                     goto unknown;
10282             asterisk = TRUE;
10283         }
10284         if (*q == 'v') {
10285             q++;
10286             if (vectorize)
10287                 goto unknown;
10288             if ((vectorarg = asterisk)) {
10289                 evix = ewix;
10290                 ewix = 0;
10291                 asterisk = FALSE;
10292             }
10293             vectorize = TRUE;
10294             goto tryasterisk;
10295         }
10296
10297         if (!asterisk)
10298         {
10299             if( *q == '0' )
10300                 fill = *q++;
10301             width = expect_number(&q);
10302         }
10303
10304         if (vectorize && vectorarg) {
10305             /* vectorizing, but not with the default "." */
10306             if (args)
10307                 vecsv = va_arg(*args, SV*);
10308             else if (evix) {
10309                 vecsv = (evix > 0 && evix <= svmax)
10310                     ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10311             } else {
10312                 vecsv = svix < svmax
10313                     ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10314             }
10315             dotstr = SvPV_const(vecsv, dotstrlen);
10316             /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10317                bad with tied or overloaded values that return UTF8.  */
10318             if (DO_UTF8(vecsv))
10319                 is_utf8 = TRUE;
10320             else if (has_utf8) {
10321                 vecsv = sv_mortalcopy(vecsv);
10322                 sv_utf8_upgrade(vecsv);
10323                 dotstr = SvPV_const(vecsv, dotstrlen);
10324                 is_utf8 = TRUE;
10325             }
10326         }
10327
10328         if (asterisk) {
10329             if (args)
10330                 i = va_arg(*args, int);
10331             else
10332                 i = (ewix ? ewix <= svmax : svix < svmax) ?
10333                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10334             left |= (i < 0);
10335             width = (i < 0) ? -i : i;
10336         }
10337       gotwidth:
10338
10339         /* PRECISION */
10340
10341         if (*q == '.') {
10342             q++;
10343             if (*q == '*') {
10344                 q++;
10345                 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10346                     goto unknown;
10347                 /* XXX: todo, support specified precision parameter */
10348                 if (epix)
10349                     goto unknown;
10350                 if (args)
10351                     i = va_arg(*args, int);
10352                 else
10353                     i = (ewix ? ewix <= svmax : svix < svmax)
10354                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10355                 precis = i;
10356                 has_precis = !(i < 0);
10357             }
10358             else {
10359                 precis = 0;
10360                 while (isDIGIT(*q))
10361                     precis = precis * 10 + (*q++ - '0');
10362                 has_precis = TRUE;
10363             }
10364         }
10365
10366         if (vectorize) {
10367             if (args) {
10368                 VECTORIZE_ARGS
10369             }
10370             else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10371                 vecsv = svargs[efix ? efix-1 : svix++];
10372                 vecstr = (U8*)SvPV_const(vecsv,veclen);
10373                 vec_utf8 = DO_UTF8(vecsv);
10374
10375                 /* if this is a version object, we need to convert
10376                  * back into v-string notation and then let the
10377                  * vectorize happen normally
10378                  */
10379                 if (sv_derived_from(vecsv, "version")) {
10380                     char *version = savesvpv(vecsv);
10381                     if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10382                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
10383                         "vector argument not supported with alpha versions");
10384                         goto unknown;
10385                     }
10386                     vecsv = sv_newmortal();
10387                     scan_vstring(version, version + veclen, vecsv);
10388                     vecstr = (U8*)SvPV_const(vecsv, veclen);
10389                     vec_utf8 = DO_UTF8(vecsv);
10390                     Safefree(version);
10391                 }
10392             }
10393             else {
10394                 vecstr = (U8*)"";
10395                 veclen = 0;
10396             }
10397         }
10398
10399         /* SIZE */
10400
10401         switch (*q) {
10402 #ifdef WIN32
10403         case 'I':                       /* Ix, I32x, and I64x */
10404 #  ifdef WIN64
10405             if (q[1] == '6' && q[2] == '4') {
10406                 q += 3;
10407                 intsize = 'q';
10408                 break;
10409             }
10410 #  endif
10411             if (q[1] == '3' && q[2] == '2') {
10412                 q += 3;
10413                 break;
10414             }
10415 #  ifdef WIN64
10416             intsize = 'q';
10417 #  endif
10418             q++;
10419             break;
10420 #endif
10421 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10422         case 'L':                       /* Ld */
10423             /*FALLTHROUGH*/
10424 #ifdef HAS_QUAD
10425         case 'q':                       /* qd */
10426 #endif
10427             intsize = 'q';
10428             q++;
10429             break;
10430 #endif
10431         case 'l':
10432             ++q;
10433 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10434             if (*q == 'l') {    /* lld, llf */
10435                 intsize = 'q';
10436                 ++q;
10437             }
10438             else
10439 #endif
10440                 intsize = 'l';
10441             break;
10442         case 'h':
10443             if (*++q == 'h') {  /* hhd, hhu */
10444                 intsize = 'c';
10445                 ++q;
10446             }
10447             else
10448                 intsize = 'h';
10449             break;
10450         case 'V':
10451         case 'z':
10452         case 't':
10453 #if HAS_C99
10454         case 'j':
10455 #endif
10456             intsize = *q++;
10457             break;
10458         }
10459
10460         /* CONVERSION */
10461
10462         if (*q == '%') {
10463             eptr = q++;
10464             elen = 1;
10465             if (vectorize) {
10466                 c = '%';
10467                 goto unknown;
10468             }
10469             goto string;
10470         }
10471
10472         if (!vectorize && !args) {
10473             if (efix) {
10474                 const I32 i = efix-1;
10475                 argsv = (i >= 0 && i < svmax)
10476                     ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10477             } else {
10478                 argsv = (svix >= 0 && svix < svmax)
10479                     ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10480             }
10481         }
10482
10483         switch (c = *q++) {
10484
10485             /* STRINGS */
10486
10487         case 'c':
10488             if (vectorize)
10489                 goto unknown;
10490             uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10491             if ((uv > 255 ||
10492                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
10493                 && !IN_BYTES) {
10494                 eptr = (char*)utf8buf;
10495                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10496                 is_utf8 = TRUE;
10497             }
10498             else {
10499                 c = (char)uv;
10500                 eptr = &c;
10501                 elen = 1;
10502             }
10503             goto string;
10504
10505         case 's':
10506             if (vectorize)
10507                 goto unknown;
10508             if (args) {
10509                 eptr = va_arg(*args, char*);
10510                 if (eptr)
10511                     elen = strlen(eptr);
10512                 else {
10513                     eptr = (char *)nullstr;
10514                     elen = sizeof nullstr - 1;
10515                 }
10516             }
10517             else {
10518                 eptr = SvPV_const(argsv, elen);
10519                 if (DO_UTF8(argsv)) {
10520                     STRLEN old_precis = precis;
10521                     if (has_precis && precis < elen) {
10522                         STRLEN ulen = sv_len_utf8(argsv);
10523                         I32 p = precis > ulen ? ulen : precis;
10524                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10525                         precis = p;
10526                     }
10527                     if (width) { /* fudge width (can't fudge elen) */
10528                         if (has_precis && precis < elen)
10529                             width += precis - old_precis;
10530                         else
10531                             width += elen - sv_len_utf8(argsv);
10532                     }
10533                     is_utf8 = TRUE;
10534                 }
10535             }
10536
10537         string:
10538             if (has_precis && precis < elen)
10539                 elen = precis;
10540             break;
10541
10542             /* INTEGERS */
10543
10544         case 'p':
10545             if (alt || vectorize)
10546                 goto unknown;
10547             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10548             base = 16;
10549             goto integer;
10550
10551         case 'D':
10552 #ifdef IV_IS_QUAD
10553             intsize = 'q';
10554 #else
10555             intsize = 'l';
10556 #endif
10557             /*FALLTHROUGH*/
10558         case 'd':
10559         case 'i':
10560 #if vdNUMBER
10561         format_vd:
10562 #endif
10563             if (vectorize) {
10564                 STRLEN ulen;
10565                 if (!veclen)
10566                     continue;
10567                 if (vec_utf8)
10568                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10569                                         UTF8_ALLOW_ANYUV);
10570                 else {
10571                     uv = *vecstr;
10572                     ulen = 1;
10573                 }
10574                 vecstr += ulen;
10575                 veclen -= ulen;
10576                 if (plus)
10577                      esignbuf[esignlen++] = plus;
10578             }
10579             else if (args) {
10580                 switch (intsize) {
10581                 case 'c':       iv = (char)va_arg(*args, int); break;
10582                 case 'h':       iv = (short)va_arg(*args, int); break;
10583                 case 'l':       iv = va_arg(*args, long); break;
10584                 case 'V':       iv = va_arg(*args, IV); break;
10585                 case 'z':       iv = va_arg(*args, SSize_t); break;
10586                 case 't':       iv = va_arg(*args, ptrdiff_t); break;
10587                 default:        iv = va_arg(*args, int); break;
10588 #if HAS_C99
10589                 case 'j':       iv = va_arg(*args, intmax_t); break;
10590 #endif
10591                 case 'q':
10592 #ifdef HAS_QUAD
10593                                 iv = va_arg(*args, Quad_t); break;
10594 #else
10595                                 goto unknown;
10596 #endif
10597                 }
10598             }
10599             else {
10600                 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10601                 switch (intsize) {
10602                 case 'c':       iv = (char)tiv; break;
10603                 case 'h':       iv = (short)tiv; break;
10604                 case 'l':       iv = (long)tiv; break;
10605                 case 'V':
10606                 default:        iv = tiv; break;
10607                 case 'q':
10608 #ifdef HAS_QUAD
10609                                 iv = (Quad_t)tiv; break;
10610 #else
10611                                 goto unknown;
10612 #endif
10613                 }
10614             }
10615             if ( !vectorize )   /* we already set uv above */
10616             {
10617                 if (iv >= 0) {
10618                     uv = iv;
10619                     if (plus)
10620                         esignbuf[esignlen++] = plus;
10621                 }
10622                 else {
10623                     uv = -iv;
10624                     esignbuf[esignlen++] = '-';
10625                 }
10626             }
10627             base = 10;
10628             goto integer;
10629
10630         case 'U':
10631 #ifdef IV_IS_QUAD
10632             intsize = 'q';
10633 #else
10634             intsize = 'l';
10635 #endif
10636             /*FALLTHROUGH*/
10637         case 'u':
10638             base = 10;
10639             goto uns_integer;
10640
10641         case 'B':
10642         case 'b':
10643             base = 2;
10644             goto uns_integer;
10645
10646         case 'O':
10647 #ifdef IV_IS_QUAD
10648             intsize = 'q';
10649 #else
10650             intsize = 'l';
10651 #endif
10652             /*FALLTHROUGH*/
10653         case 'o':
10654             base = 8;
10655             goto uns_integer;
10656
10657         case 'X':
10658         case 'x':
10659             base = 16;
10660
10661         uns_integer:
10662             if (vectorize) {
10663                 STRLEN ulen;
10664         vector:
10665                 if (!veclen)
10666                     continue;
10667                 if (vec_utf8)
10668                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10669                                         UTF8_ALLOW_ANYUV);
10670                 else {
10671                     uv = *vecstr;
10672                     ulen = 1;
10673                 }
10674                 vecstr += ulen;
10675                 veclen -= ulen;
10676             }
10677             else if (args) {
10678                 switch (intsize) {
10679                 case 'c':  uv = (unsigned char)va_arg(*args, unsigned); break;
10680                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
10681                 case 'l':  uv = va_arg(*args, unsigned long); break;
10682                 case 'V':  uv = va_arg(*args, UV); break;
10683                 case 'z':  uv = va_arg(*args, Size_t); break;
10684                 case 't':  uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
10685 #if HAS_C99
10686                 case 'j':  uv = va_arg(*args, uintmax_t); break;
10687 #endif
10688                 default:   uv = va_arg(*args, unsigned); break;
10689                 case 'q':
10690 #ifdef HAS_QUAD
10691                            uv = va_arg(*args, Uquad_t); break;
10692 #else
10693                            goto unknown;
10694 #endif
10695                 }
10696             }
10697             else {
10698                 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10699                 switch (intsize) {
10700                 case 'c':       uv = (unsigned char)tuv; break;
10701                 case 'h':       uv = (unsigned short)tuv; break;
10702                 case 'l':       uv = (unsigned long)tuv; break;
10703                 case 'V':
10704                 default:        uv = tuv; break;
10705                 case 'q':
10706 #ifdef HAS_QUAD
10707                                 uv = (Uquad_t)tuv; break;
10708 #else
10709                                 goto unknown;
10710 #endif
10711                 }
10712             }
10713
10714         integer:
10715             {
10716                 char *ptr = ebuf + sizeof ebuf;
10717                 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10718                 zeros = 0;
10719
10720                 switch (base) {
10721                     unsigned dig;
10722                 case 16:
10723                     p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10724                     do {
10725                         dig = uv & 15;
10726                         *--ptr = p[dig];
10727                     } while (uv >>= 4);
10728                     if (tempalt) {
10729                         esignbuf[esignlen++] = '0';
10730                         esignbuf[esignlen++] = c;  /* 'x' or 'X' */
10731                     }
10732                     break;
10733                 case 8:
10734                     do {
10735                         dig = uv & 7;
10736                         *--ptr = '0' + dig;
10737                     } while (uv >>= 3);
10738                     if (alt && *ptr != '0')
10739                         *--ptr = '0';
10740                     break;
10741                 case 2:
10742                     do {
10743                         dig = uv & 1;
10744                         *--ptr = '0' + dig;
10745                     } while (uv >>= 1);
10746                     if (tempalt) {
10747                         esignbuf[esignlen++] = '0';
10748                         esignbuf[esignlen++] = c;
10749                     }
10750                     break;
10751                 default:                /* it had better be ten or less */
10752                     do {
10753                         dig = uv % base;
10754                         *--ptr = '0' + dig;
10755                     } while (uv /= base);
10756                     break;
10757                 }
10758                 elen = (ebuf + sizeof ebuf) - ptr;
10759                 eptr = ptr;
10760                 if (has_precis) {
10761                     if (precis > elen)
10762                         zeros = precis - elen;
10763                     else if (precis == 0 && elen == 1 && *eptr == '0'
10764                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10765                         elen = 0;
10766
10767                 /* a precision nullifies the 0 flag. */
10768                     if (fill == '0')
10769                         fill = ' ';
10770                 }
10771             }
10772             break;
10773
10774             /* FLOATING POINT */
10775
10776         case 'F':
10777             c = 'f';            /* maybe %F isn't supported here */
10778             /*FALLTHROUGH*/
10779         case 'e': case 'E':
10780         case 'f':
10781         case 'g': case 'G':
10782             if (vectorize)
10783                 goto unknown;
10784
10785             /* This is evil, but floating point is even more evil */
10786
10787             /* for SV-style calling, we can only get NV
10788                for C-style calling, we assume %f is double;
10789                for simplicity we allow any of %Lf, %llf, %qf for long double
10790             */
10791             switch (intsize) {
10792             case 'V':
10793 #if defined(USE_LONG_DOUBLE)
10794                 intsize = 'q';
10795 #endif
10796                 break;
10797 /* [perl #20339] - we should accept and ignore %lf rather than die */
10798             case 'l':
10799                 /*FALLTHROUGH*/
10800             default:
10801 #if defined(USE_LONG_DOUBLE)
10802                 intsize = args ? 0 : 'q';
10803 #endif
10804                 break;
10805             case 'q':
10806 #if defined(HAS_LONG_DOUBLE)
10807                 break;
10808 #else
10809                 /*FALLTHROUGH*/
10810 #endif
10811             case 'c':
10812             case 'h':
10813             case 'z':
10814             case 't':
10815             case 'j':
10816                 goto unknown;
10817             }
10818
10819             /* now we need (long double) if intsize == 'q', else (double) */
10820             nv = (args) ?
10821 #if LONG_DOUBLESIZE > DOUBLESIZE
10822                 intsize == 'q' ?
10823                     va_arg(*args, long double) :
10824                     va_arg(*args, double)
10825 #else
10826                     va_arg(*args, double)
10827 #endif
10828                 : SvNV(argsv);
10829
10830             need = 0;
10831             /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10832                else. frexp() has some unspecified behaviour for those three */
10833             if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10834                 i = PERL_INT_MIN;
10835                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10836                    will cast our (long double) to (double) */
10837                 (void)Perl_frexp(nv, &i);
10838                 if (i == PERL_INT_MIN)
10839                     Perl_die(aTHX_ "panic: frexp");
10840                 if (i > 0)
10841                     need = BIT_DIGITS(i);
10842             }
10843             need += has_precis ? precis : 6; /* known default */
10844
10845             if (need < width)
10846                 need = width;
10847
10848 #ifdef HAS_LDBL_SPRINTF_BUG
10849             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10850                with sfio - Allen <allens@cpan.org> */
10851
10852 #  ifdef DBL_MAX
10853 #    define MY_DBL_MAX DBL_MAX
10854 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10855 #    if DOUBLESIZE >= 8
10856 #      define MY_DBL_MAX 1.7976931348623157E+308L
10857 #    else
10858 #      define MY_DBL_MAX 3.40282347E+38L
10859 #    endif
10860 #  endif
10861
10862 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10863 #    define MY_DBL_MAX_BUG 1L
10864 #  else
10865 #    define MY_DBL_MAX_BUG MY_DBL_MAX
10866 #  endif
10867
10868 #  ifdef DBL_MIN
10869 #    define MY_DBL_MIN DBL_MIN
10870 #  else  /* XXX guessing! -Allen */
10871 #    if DOUBLESIZE >= 8
10872 #      define MY_DBL_MIN 2.2250738585072014E-308L
10873 #    else
10874 #      define MY_DBL_MIN 1.17549435E-38L
10875 #    endif
10876 #  endif
10877
10878             if ((intsize == 'q') && (c == 'f') &&
10879                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10880                 (need < DBL_DIG)) {
10881                 /* it's going to be short enough that
10882                  * long double precision is not needed */
10883
10884                 if ((nv <= 0L) && (nv >= -0L))
10885                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10886                 else {
10887                     /* would use Perl_fp_class as a double-check but not
10888                      * functional on IRIX - see perl.h comments */
10889
10890                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10891                         /* It's within the range that a double can represent */
10892 #if defined(DBL_MAX) && !defined(DBL_MIN)
10893                         if ((nv >= ((long double)1/DBL_MAX)) ||
10894                             (nv <= (-(long double)1/DBL_MAX)))
10895 #endif
10896                         fix_ldbl_sprintf_bug = TRUE;
10897                     }
10898                 }
10899                 if (fix_ldbl_sprintf_bug == TRUE) {
10900                     double temp;
10901
10902                     intsize = 0;
10903                     temp = (double)nv;
10904                     nv = (NV)temp;
10905                 }
10906             }
10907
10908 #  undef MY_DBL_MAX
10909 #  undef MY_DBL_MAX_BUG
10910 #  undef MY_DBL_MIN
10911
10912 #endif /* HAS_LDBL_SPRINTF_BUG */
10913
10914             need += 20; /* fudge factor */
10915             if (PL_efloatsize < need) {
10916                 Safefree(PL_efloatbuf);
10917                 PL_efloatsize = need + 20; /* more fudge */
10918                 Newx(PL_efloatbuf, PL_efloatsize, char);
10919                 PL_efloatbuf[0] = '\0';
10920             }
10921
10922             if ( !(width || left || plus || alt) && fill != '0'
10923                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
10924                 /* See earlier comment about buggy Gconvert when digits,
10925                    aka precis is 0  */
10926                 if ( c == 'g' && precis) {
10927                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10928                     /* May return an empty string for digits==0 */
10929                     if (*PL_efloatbuf) {
10930                         elen = strlen(PL_efloatbuf);
10931                         goto float_converted;
10932                     }
10933                 } else if ( c == 'f' && !precis) {
10934                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10935                         break;
10936                 }
10937             }
10938             {
10939                 char *ptr = ebuf + sizeof ebuf;
10940                 *--ptr = '\0';
10941                 *--ptr = c;
10942                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10943 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10944                 if (intsize == 'q') {
10945                     /* Copy the one or more characters in a long double
10946                      * format before the 'base' ([efgEFG]) character to
10947                      * the format string. */
10948                     static char const prifldbl[] = PERL_PRIfldbl;
10949                     char const *p = prifldbl + sizeof(prifldbl) - 3;
10950                     while (p >= prifldbl) { *--ptr = *p--; }
10951                 }
10952 #endif
10953                 if (has_precis) {
10954                     base = precis;
10955                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10956                     *--ptr = '.';
10957                 }
10958                 if (width) {
10959                     base = width;
10960                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10961                 }
10962                 if (fill == '0')
10963                     *--ptr = fill;
10964                 if (left)
10965                     *--ptr = '-';
10966                 if (plus)
10967                     *--ptr = plus;
10968                 if (alt)
10969                     *--ptr = '#';
10970                 *--ptr = '%';
10971
10972                 /* No taint.  Otherwise we are in the strange situation
10973                  * where printf() taints but print($float) doesn't.
10974                  * --jhi */
10975 #if defined(HAS_LONG_DOUBLE)
10976                 elen = ((intsize == 'q')
10977                         ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10978                         : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10979 #else
10980                 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10981 #endif
10982             }
10983         float_converted:
10984             eptr = PL_efloatbuf;
10985             break;
10986
10987             /* SPECIAL */
10988
10989         case 'n':
10990             if (vectorize)
10991                 goto unknown;
10992             i = SvCUR(sv) - origlen;
10993             if (args) {
10994                 switch (intsize) {
10995                 case 'c':       *(va_arg(*args, char*)) = i; break;
10996                 case 'h':       *(va_arg(*args, short*)) = i; break;
10997                 default:        *(va_arg(*args, int*)) = i; break;
10998                 case 'l':       *(va_arg(*args, long*)) = i; break;
10999                 case 'V':       *(va_arg(*args, IV*)) = i; break;
11000                 case 'z':       *(va_arg(*args, SSize_t*)) = i; break;
11001                 case 't':       *(va_arg(*args, ptrdiff_t*)) = i; break;
11002 #if HAS_C99
11003                 case 'j':       *(va_arg(*args, intmax_t*)) = i; break;
11004 #endif
11005                 case 'q':
11006 #ifdef HAS_QUAD
11007                                 *(va_arg(*args, Quad_t*)) = i; break;
11008 #else
11009                                 goto unknown;
11010 #endif
11011                 }
11012             }
11013             else
11014                 sv_setuv_mg(argsv, (UV)i);
11015             continue;   /* not "break" */
11016
11017             /* UNKNOWN */
11018
11019         default:
11020       unknown:
11021             if (!args
11022                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
11023                 && ckWARN(WARN_PRINTF))
11024             {
11025                 SV * const msg = sv_newmortal();
11026                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
11027                           (PL_op->op_type == OP_PRTF) ? "" : "s");
11028                 if (fmtstart < patend) {
11029                     const char * const fmtend = q < patend ? q : patend;
11030                     const char * f;
11031                     sv_catpvs(msg, "\"%");
11032                     for (f = fmtstart; f < fmtend; f++) {
11033                         if (isPRINT(*f)) {
11034                             sv_catpvn(msg, f, 1);
11035                         } else {
11036                             Perl_sv_catpvf(aTHX_ msg,
11037                                            "\\%03"UVof, (UV)*f & 0xFF);
11038                         }
11039                     }
11040                     sv_catpvs(msg, "\"");
11041                 } else {
11042                     sv_catpvs(msg, "end of string");
11043                 }
11044                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
11045             }
11046
11047             /* output mangled stuff ... */
11048             if (c == '\0')
11049                 --q;
11050             eptr = p;
11051             elen = q - p;
11052
11053             /* ... right here, because formatting flags should not apply */
11054             SvGROW(sv, SvCUR(sv) + elen + 1);
11055             p = SvEND(sv);
11056             Copy(eptr, p, elen, char);
11057             p += elen;
11058             *p = '\0';
11059             SvCUR_set(sv, p - SvPVX_const(sv));
11060             svix = osvix;
11061             continue;   /* not "break" */
11062         }
11063
11064         if (is_utf8 != has_utf8) {
11065             if (is_utf8) {
11066                 if (SvCUR(sv))
11067                     sv_utf8_upgrade(sv);
11068             }
11069             else {
11070                 const STRLEN old_elen = elen;
11071                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
11072                 sv_utf8_upgrade(nsv);
11073                 eptr = SvPVX_const(nsv);
11074                 elen = SvCUR(nsv);
11075
11076                 if (width) { /* fudge width (can't fudge elen) */
11077                     width += elen - old_elen;
11078                 }
11079                 is_utf8 = TRUE;
11080             }
11081         }
11082
11083         have = esignlen + zeros + elen;
11084         if (have < zeros)
11085             Perl_croak_nocontext("%s", PL_memory_wrap);
11086
11087         need = (have > width ? have : width);
11088         gap = need - have;
11089
11090         if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
11091             Perl_croak_nocontext("%s", PL_memory_wrap);
11092         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
11093         p = SvEND(sv);
11094         if (esignlen && fill == '0') {
11095             int i;
11096             for (i = 0; i < (int)esignlen; i++)
11097                 *p++ = esignbuf[i];
11098         }
11099         if (gap && !left) {
11100             memset(p, fill, gap);
11101             p += gap;
11102         }
11103         if (esignlen && fill != '0') {
11104             int i;
11105             for (i = 0; i < (int)esignlen; i++)
11106                 *p++ = esignbuf[i];
11107         }
11108         if (zeros) {
11109             int i;
11110             for (i = zeros; i; i--)
11111                 *p++ = '0';
11112         }
11113         if (elen) {
11114             Copy(eptr, p, elen, char);
11115             p += elen;
11116         }
11117         if (gap && left) {
11118             memset(p, ' ', gap);
11119             p += gap;
11120         }
11121         if (vectorize) {
11122             if (veclen) {
11123                 Copy(dotstr, p, dotstrlen, char);
11124                 p += dotstrlen;
11125             }
11126             else
11127                 vectorize = FALSE;              /* done iterating over vecstr */
11128         }
11129         if (is_utf8)
11130             has_utf8 = TRUE;
11131         if (has_utf8)
11132             SvUTF8_on(sv);
11133         *p = '\0';
11134         SvCUR_set(sv, p - SvPVX_const(sv));
11135         if (vectorize) {
11136             esignlen = 0;
11137             goto vector;
11138         }
11139     }
11140     SvTAINT(sv);
11141 }
11142
11143 /* =========================================================================
11144
11145 =head1 Cloning an interpreter
11146
11147 All the macros and functions in this section are for the private use of
11148 the main function, perl_clone().
11149
11150 The foo_dup() functions make an exact copy of an existing foo thingy.
11151 During the course of a cloning, a hash table is used to map old addresses
11152 to new addresses. The table is created and manipulated with the
11153 ptr_table_* functions.
11154
11155 =cut
11156
11157  * =========================================================================*/
11158
11159
11160 #if defined(USE_ITHREADS)
11161
11162 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
11163 #ifndef GpREFCNT_inc
11164 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
11165 #endif
11166
11167
11168 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
11169    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
11170    If this changes, please unmerge ss_dup.
11171    Likewise, sv_dup_inc_multiple() relies on this fact.  */
11172 #define sv_dup_inc_NN(s,t)      SvREFCNT_inc_NN(sv_dup_inc(s,t))
11173 #define av_dup(s,t)     MUTABLE_AV(sv_dup((const SV *)s,t))
11174 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11175 #define hv_dup(s,t)     MUTABLE_HV(sv_dup((const SV *)s,t))
11176 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11177 #define cv_dup(s,t)     MUTABLE_CV(sv_dup((const SV *)s,t))
11178 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
11179 #define io_dup(s,t)     MUTABLE_IO(sv_dup((const SV *)s,t))
11180 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
11181 #define gv_dup(s,t)     MUTABLE_GV(sv_dup((const SV *)s,t))
11182 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
11183 #define SAVEPV(p)       ((p) ? savepv(p) : NULL)
11184 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
11185
11186 /* clone a parser */
11187
11188 yy_parser *
11189 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
11190 {
11191     yy_parser *parser;
11192
11193     PERL_ARGS_ASSERT_PARSER_DUP;
11194
11195     if (!proto)
11196         return NULL;
11197
11198     /* look for it in the table first */
11199     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11200     if (parser)
11201         return parser;
11202
11203     /* create anew and remember what it is */
11204     Newxz(parser, 1, yy_parser);
11205     ptr_table_store(PL_ptr_table, proto, parser);
11206
11207     /* XXX these not yet duped */
11208     parser->old_parser = NULL;
11209     parser->stack = NULL;
11210     parser->ps = NULL;
11211     parser->stack_size = 0;
11212     /* XXX parser->stack->state = 0; */
11213
11214     /* XXX eventually, just Copy() most of the parser struct ? */
11215
11216     parser->lex_brackets = proto->lex_brackets;
11217     parser->lex_casemods = proto->lex_casemods;
11218     parser->lex_brackstack = savepvn(proto->lex_brackstack,
11219                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11220     parser->lex_casestack = savepvn(proto->lex_casestack,
11221                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11222     parser->lex_defer   = proto->lex_defer;
11223     parser->lex_dojoin  = proto->lex_dojoin;
11224     parser->lex_expect  = proto->lex_expect;
11225     parser->lex_formbrack = proto->lex_formbrack;
11226     parser->lex_inpat   = proto->lex_inpat;
11227     parser->lex_inwhat  = proto->lex_inwhat;
11228     parser->lex_op      = proto->lex_op;
11229     parser->lex_repl    = sv_dup_inc(proto->lex_repl, param);
11230     parser->lex_starts  = proto->lex_starts;
11231     parser->lex_stuff   = sv_dup_inc(proto->lex_stuff, param);
11232     parser->multi_close = proto->multi_close;
11233     parser->multi_open  = proto->multi_open;
11234     parser->multi_start = proto->multi_start;
11235     parser->multi_end   = proto->multi_end;
11236     parser->pending_ident = proto->pending_ident;
11237     parser->preambled   = proto->preambled;
11238     parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11239     parser->linestr     = sv_dup_inc(proto->linestr, param);
11240     parser->expect      = proto->expect;
11241     parser->copline     = proto->copline;
11242     parser->last_lop_op = proto->last_lop_op;
11243     parser->lex_state   = proto->lex_state;
11244     parser->rsfp        = fp_dup(proto->rsfp, '<', param);
11245     /* rsfp_filters entries have fake IoDIRP() */
11246     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11247     parser->in_my       = proto->in_my;
11248     parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11249     parser->error_count = proto->error_count;
11250
11251
11252     parser->linestr     = sv_dup_inc(proto->linestr, param);
11253
11254     {
11255         char * const ols = SvPVX(proto->linestr);
11256         char * const ls  = SvPVX(parser->linestr);
11257
11258         parser->bufptr      = ls + (proto->bufptr >= ols ?
11259                                     proto->bufptr -  ols : 0);
11260         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
11261                                     proto->oldbufptr -  ols : 0);
11262         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11263                                     proto->oldoldbufptr -  ols : 0);
11264         parser->linestart   = ls + (proto->linestart >= ols ?
11265                                     proto->linestart -  ols : 0);
11266         parser->last_uni    = ls + (proto->last_uni >= ols ?
11267                                     proto->last_uni -  ols : 0);
11268         parser->last_lop    = ls + (proto->last_lop >= ols ?
11269                                     proto->last_lop -  ols : 0);
11270
11271         parser->bufend      = ls + SvCUR(parser->linestr);
11272     }
11273
11274     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11275
11276
11277 #ifdef PERL_MAD
11278     parser->endwhite    = proto->endwhite;
11279     parser->faketokens  = proto->faketokens;
11280     parser->lasttoke    = proto->lasttoke;
11281     parser->nextwhite   = proto->nextwhite;
11282     parser->realtokenstart = proto->realtokenstart;
11283     parser->skipwhite   = proto->skipwhite;
11284     parser->thisclose   = proto->thisclose;
11285     parser->thismad     = proto->thismad;
11286     parser->thisopen    = proto->thisopen;
11287     parser->thisstuff   = proto->thisstuff;
11288     parser->thistoken   = proto->thistoken;
11289     parser->thiswhite   = proto->thiswhite;
11290
11291     Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11292     parser->curforce    = proto->curforce;
11293 #else
11294     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11295     Copy(proto->nexttype, parser->nexttype, 5,  I32);
11296     parser->nexttoke    = proto->nexttoke;
11297 #endif
11298
11299     /* XXX should clone saved_curcop here, but we aren't passed
11300      * proto_perl; so do it in perl_clone_using instead */
11301
11302     return parser;
11303 }
11304
11305
11306 /* duplicate a file handle */
11307
11308 PerlIO *
11309 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11310 {
11311     PerlIO *ret;
11312
11313     PERL_ARGS_ASSERT_FP_DUP;
11314     PERL_UNUSED_ARG(type);
11315
11316     if (!fp)
11317         return (PerlIO*)NULL;
11318
11319     /* look for it in the table first */
11320     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11321     if (ret)
11322         return ret;
11323
11324     /* create anew and remember what it is */
11325     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11326     ptr_table_store(PL_ptr_table, fp, ret);
11327     return ret;
11328 }
11329
11330 /* duplicate a directory handle */
11331
11332 DIR *
11333 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11334 {
11335     DIR *ret;
11336
11337 #ifdef HAS_FCHDIR
11338     DIR *pwd;
11339     register const Direntry_t *dirent;
11340     char smallbuf[256];
11341     char *name = NULL;
11342     STRLEN len = -1;
11343     long pos;
11344 #endif
11345
11346     PERL_UNUSED_CONTEXT;
11347     PERL_ARGS_ASSERT_DIRP_DUP;
11348
11349     if (!dp)
11350         return (DIR*)NULL;
11351
11352     /* look for it in the table first */
11353     ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11354     if (ret)
11355         return ret;
11356
11357 #ifdef HAS_FCHDIR
11358
11359     PERL_UNUSED_ARG(param);
11360
11361     /* create anew */
11362
11363     /* open the current directory (so we can switch back) */
11364     if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11365
11366     /* chdir to our dir handle and open the present working directory */
11367     if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11368         PerlDir_close(pwd);
11369         return (DIR *)NULL;
11370     }
11371     /* Now we should have two dir handles pointing to the same dir. */
11372
11373     /* Be nice to the calling code and chdir back to where we were. */
11374     fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11375
11376     /* We have no need of the pwd handle any more. */
11377     PerlDir_close(pwd);
11378
11379 #ifdef DIRNAMLEN
11380 # define d_namlen(d) (d)->d_namlen
11381 #else
11382 # define d_namlen(d) strlen((d)->d_name)
11383 #endif
11384     /* Iterate once through dp, to get the file name at the current posi-
11385        tion. Then step back. */
11386     pos = PerlDir_tell(dp);
11387     if ((dirent = PerlDir_read(dp))) {
11388         len = d_namlen(dirent);
11389         if (len <= sizeof smallbuf) name = smallbuf;
11390         else Newx(name, len, char);
11391         Move(dirent->d_name, name, len, char);
11392     }
11393     PerlDir_seek(dp, pos);
11394
11395     /* Iterate through the new dir handle, till we find a file with the
11396        right name. */
11397     if (!dirent) /* just before the end */
11398         for(;;) {
11399             pos = PerlDir_tell(ret);
11400             if (PerlDir_read(ret)) continue; /* not there yet */
11401             PerlDir_seek(ret, pos); /* step back */
11402             break;
11403         }
11404     else {
11405         const long pos0 = PerlDir_tell(ret);
11406         for(;;) {
11407             pos = PerlDir_tell(ret);
11408             if ((dirent = PerlDir_read(ret))) {
11409                 if (len == d_namlen(dirent)
11410                  && memEQ(name, dirent->d_name, len)) {
11411                     /* found it */
11412                     PerlDir_seek(ret, pos); /* step back */
11413                     break;
11414                 }
11415                 /* else we are not there yet; keep iterating */
11416             }
11417             else { /* This is not meant to happen. The best we can do is
11418                       reset the iterator to the beginning. */
11419                 PerlDir_seek(ret, pos0);
11420                 break;
11421             }
11422         }
11423     }
11424 #undef d_namlen
11425
11426     if (name && name != smallbuf)
11427         Safefree(name);
11428 #endif
11429
11430 #ifdef WIN32
11431     ret = win32_dirp_dup(dp, param);
11432 #endif
11433
11434     /* pop it in the pointer table */
11435     if (ret)
11436         ptr_table_store(PL_ptr_table, dp, ret);
11437
11438     return ret;
11439 }
11440
11441 /* duplicate a typeglob */
11442
11443 GP *
11444 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11445 {
11446     GP *ret;
11447
11448     PERL_ARGS_ASSERT_GP_DUP;
11449
11450     if (!gp)
11451         return (GP*)NULL;
11452     /* look for it in the table first */
11453     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11454     if (ret)
11455         return ret;
11456
11457     /* create anew and remember what it is */
11458     Newxz(ret, 1, GP);
11459     ptr_table_store(PL_ptr_table, gp, ret);
11460
11461     /* clone */
11462     /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11463        on Newxz() to do this for us.  */
11464     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
11465     ret->gp_io          = io_dup_inc(gp->gp_io, param);
11466     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
11467     ret->gp_av          = av_dup_inc(gp->gp_av, param);
11468     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
11469     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11470     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
11471     ret->gp_cvgen       = gp->gp_cvgen;
11472     ret->gp_line        = gp->gp_line;
11473     ret->gp_file_hek    = hek_dup(gp->gp_file_hek, param);
11474     return ret;
11475 }
11476
11477 /* duplicate a chain of magic */
11478
11479 MAGIC *
11480 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11481 {
11482     MAGIC *mgret = NULL;
11483     MAGIC **mgprev_p = &mgret;
11484
11485     PERL_ARGS_ASSERT_MG_DUP;
11486
11487     for (; mg; mg = mg->mg_moremagic) {
11488         MAGIC *nmg;
11489
11490         if ((param->flags & CLONEf_JOIN_IN)
11491                 && mg->mg_type == PERL_MAGIC_backref)
11492             /* when joining, we let the individual SVs add themselves to
11493              * backref as needed. */
11494             continue;
11495
11496         Newx(nmg, 1, MAGIC);
11497         *mgprev_p = nmg;
11498         mgprev_p = &(nmg->mg_moremagic);
11499
11500         /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11501            dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11502            from the original commit adding Perl_mg_dup() - revision 4538.
11503            Similarly there is the annotation "XXX random ptr?" next to the
11504            assignment to nmg->mg_ptr.  */
11505         *nmg = *mg;
11506
11507         /* FIXME for plugins
11508         if (nmg->mg_type == PERL_MAGIC_qr) {
11509             nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11510         }
11511         else
11512         */
11513         nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11514                           ? nmg->mg_type == PERL_MAGIC_backref
11515                                 /* The backref AV has its reference
11516                                  * count deliberately bumped by 1 */
11517                                 ? SvREFCNT_inc(av_dup_inc((const AV *)
11518                                                     nmg->mg_obj, param))
11519                                 : sv_dup_inc(nmg->mg_obj, param)
11520                           : sv_dup(nmg->mg_obj, param);
11521
11522         if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11523             if (nmg->mg_len > 0) {
11524                 nmg->mg_ptr     = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11525                 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11526                         AMT_AMAGIC((AMT*)nmg->mg_ptr))
11527                 {
11528                     AMT * const namtp = (AMT*)nmg->mg_ptr;
11529                     sv_dup_inc_multiple((SV**)(namtp->table),
11530                                         (SV**)(namtp->table), NofAMmeth, param);
11531                 }
11532             }
11533             else if (nmg->mg_len == HEf_SVKEY)
11534                 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11535         }
11536         if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11537             nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11538         }
11539     }
11540     return mgret;
11541 }
11542
11543 #endif /* USE_ITHREADS */
11544
11545 struct ptr_tbl_arena {
11546     struct ptr_tbl_arena *next;
11547     struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers.  */
11548 };
11549
11550 /* create a new pointer-mapping table */
11551
11552 PTR_TBL_t *
11553 Perl_ptr_table_new(pTHX)
11554 {
11555     PTR_TBL_t *tbl;
11556     PERL_UNUSED_CONTEXT;
11557
11558     Newx(tbl, 1, PTR_TBL_t);
11559     tbl->tbl_max        = 511;
11560     tbl->tbl_items      = 0;
11561     tbl->tbl_arena      = NULL;
11562     tbl->tbl_arena_next = NULL;
11563     tbl->tbl_arena_end  = NULL;
11564     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11565     return tbl;
11566 }
11567
11568 #define PTR_TABLE_HASH(ptr) \
11569   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11570
11571 /* map an existing pointer using a table */
11572
11573 STATIC PTR_TBL_ENT_t *
11574 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11575 {
11576     PTR_TBL_ENT_t *tblent;
11577     const UV hash = PTR_TABLE_HASH(sv);
11578
11579     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11580
11581     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11582     for (; tblent; tblent = tblent->next) {
11583         if (tblent->oldval == sv)
11584             return tblent;
11585     }
11586     return NULL;
11587 }
11588
11589 void *
11590 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11591 {
11592     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11593
11594     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11595     PERL_UNUSED_CONTEXT;
11596
11597     return tblent ? tblent->newval : NULL;
11598 }
11599
11600 /* add a new entry to a pointer-mapping table */
11601
11602 void
11603 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
11604 {
11605     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
11606
11607     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
11608     PERL_UNUSED_CONTEXT;
11609
11610     if (tblent) {
11611         tblent->newval = newsv;
11612     } else {
11613         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
11614
11615         if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
11616             struct ptr_tbl_arena *new_arena;
11617
11618             Newx(new_arena, 1, struct ptr_tbl_arena);
11619             new_arena->next = tbl->tbl_arena;
11620             tbl->tbl_arena = new_arena;
11621             tbl->tbl_arena_next = new_arena->array;
11622             tbl->tbl_arena_end = new_arena->array
11623                 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
11624         }
11625
11626         tblent = tbl->tbl_arena_next++;
11627
11628         tblent->oldval = oldsv;
11629         tblent->newval = newsv;
11630         tblent->next = tbl->tbl_ary[entry];
11631         tbl->tbl_ary[entry] = tblent;
11632         tbl->tbl_items++;
11633         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
11634             ptr_table_split(tbl);
11635     }
11636 }
11637
11638 /* double the hash bucket size of an existing ptr table */
11639
11640 void
11641 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
11642 {
11643     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
11644     const UV oldsize = tbl->tbl_max + 1;
11645     UV newsize = oldsize * 2;
11646     UV i;
11647
11648     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11649     PERL_UNUSED_CONTEXT;
11650
11651     Renew(ary, newsize, PTR_TBL_ENT_t*);
11652     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11653     tbl->tbl_max = --newsize;
11654     tbl->tbl_ary = ary;
11655     for (i=0; i < oldsize; i++, ary++) {
11656         PTR_TBL_ENT_t **entp = ary;
11657         PTR_TBL_ENT_t *ent = *ary;
11658         PTR_TBL_ENT_t **curentp;
11659         if (!ent)
11660             continue;
11661         curentp = ary + oldsize;
11662         do {
11663             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11664                 *entp = ent->next;
11665                 ent->next = *curentp;
11666                 *curentp = ent;
11667             }
11668             else
11669                 entp = &ent->next;
11670             ent = *entp;
11671         } while (ent);
11672     }
11673 }
11674
11675 /* remove all the entries from a ptr table */
11676 /* Deprecated - will be removed post 5.14 */
11677
11678 void
11679 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11680 {
11681     if (tbl && tbl->tbl_items) {
11682         struct ptr_tbl_arena *arena = tbl->tbl_arena;
11683
11684         Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11685
11686         while (arena) {
11687             struct ptr_tbl_arena *next = arena->next;
11688
11689             Safefree(arena);
11690             arena = next;
11691         };
11692
11693         tbl->tbl_items = 0;
11694         tbl->tbl_arena = NULL;
11695         tbl->tbl_arena_next = NULL;
11696         tbl->tbl_arena_end = NULL;
11697     }
11698 }
11699
11700 /* clear and free a ptr table */
11701
11702 void
11703 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11704 {
11705     struct ptr_tbl_arena *arena;
11706
11707     if (!tbl) {
11708         return;
11709     }
11710
11711     arena = tbl->tbl_arena;
11712
11713     while (arena) {
11714         struct ptr_tbl_arena *next = arena->next;
11715
11716         Safefree(arena);
11717         arena = next;
11718     }
11719
11720     Safefree(tbl->tbl_ary);
11721     Safefree(tbl);
11722 }
11723
11724 #if defined(USE_ITHREADS)
11725
11726 void
11727 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11728 {
11729     PERL_ARGS_ASSERT_RVPV_DUP;
11730
11731     if (SvROK(sstr)) {
11732         if (SvWEAKREF(sstr)) {
11733             SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11734             if (param->flags & CLONEf_JOIN_IN) {
11735                 /* if joining, we add any back references individually rather
11736                  * than copying the whole backref array */
11737                 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11738             }
11739         }
11740         else
11741             SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11742     }
11743     else if (SvPVX_const(sstr)) {
11744         /* Has something there */
11745         if (SvLEN(sstr)) {
11746             /* Normal PV - clone whole allocated space */
11747             SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11748             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11749                 /* Not that normal - actually sstr is copy on write.
11750                    But we are a true, independent SV, so:  */
11751                 SvREADONLY_off(dstr);
11752                 SvFAKE_off(dstr);
11753             }
11754         }
11755         else {
11756             /* Special case - not normally malloced for some reason */
11757             if (isGV_with_GP(sstr)) {
11758                 /* Don't need to do anything here.  */
11759             }
11760             else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11761                 /* A "shared" PV - clone it as "shared" PV */
11762                 SvPV_set(dstr,
11763                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11764                                          param)));
11765             }
11766             else {
11767                 /* Some other special case - random pointer */
11768                 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11769             }
11770         }
11771     }
11772     else {
11773         /* Copy the NULL */
11774         SvPV_set(dstr, NULL);
11775     }
11776 }
11777
11778 /* duplicate a list of SVs. source and dest may point to the same memory.  */
11779 static SV **
11780 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11781                       SSize_t items, CLONE_PARAMS *const param)
11782 {
11783     PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11784
11785     while (items-- > 0) {
11786         *dest++ = sv_dup_inc(*source++, param);
11787     }
11788
11789     return dest;
11790 }
11791
11792 /* duplicate an SV of any type (including AV, HV etc) */
11793
11794 static SV *
11795 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11796 {
11797     dVAR;
11798     SV *dstr;
11799
11800     PERL_ARGS_ASSERT_SV_DUP_COMMON;
11801
11802     if (SvTYPE(sstr) == SVTYPEMASK) {
11803 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11804         abort();
11805 #endif
11806         return NULL;
11807     }
11808     /* look for it in the table first */
11809     dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11810     if (dstr)
11811         return dstr;
11812
11813     if(param->flags & CLONEf_JOIN_IN) {
11814         /** We are joining here so we don't want do clone
11815             something that is bad **/
11816         if (SvTYPE(sstr) == SVt_PVHV) {
11817             const HEK * const hvname = HvNAME_HEK(sstr);
11818             if (hvname) {
11819                 /** don't clone stashes if they already exist **/
11820                 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
11821                 ptr_table_store(PL_ptr_table, sstr, dstr);
11822                 return dstr;
11823             }
11824         }
11825     }
11826
11827     /* create anew and remember what it is */
11828     new_SV(dstr);
11829
11830 #ifdef DEBUG_LEAKING_SCALARS
11831     dstr->sv_debug_optype = sstr->sv_debug_optype;
11832     dstr->sv_debug_line = sstr->sv_debug_line;
11833     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11834     dstr->sv_debug_parent = (SV*)sstr;
11835     FREE_SV_DEBUG_FILE(dstr);
11836     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11837 #endif
11838
11839     ptr_table_store(PL_ptr_table, sstr, dstr);
11840
11841     /* clone */
11842     SvFLAGS(dstr)       = SvFLAGS(sstr);
11843     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
11844     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
11845
11846 #ifdef DEBUGGING
11847     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11848         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11849                       (void*)PL_watch_pvx, SvPVX_const(sstr));
11850 #endif
11851
11852     /* don't clone objects whose class has asked us not to */
11853     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11854         SvFLAGS(dstr) = 0;
11855         return dstr;
11856     }
11857
11858     switch (SvTYPE(sstr)) {
11859     case SVt_NULL:
11860         SvANY(dstr)     = NULL;
11861         break;
11862     case SVt_IV:
11863         SvANY(dstr)     = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11864         if(SvROK(sstr)) {
11865             Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11866         } else {
11867             SvIV_set(dstr, SvIVX(sstr));
11868         }
11869         break;
11870     case SVt_NV:
11871         SvANY(dstr)     = new_XNV();
11872         SvNV_set(dstr, SvNVX(sstr));
11873         break;
11874         /* case SVt_BIND: */
11875     default:
11876         {
11877             /* These are all the types that need complex bodies allocating.  */
11878             void *new_body;
11879             const svtype sv_type = SvTYPE(sstr);
11880             const struct body_details *const sv_type_details
11881                 = bodies_by_type + sv_type;
11882
11883             switch (sv_type) {
11884             default:
11885                 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11886                 break;
11887
11888             case SVt_PVGV:
11889             case SVt_PVIO:
11890             case SVt_PVFM:
11891             case SVt_PVHV:
11892             case SVt_PVAV:
11893             case SVt_PVCV:
11894             case SVt_PVLV:
11895             case SVt_REGEXP:
11896             case SVt_PVMG:
11897             case SVt_PVNV:
11898             case SVt_PVIV:
11899             case SVt_PV:
11900                 assert(sv_type_details->body_size);
11901                 if (sv_type_details->arena) {
11902                     new_body_inline(new_body, sv_type);
11903                     new_body
11904                         = (void*)((char*)new_body - sv_type_details->offset);
11905                 } else {
11906                     new_body = new_NOARENA(sv_type_details);
11907                 }
11908             }
11909             assert(new_body);
11910             SvANY(dstr) = new_body;
11911
11912 #ifndef PURIFY
11913             Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11914                  ((char*)SvANY(dstr)) + sv_type_details->offset,
11915                  sv_type_details->copy, char);
11916 #else
11917             Copy(((char*)SvANY(sstr)),
11918                  ((char*)SvANY(dstr)),
11919                  sv_type_details->body_size + sv_type_details->offset, char);
11920 #endif
11921
11922             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11923                 && !isGV_with_GP(dstr)
11924                 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11925                 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11926
11927             /* The Copy above means that all the source (unduplicated) pointers
11928                are now in the destination.  We can check the flags and the
11929                pointers in either, but it's possible that there's less cache
11930                missing by always going for the destination.
11931                FIXME - instrument and check that assumption  */
11932             if (sv_type >= SVt_PVMG) {
11933                 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11934                     SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11935                 } else if (SvMAGIC(dstr))
11936                     SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11937                 if (SvSTASH(dstr))
11938                     SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11939             }
11940
11941             /* The cast silences a GCC warning about unhandled types.  */
11942             switch ((int)sv_type) {
11943             case SVt_PV:
11944                 break;
11945             case SVt_PVIV:
11946                 break;
11947             case SVt_PVNV:
11948                 break;
11949             case SVt_PVMG:
11950                 break;
11951             case SVt_REGEXP:
11952                 /* FIXME for plugins */
11953                 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11954                 break;
11955             case SVt_PVLV:
11956                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11957                 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11958                     LvTARG(dstr) = dstr;
11959                 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11960                     LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11961                 else
11962                     LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11963             case SVt_PVGV:
11964                 /* non-GP case already handled above */
11965                 if(isGV_with_GP(sstr)) {
11966                     GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11967                     /* Don't call sv_add_backref here as it's going to be
11968                        created as part of the magic cloning of the symbol
11969                        table--unless this is during a join and the stash
11970                        is not actually being cloned.  */
11971                     /* Danger Will Robinson - GvGP(dstr) isn't initialised
11972                        at the point of this comment.  */
11973                     GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11974                     if (param->flags & CLONEf_JOIN_IN)
11975                         Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
11976                     GvGP_set(dstr, gp_dup(GvGP(sstr), param));
11977                     (void)GpREFCNT_inc(GvGP(dstr));
11978                 }
11979                 break;
11980             case SVt_PVIO:
11981                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11982                 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11983                     /* I have no idea why fake dirp (rsfps)
11984                        should be treated differently but otherwise
11985                        we end up with leaks -- sky*/
11986                     IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
11987                     IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
11988                     IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11989                 } else {
11990                     IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
11991                     IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
11992                     IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
11993                     if (IoDIRP(dstr)) {
11994                         IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr), param);
11995                     } else {
11996                         NOOP;
11997                         /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
11998                     }
11999                     IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
12000                 }
12001                 if (IoOFP(dstr) == IoIFP(sstr))
12002                     IoOFP(dstr) = IoIFP(dstr);
12003                 else
12004                     IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
12005                 IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
12006                 IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
12007                 IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
12008                 break;
12009             case SVt_PVAV:
12010                 /* avoid cloning an empty array */
12011                 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
12012                     SV **dst_ary, **src_ary;
12013                     SSize_t items = AvFILLp((const AV *)sstr) + 1;
12014
12015                     src_ary = AvARRAY((const AV *)sstr);
12016                     Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
12017                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
12018                     AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
12019                     AvALLOC((const AV *)dstr) = dst_ary;
12020                     if (AvREAL((const AV *)sstr)) {
12021                         dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
12022                                                       param);
12023                     }
12024                     else {
12025                         while (items-- > 0)
12026                             *dst_ary++ = sv_dup(*src_ary++, param);
12027                     }
12028                     items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
12029                     while (items-- > 0) {
12030                         *dst_ary++ = &PL_sv_undef;
12031                     }
12032                 }
12033                 else {
12034                     AvARRAY(MUTABLE_AV(dstr))   = NULL;
12035                     AvALLOC((const AV *)dstr)   = (SV**)NULL;
12036                     AvMAX(  (const AV *)dstr)   = -1;
12037                     AvFILLp((const AV *)dstr)   = -1;
12038                 }
12039                 break;
12040             case SVt_PVHV:
12041                 if (HvARRAY((const HV *)sstr)) {
12042                     STRLEN i = 0;
12043                     const bool sharekeys = !!HvSHAREKEYS(sstr);
12044                     XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
12045                     XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
12046                     char *darray;
12047                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
12048                         + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
12049                         char);
12050                     HvARRAY(dstr) = (HE**)darray;
12051                     while (i <= sxhv->xhv_max) {
12052                         const HE * const source = HvARRAY(sstr)[i];
12053                         HvARRAY(dstr)[i] = source
12054                             ? he_dup(source, sharekeys, param) : 0;
12055                         ++i;
12056                     }
12057                     if (SvOOK(sstr)) {
12058                         const struct xpvhv_aux * const saux = HvAUX(sstr);
12059                         struct xpvhv_aux * const daux = HvAUX(dstr);
12060                         /* This flag isn't copied.  */
12061                         /* SvOOK_on(hv) attacks the IV flags.  */
12062                         SvFLAGS(dstr) |= SVf_OOK;
12063
12064                         if (saux->xhv_name_count) {
12065                             HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
12066                             const I32 count
12067                              = saux->xhv_name_count < 0
12068                                 ? -saux->xhv_name_count
12069                                 :  saux->xhv_name_count;
12070                             HEK **shekp = sname + count;
12071                             HEK **dhekp;
12072                             Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
12073                             dhekp = daux->xhv_name_u.xhvnameu_names + count;
12074                             while (shekp-- > sname) {
12075                                 dhekp--;
12076                                 *dhekp = hek_dup(*shekp, param);
12077                             }
12078                         }
12079                         else {
12080                             daux->xhv_name_u.xhvnameu_name
12081                                 = hek_dup(saux->xhv_name_u.xhvnameu_name,
12082                                           param);
12083                         }
12084                         daux->xhv_name_count = saux->xhv_name_count;
12085
12086                         daux->xhv_riter = saux->xhv_riter;
12087                         daux->xhv_eiter = saux->xhv_eiter
12088                             ? he_dup(saux->xhv_eiter,
12089                                         cBOOL(HvSHAREKEYS(sstr)), param) : 0;
12090                         /* backref array needs refcnt=2; see sv_add_backref */
12091                         daux->xhv_backreferences =
12092                             (param->flags & CLONEf_JOIN_IN)
12093                                 /* when joining, we let the individual GVs and
12094                                  * CVs add themselves to backref as
12095                                  * needed. This avoids pulling in stuff
12096                                  * that isn't required, and simplifies the
12097                                  * case where stashes aren't cloned back
12098                                  * if they already exist in the parent
12099                                  * thread */
12100                             ? NULL
12101                             : saux->xhv_backreferences
12102                                 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
12103                                     ? MUTABLE_AV(SvREFCNT_inc(
12104                                           sv_dup_inc((const SV *)
12105                                             saux->xhv_backreferences, param)))
12106                                     : MUTABLE_AV(sv_dup((const SV *)
12107                                             saux->xhv_backreferences, param))
12108                                 : 0;
12109
12110                         daux->xhv_mro_meta = saux->xhv_mro_meta
12111                             ? mro_meta_dup(saux->xhv_mro_meta, param)
12112                             : 0;
12113
12114                         /* Record stashes for possible cloning in Perl_clone(). */
12115                         if (HvNAME(sstr))
12116                             av_push(param->stashes, dstr);
12117                     }
12118                 }
12119                 else
12120                     HvARRAY(MUTABLE_HV(dstr)) = NULL;
12121                 break;
12122             case SVt_PVCV:
12123                 if (!(param->flags & CLONEf_COPY_STACKS)) {
12124                     CvDEPTH(dstr) = 0;
12125                 }
12126                 /*FALLTHROUGH*/
12127             case SVt_PVFM:
12128                 /* NOTE: not refcounted */
12129                 SvANY(MUTABLE_CV(dstr))->xcv_stash =
12130                     hv_dup(CvSTASH(dstr), param);
12131                 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
12132                     Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
12133                 if (!CvISXSUB(dstr)) {
12134                     OP_REFCNT_LOCK;
12135                     CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
12136                     OP_REFCNT_UNLOCK;
12137                     CvFILE(dstr) = SAVEPV(CvFILE(dstr));
12138                 } else if (CvCONST(dstr)) {
12139                     CvXSUBANY(dstr).any_ptr =
12140                         sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
12141                 }
12142                 /* don't dup if copying back - CvGV isn't refcounted, so the
12143                  * duped GV may never be freed. A bit of a hack! DAPM */
12144                 SvANY(MUTABLE_CV(dstr))->xcv_gv =
12145                     CvCVGV_RC(dstr)
12146                     ? gv_dup_inc(CvGV(sstr), param)
12147                     : (param->flags & CLONEf_JOIN_IN)
12148                         ? NULL
12149                         : gv_dup(CvGV(sstr), param);
12150
12151                 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
12152                 CvOUTSIDE(dstr) =
12153                     CvWEAKOUTSIDE(sstr)
12154                     ? cv_dup(    CvOUTSIDE(dstr), param)
12155                     : cv_dup_inc(CvOUTSIDE(dstr), param);
12156                 break;
12157             }
12158         }
12159     }
12160
12161     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
12162         ++PL_sv_objcount;
12163
12164     return dstr;
12165  }
12166
12167 SV *
12168 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12169 {
12170     PERL_ARGS_ASSERT_SV_DUP_INC;
12171     return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
12172 }
12173
12174 SV *
12175 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12176 {
12177     SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
12178     PERL_ARGS_ASSERT_SV_DUP;
12179
12180     /* Track every SV that (at least initially) had a reference count of 0.
12181        We need to do this by holding an actual reference to it in this array.
12182        If we attempt to cheat, turn AvREAL_off(), and store only pointers
12183        (akin to the stashes hash, and the perl stack), we come unstuck if
12184        a weak reference (or other SV legitimately SvREFCNT() == 0 for this
12185        thread) is manipulated in a CLONE method, because CLONE runs before the
12186        unreferenced array is walked to find SVs still with SvREFCNT() == 0
12187        (and fix things up by giving each a reference via the temps stack).
12188        Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
12189        then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
12190        before the walk of unreferenced happens and a reference to that is SV
12191        added to the temps stack. At which point we have the same SV considered
12192        to be in use, and free to be re-used. Not good.
12193     */
12194     if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
12195         assert(param->unreferenced);
12196         av_push(param->unreferenced, SvREFCNT_inc(dstr));
12197     }
12198
12199     return dstr;
12200 }
12201
12202 /* duplicate a context */
12203
12204 PERL_CONTEXT *
12205 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12206 {
12207     PERL_CONTEXT *ncxs;
12208
12209     PERL_ARGS_ASSERT_CX_DUP;
12210
12211     if (!cxs)
12212         return (PERL_CONTEXT*)NULL;
12213
12214     /* look for it in the table first */
12215     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12216     if (ncxs)
12217         return ncxs;
12218
12219     /* create anew and remember what it is */
12220     Newx(ncxs, max + 1, PERL_CONTEXT);
12221     ptr_table_store(PL_ptr_table, cxs, ncxs);
12222     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12223
12224     while (ix >= 0) {
12225         PERL_CONTEXT * const ncx = &ncxs[ix];
12226         if (CxTYPE(ncx) == CXt_SUBST) {
12227             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12228         }
12229         else {
12230             switch (CxTYPE(ncx)) {
12231             case CXt_SUB:
12232                 ncx->blk_sub.cv         = (ncx->blk_sub.olddepth == 0
12233                                            ? cv_dup_inc(ncx->blk_sub.cv, param)
12234                                            : cv_dup(ncx->blk_sub.cv,param));
12235                 ncx->blk_sub.argarray   = (CxHASARGS(ncx)
12236                                            ? av_dup_inc(ncx->blk_sub.argarray,
12237                                                         param)
12238                                            : NULL);
12239                 ncx->blk_sub.savearray  = av_dup_inc(ncx->blk_sub.savearray,
12240                                                      param);
12241                 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12242                                            ncx->blk_sub.oldcomppad);
12243                 break;
12244             case CXt_EVAL:
12245                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12246                                                       param);
12247                 ncx->blk_eval.cur_text  = sv_dup(ncx->blk_eval.cur_text, param);
12248                 break;
12249             case CXt_LOOP_LAZYSV:
12250                 ncx->blk_loop.state_u.lazysv.end
12251                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12252                 /* We are taking advantage of av_dup_inc and sv_dup_inc
12253                    actually being the same function, and order equivalence of
12254                    the two unions.
12255                    We can assert the later [but only at run time :-(]  */
12256                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12257                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
12258             case CXt_LOOP_FOR:
12259                 ncx->blk_loop.state_u.ary.ary
12260                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12261             case CXt_LOOP_LAZYIV:
12262             case CXt_LOOP_PLAIN:
12263                 if (CxPADLOOP(ncx)) {
12264                     ncx->blk_loop.itervar_u.oldcomppad
12265                         = (PAD*)ptr_table_fetch(PL_ptr_table,
12266                                         ncx->blk_loop.itervar_u.oldcomppad);
12267                 } else {
12268                     ncx->blk_loop.itervar_u.gv
12269                         = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12270                                     param);
12271                 }
12272                 break;
12273             case CXt_FORMAT:
12274                 ncx->blk_format.cv      = cv_dup(ncx->blk_format.cv, param);
12275                 ncx->blk_format.gv      = gv_dup(ncx->blk_format.gv, param);
12276                 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12277                                                      param);
12278                 break;
12279             case CXt_BLOCK:
12280             case CXt_NULL:
12281                 break;
12282             }
12283         }
12284         --ix;
12285     }
12286     return ncxs;
12287 }
12288
12289 /* duplicate a stack info structure */
12290
12291 PERL_SI *
12292 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12293 {
12294     PERL_SI *nsi;
12295
12296     PERL_ARGS_ASSERT_SI_DUP;
12297
12298     if (!si)
12299         return (PERL_SI*)NULL;
12300
12301     /* look for it in the table first */
12302     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12303     if (nsi)
12304         return nsi;
12305
12306     /* create anew and remember what it is */
12307     Newxz(nsi, 1, PERL_SI);
12308     ptr_table_store(PL_ptr_table, si, nsi);
12309
12310     nsi->si_stack       = av_dup_inc(si->si_stack, param);
12311     nsi->si_cxix        = si->si_cxix;
12312     nsi->si_cxmax       = si->si_cxmax;
12313     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12314     nsi->si_type        = si->si_type;
12315     nsi->si_prev        = si_dup(si->si_prev, param);
12316     nsi->si_next        = si_dup(si->si_next, param);
12317     nsi->si_markoff     = si->si_markoff;
12318
12319     return nsi;
12320 }
12321
12322 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
12323 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
12324 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
12325 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
12326 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
12327 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
12328 #define POPUV(ss,ix)    ((ss)[--(ix)].any_uv)
12329 #define TOPUV(ss,ix)    ((ss)[ix].any_uv)
12330 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
12331 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
12332 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
12333 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
12334 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
12335 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
12336 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12337 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12338
12339 /* XXXXX todo */
12340 #define pv_dup_inc(p)   SAVEPV(p)
12341 #define pv_dup(p)       SAVEPV(p)
12342 #define svp_dup_inc(p,pp)       any_dup(p,pp)
12343
12344 /* map any object to the new equivent - either something in the
12345  * ptr table, or something in the interpreter structure
12346  */
12347
12348 void *
12349 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12350 {
12351     void *ret;
12352
12353     PERL_ARGS_ASSERT_ANY_DUP;
12354
12355     if (!v)
12356         return (void*)NULL;
12357
12358     /* look for it in the table first */
12359     ret = ptr_table_fetch(PL_ptr_table, v);
12360     if (ret)
12361         return ret;
12362
12363     /* see if it is part of the interpreter structure */
12364     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12365         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12366     else {
12367         ret = v;
12368     }
12369
12370     return ret;
12371 }
12372
12373 /* duplicate the save stack */
12374
12375 ANY *
12376 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12377 {
12378     dVAR;
12379     ANY * const ss      = proto_perl->Isavestack;
12380     const I32 max       = proto_perl->Isavestack_max;
12381     I32 ix              = proto_perl->Isavestack_ix;
12382     ANY *nss;
12383     const SV *sv;
12384     const GV *gv;
12385     const AV *av;
12386     const HV *hv;
12387     void* ptr;
12388     int intval;
12389     long longval;
12390     GP *gp;
12391     IV iv;
12392     I32 i;
12393     char *c = NULL;
12394     void (*dptr) (void*);
12395     void (*dxptr) (pTHX_ void*);
12396
12397     PERL_ARGS_ASSERT_SS_DUP;
12398
12399     Newxz(nss, max, ANY);
12400
12401     while (ix > 0) {
12402         const UV uv = POPUV(ss,ix);
12403         const U8 type = (U8)uv & SAVE_MASK;
12404
12405         TOPUV(nss,ix) = uv;
12406         switch (type) {
12407         case SAVEt_CLEARSV:
12408             break;
12409         case SAVEt_HELEM:               /* hash element */
12410             sv = (const SV *)POPPTR(ss,ix);
12411             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12412             /* fall through */
12413         case SAVEt_ITEM:                        /* normal string */
12414         case SAVEt_GVSV:                        /* scalar slot in GV */
12415         case SAVEt_SV:                          /* scalar reference */
12416             sv = (const SV *)POPPTR(ss,ix);
12417             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12418             /* fall through */
12419         case SAVEt_FREESV:
12420         case SAVEt_MORTALIZESV:
12421             sv = (const SV *)POPPTR(ss,ix);
12422             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12423             break;
12424         case SAVEt_SHARED_PVREF:                /* char* in shared space */
12425             c = (char*)POPPTR(ss,ix);
12426             TOPPTR(nss,ix) = savesharedpv(c);
12427             ptr = POPPTR(ss,ix);
12428             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12429             break;
12430         case SAVEt_GENERIC_SVREF:               /* generic sv */
12431         case SAVEt_SVREF:                       /* scalar reference */
12432             sv = (const SV *)POPPTR(ss,ix);
12433             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12434             ptr = POPPTR(ss,ix);
12435             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12436             break;
12437         case SAVEt_HV:                          /* hash reference */
12438         case SAVEt_AV:                          /* array reference */
12439             sv = (const SV *) POPPTR(ss,ix);
12440             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12441             /* fall through */
12442         case SAVEt_COMPPAD:
12443         case SAVEt_NSTAB:
12444             sv = (const SV *) POPPTR(ss,ix);
12445             TOPPTR(nss,ix) = sv_dup(sv, param);
12446             break;
12447         case SAVEt_INT:                         /* int reference */
12448             ptr = POPPTR(ss,ix);
12449             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12450             intval = (int)POPINT(ss,ix);
12451             TOPINT(nss,ix) = intval;
12452             break;
12453         case SAVEt_LONG:                        /* long reference */
12454             ptr = POPPTR(ss,ix);
12455             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12456             longval = (long)POPLONG(ss,ix);
12457             TOPLONG(nss,ix) = longval;
12458             break;
12459         case SAVEt_I32:                         /* I32 reference */
12460         case SAVEt_COP_ARYBASE:                 /* call CopARYBASE_set */
12461             ptr = POPPTR(ss,ix);
12462             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12463             i = POPINT(ss,ix);
12464             TOPINT(nss,ix) = i;
12465             break;
12466         case SAVEt_IV:                          /* IV reference */
12467             ptr = POPPTR(ss,ix);
12468             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12469             iv = POPIV(ss,ix);
12470             TOPIV(nss,ix) = iv;
12471             break;
12472         case SAVEt_HPTR:                        /* HV* reference */
12473         case SAVEt_APTR:                        /* AV* reference */
12474         case SAVEt_SPTR:                        /* SV* reference */
12475             ptr = POPPTR(ss,ix);
12476             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12477             sv = (const SV *)POPPTR(ss,ix);
12478             TOPPTR(nss,ix) = sv_dup(sv, param);
12479             break;
12480         case SAVEt_VPTR:                        /* random* reference */
12481             ptr = POPPTR(ss,ix);
12482             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12483             /* Fall through */
12484         case SAVEt_INT_SMALL:
12485         case SAVEt_I32_SMALL:
12486         case SAVEt_I16:                         /* I16 reference */
12487         case SAVEt_I8:                          /* I8 reference */
12488         case SAVEt_BOOL:
12489             ptr = POPPTR(ss,ix);
12490             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12491             break;
12492         case SAVEt_GENERIC_PVREF:               /* generic char* */
12493         case SAVEt_PPTR:                        /* char* reference */
12494             ptr = POPPTR(ss,ix);
12495             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12496             c = (char*)POPPTR(ss,ix);
12497             TOPPTR(nss,ix) = pv_dup(c);
12498             break;
12499         case SAVEt_GP:                          /* scalar reference */
12500             gp = (GP*)POPPTR(ss,ix);
12501             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12502             (void)GpREFCNT_inc(gp);
12503             gv = (const GV *)POPPTR(ss,ix);
12504             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12505             break;
12506         case SAVEt_FREEOP:
12507             ptr = POPPTR(ss,ix);
12508             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12509                 /* these are assumed to be refcounted properly */
12510                 OP *o;
12511                 switch (((OP*)ptr)->op_type) {
12512                 case OP_LEAVESUB:
12513                 case OP_LEAVESUBLV:
12514                 case OP_LEAVEEVAL:
12515                 case OP_LEAVE:
12516                 case OP_SCOPE:
12517                 case OP_LEAVEWRITE:
12518                     TOPPTR(nss,ix) = ptr;
12519                     o = (OP*)ptr;
12520                     OP_REFCNT_LOCK;
12521                     (void) OpREFCNT_inc(o);
12522                     OP_REFCNT_UNLOCK;
12523                     break;
12524                 default:
12525                     TOPPTR(nss,ix) = NULL;
12526                     break;
12527                 }
12528             }
12529             else
12530                 TOPPTR(nss,ix) = NULL;
12531             break;
12532         case SAVEt_FREECOPHH:
12533             ptr = POPPTR(ss,ix);
12534             TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
12535             break;
12536         case SAVEt_DELETE:
12537             hv = (const HV *)POPPTR(ss,ix);
12538             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12539             i = POPINT(ss,ix);
12540             TOPINT(nss,ix) = i;
12541             /* Fall through */
12542         case SAVEt_FREEPV:
12543             c = (char*)POPPTR(ss,ix);
12544             TOPPTR(nss,ix) = pv_dup_inc(c);
12545             break;
12546         case SAVEt_STACK_POS:           /* Position on Perl stack */
12547             i = POPINT(ss,ix);
12548             TOPINT(nss,ix) = i;
12549             break;
12550         case SAVEt_DESTRUCTOR:
12551             ptr = POPPTR(ss,ix);
12552             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
12553             dptr = POPDPTR(ss,ix);
12554             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
12555                                         any_dup(FPTR2DPTR(void *, dptr),
12556                                                 proto_perl));
12557             break;
12558         case SAVEt_DESTRUCTOR_X:
12559             ptr = POPPTR(ss,ix);
12560             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
12561             dxptr = POPDXPTR(ss,ix);
12562             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
12563                                          any_dup(FPTR2DPTR(void *, dxptr),
12564                                                  proto_perl));
12565             break;
12566         case SAVEt_REGCONTEXT:
12567         case SAVEt_ALLOC:
12568             ix -= uv >> SAVE_TIGHT_SHIFT;
12569             break;
12570         case SAVEt_AELEM:               /* array element */
12571             sv = (const SV *)POPPTR(ss,ix);
12572             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12573             i = POPINT(ss,ix);
12574             TOPINT(nss,ix) = i;
12575             av = (const AV *)POPPTR(ss,ix);
12576             TOPPTR(nss,ix) = av_dup_inc(av, param);
12577             break;
12578         case SAVEt_OP:
12579             ptr = POPPTR(ss,ix);
12580             TOPPTR(nss,ix) = ptr;
12581             break;
12582         case SAVEt_HINTS:
12583             ptr = POPPTR(ss,ix);
12584             ptr = cophh_copy((COPHH*)ptr);
12585             TOPPTR(nss,ix) = ptr;
12586             i = POPINT(ss,ix);
12587             TOPINT(nss,ix) = i;
12588             if (i & HINT_LOCALIZE_HH) {
12589                 hv = (const HV *)POPPTR(ss,ix);
12590                 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12591             }
12592             break;
12593         case SAVEt_PADSV_AND_MORTALIZE:
12594             longval = (long)POPLONG(ss,ix);
12595             TOPLONG(nss,ix) = longval;
12596             ptr = POPPTR(ss,ix);
12597             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12598             sv = (const SV *)POPPTR(ss,ix);
12599             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12600             break;
12601         case SAVEt_SET_SVFLAGS:
12602             i = POPINT(ss,ix);
12603             TOPINT(nss,ix) = i;
12604             i = POPINT(ss,ix);
12605             TOPINT(nss,ix) = i;
12606             sv = (const SV *)POPPTR(ss,ix);
12607             TOPPTR(nss,ix) = sv_dup(sv, param);
12608             break;
12609         case SAVEt_RE_STATE:
12610             {
12611                 const struct re_save_state *const old_state
12612                     = (struct re_save_state *)
12613                     (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12614                 struct re_save_state *const new_state
12615                     = (struct re_save_state *)
12616                     (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12617
12618                 Copy(old_state, new_state, 1, struct re_save_state);
12619                 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12620
12621                 new_state->re_state_bostr
12622                     = pv_dup(old_state->re_state_bostr);
12623                 new_state->re_state_reginput
12624                     = pv_dup(old_state->re_state_reginput);
12625                 new_state->re_state_regeol
12626                     = pv_dup(old_state->re_state_regeol);
12627                 new_state->re_state_regoffs
12628                     = (regexp_paren_pair*)
12629                         any_dup(old_state->re_state_regoffs, proto_perl);
12630                 new_state->re_state_reglastparen
12631                     = (U32*) any_dup(old_state->re_state_reglastparen,
12632                               proto_perl);
12633                 new_state->re_state_reglastcloseparen
12634                     = (U32*)any_dup(old_state->re_state_reglastcloseparen,
12635                               proto_perl);
12636                 /* XXX This just has to be broken. The old save_re_context
12637                    code did SAVEGENERICPV(PL_reg_start_tmp);
12638                    PL_reg_start_tmp is char **.
12639                    Look above to what the dup code does for
12640                    SAVEt_GENERIC_PVREF
12641                    It can never have worked.
12642                    So this is merely a faithful copy of the exiting bug:  */
12643                 new_state->re_state_reg_start_tmp
12644                     = (char **) pv_dup((char *)
12645                                       old_state->re_state_reg_start_tmp);
12646                 /* I assume that it only ever "worked" because no-one called
12647                    (pseudo)fork while the regexp engine had re-entered itself.
12648                 */
12649 #ifdef PERL_OLD_COPY_ON_WRITE
12650                 new_state->re_state_nrs
12651                     = sv_dup(old_state->re_state_nrs, param);
12652 #endif
12653                 new_state->re_state_reg_magic
12654                     = (MAGIC*) any_dup(old_state->re_state_reg_magic,
12655                                proto_perl);
12656                 new_state->re_state_reg_oldcurpm
12657                     = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
12658                               proto_perl);
12659                 new_state->re_state_reg_curpm
12660                     = (PMOP*)  any_dup(old_state->re_state_reg_curpm,
12661                                proto_perl);
12662                 new_state->re_state_reg_oldsaved
12663                     = pv_dup(old_state->re_state_reg_oldsaved);
12664                 new_state->re_state_reg_poscache
12665                     = pv_dup(old_state->re_state_reg_poscache);
12666                 new_state->re_state_reg_starttry
12667                     = pv_dup(old_state->re_state_reg_starttry);
12668                 break;
12669             }
12670         case SAVEt_COMPILE_WARNINGS:
12671             ptr = POPPTR(ss,ix);
12672             TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12673             break;
12674         case SAVEt_PARSER:
12675             ptr = POPPTR(ss,ix);
12676             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12677             break;
12678         default:
12679             Perl_croak(aTHX_
12680                        "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12681         }
12682     }
12683
12684     return nss;
12685 }
12686
12687
12688 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12689  * flag to the result. This is done for each stash before cloning starts,
12690  * so we know which stashes want their objects cloned */
12691
12692 static void
12693 do_mark_cloneable_stash(pTHX_ SV *const sv)
12694 {
12695     const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12696     if (hvname) {
12697         GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12698         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12699         if (cloner && GvCV(cloner)) {
12700             dSP;
12701             UV status;
12702
12703             ENTER;
12704             SAVETMPS;
12705             PUSHMARK(SP);
12706             mXPUSHs(newSVhek(hvname));
12707             PUTBACK;
12708             call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12709             SPAGAIN;
12710             status = POPu;
12711             PUTBACK;
12712             FREETMPS;
12713             LEAVE;
12714             if (status)
12715                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12716         }
12717     }
12718 }
12719
12720
12721
12722 /*
12723 =for apidoc perl_clone
12724
12725 Create and return a new interpreter by cloning the current one.
12726
12727 perl_clone takes these flags as parameters:
12728
12729 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12730 without it we only clone the data and zero the stacks,
12731 with it we copy the stacks and the new perl interpreter is
12732 ready to run at the exact same point as the previous one.
12733 The pseudo-fork code uses COPY_STACKS while the
12734 threads->create doesn't.
12735
12736 CLONEf_KEEP_PTR_TABLE
12737 perl_clone keeps a ptr_table with the pointer of the old
12738 variable as a key and the new variable as a value,
12739 this allows it to check if something has been cloned and not
12740 clone it again but rather just use the value and increase the
12741 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
12742 the ptr_table using the function
12743 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12744 reason to keep it around is if you want to dup some of your own
12745 variable who are outside the graph perl scans, example of this
12746 code is in threads.xs create
12747
12748 CLONEf_CLONE_HOST
12749 This is a win32 thing, it is ignored on unix, it tells perls
12750 win32host code (which is c++) to clone itself, this is needed on
12751 win32 if you want to run two threads at the same time,
12752 if you just want to do some stuff in a separate perl interpreter
12753 and then throw it away and return to the original one,
12754 you don't need to do anything.
12755
12756 =cut
12757 */
12758
12759 /* XXX the above needs expanding by someone who actually understands it ! */
12760 EXTERN_C PerlInterpreter *
12761 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12762
12763 PerlInterpreter *
12764 perl_clone(PerlInterpreter *proto_perl, UV flags)
12765 {
12766    dVAR;
12767 #ifdef PERL_IMPLICIT_SYS
12768
12769     PERL_ARGS_ASSERT_PERL_CLONE;
12770
12771    /* perlhost.h so we need to call into it
12772    to clone the host, CPerlHost should have a c interface, sky */
12773
12774    if (flags & CLONEf_CLONE_HOST) {
12775        return perl_clone_host(proto_perl,flags);
12776    }
12777    return perl_clone_using(proto_perl, flags,
12778                             proto_perl->IMem,
12779                             proto_perl->IMemShared,
12780                             proto_perl->IMemParse,
12781                             proto_perl->IEnv,
12782                             proto_perl->IStdIO,
12783                             proto_perl->ILIO,
12784                             proto_perl->IDir,
12785                             proto_perl->ISock,
12786                             proto_perl->IProc);
12787 }
12788
12789 PerlInterpreter *
12790 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12791                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
12792                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12793                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12794                  struct IPerlDir* ipD, struct IPerlSock* ipS,
12795                  struct IPerlProc* ipP)
12796 {
12797     /* XXX many of the string copies here can be optimized if they're
12798      * constants; they need to be allocated as common memory and just
12799      * their pointers copied. */
12800
12801     IV i;
12802     CLONE_PARAMS clone_params;
12803     CLONE_PARAMS* const param = &clone_params;
12804
12805     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12806
12807     PERL_ARGS_ASSERT_PERL_CLONE_USING;
12808 #else           /* !PERL_IMPLICIT_SYS */
12809     IV i;
12810     CLONE_PARAMS clone_params;
12811     CLONE_PARAMS* param = &clone_params;
12812     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12813
12814     PERL_ARGS_ASSERT_PERL_CLONE;
12815 #endif          /* PERL_IMPLICIT_SYS */
12816
12817     /* for each stash, determine whether its objects should be cloned */
12818     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12819     PERL_SET_THX(my_perl);
12820
12821 #ifdef DEBUGGING
12822     PoisonNew(my_perl, 1, PerlInterpreter);
12823     PL_op = NULL;
12824     PL_curcop = NULL;
12825     PL_defstash = NULL; /* may be used by perl malloc() */
12826     PL_markstack = 0;
12827     PL_scopestack = 0;
12828     PL_scopestack_name = 0;
12829     PL_savestack = 0;
12830     PL_savestack_ix = 0;
12831     PL_savestack_max = -1;
12832     PL_sig_pending = 0;
12833     PL_parser = NULL;
12834     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12835 #  ifdef DEBUG_LEAKING_SCALARS
12836     PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12837 #  endif
12838 #else   /* !DEBUGGING */
12839     Zero(my_perl, 1, PerlInterpreter);
12840 #endif  /* DEBUGGING */
12841
12842 #ifdef PERL_IMPLICIT_SYS
12843     /* host pointers */
12844     PL_Mem              = ipM;
12845     PL_MemShared        = ipMS;
12846     PL_MemParse         = ipMP;
12847     PL_Env              = ipE;
12848     PL_StdIO            = ipStd;
12849     PL_LIO              = ipLIO;
12850     PL_Dir              = ipD;
12851     PL_Sock             = ipS;
12852     PL_Proc             = ipP;
12853 #endif          /* PERL_IMPLICIT_SYS */
12854
12855     param->flags = flags;
12856     /* Nothing in the core code uses this, but we make it available to
12857        extensions (using mg_dup).  */
12858     param->proto_perl = proto_perl;
12859     /* Likely nothing will use this, but it is initialised to be consistent
12860        with Perl_clone_params_new().  */
12861     param->new_perl = my_perl;
12862     param->unreferenced = NULL;
12863
12864     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12865
12866     PL_body_arenas = NULL;
12867     Zero(&PL_body_roots, 1, PL_body_roots);
12868
12869     PL_sv_count         = 0;
12870     PL_sv_objcount      = 0;
12871     PL_sv_root          = NULL;
12872     PL_sv_arenaroot     = NULL;
12873
12874     PL_debug            = proto_perl->Idebug;
12875
12876     PL_hash_seed        = proto_perl->Ihash_seed;
12877     PL_rehash_seed      = proto_perl->Irehash_seed;
12878
12879     SvANY(&PL_sv_undef)         = NULL;
12880     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
12881     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
12882     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
12883     SvFLAGS(&PL_sv_no)          = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12884                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12885
12886     SvANY(&PL_sv_yes)           = new_XPVNV();
12887     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
12888     SvFLAGS(&PL_sv_yes)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12889                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12890
12891     /* dbargs array probably holds garbage */
12892     PL_dbargs           = NULL;
12893
12894     PL_compiling = proto_perl->Icompiling;
12895
12896 #ifdef PERL_DEBUG_READONLY_OPS
12897     PL_slabs = NULL;
12898     PL_slab_count = 0;
12899 #endif
12900
12901     /* pseudo environmental stuff */
12902     PL_origargc         = proto_perl->Iorigargc;
12903     PL_origargv         = proto_perl->Iorigargv;
12904
12905     /* Set tainting stuff before PerlIO_debug can possibly get called */
12906     PL_tainting         = proto_perl->Itainting;
12907     PL_taint_warn       = proto_perl->Itaint_warn;
12908
12909     PL_minus_c          = proto_perl->Iminus_c;
12910
12911     PL_localpatches     = proto_perl->Ilocalpatches;
12912     PL_splitstr         = proto_perl->Isplitstr;
12913     PL_minus_n          = proto_perl->Iminus_n;
12914     PL_minus_p          = proto_perl->Iminus_p;
12915     PL_minus_l          = proto_perl->Iminus_l;
12916     PL_minus_a          = proto_perl->Iminus_a;
12917     PL_minus_E          = proto_perl->Iminus_E;
12918     PL_minus_F          = proto_perl->Iminus_F;
12919     PL_doswitches       = proto_perl->Idoswitches;
12920     PL_dowarn           = proto_perl->Idowarn;
12921     PL_sawampersand     = proto_perl->Isawampersand;
12922     PL_unsafe           = proto_perl->Iunsafe;
12923     PL_perldb           = proto_perl->Iperldb;
12924     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12925     PL_exit_flags       = proto_perl->Iexit_flags;
12926
12927     /* XXX time(&PL_basetime) when asked for? */
12928     PL_basetime         = proto_perl->Ibasetime;
12929
12930     PL_maxsysfd         = proto_perl->Imaxsysfd;
12931     PL_statusvalue      = proto_perl->Istatusvalue;
12932 #ifdef VMS
12933     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
12934 #else
12935     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12936 #endif
12937
12938     /* RE engine related */
12939     Zero(&PL_reg_state, 1, struct re_save_state);
12940     PL_reginterp_cnt    = 0;
12941     PL_regmatch_slab    = NULL;
12942
12943     PL_sub_generation   = proto_perl->Isub_generation;
12944
12945     /* funky return mechanisms */
12946     PL_forkprocess      = proto_perl->Iforkprocess;
12947
12948     /* internal state */
12949     PL_maxo             = proto_perl->Imaxo;
12950
12951     PL_main_start       = proto_perl->Imain_start;
12952     PL_eval_root        = proto_perl->Ieval_root;
12953     PL_eval_start       = proto_perl->Ieval_start;
12954
12955     PL_filemode         = proto_perl->Ifilemode;
12956     PL_lastfd           = proto_perl->Ilastfd;
12957     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
12958     PL_Argv             = NULL;
12959     PL_Cmd              = NULL;
12960     PL_gensym           = proto_perl->Igensym;
12961
12962     PL_laststatval      = proto_perl->Ilaststatval;
12963     PL_laststype        = proto_perl->Ilaststype;
12964     PL_mess_sv          = NULL;
12965
12966     PL_profiledata      = NULL;
12967
12968     PL_generation       = proto_perl->Igeneration;
12969
12970     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
12971     PL_in_clean_all     = proto_perl->Iin_clean_all;
12972
12973     PL_uid              = proto_perl->Iuid;
12974     PL_euid             = proto_perl->Ieuid;
12975     PL_gid              = proto_perl->Igid;
12976     PL_egid             = proto_perl->Iegid;
12977     PL_nomemok          = proto_perl->Inomemok;
12978     PL_an               = proto_perl->Ian;
12979     PL_evalseq          = proto_perl->Ievalseq;
12980     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
12981     PL_origalen         = proto_perl->Iorigalen;
12982
12983     PL_sighandlerp      = proto_perl->Isighandlerp;
12984
12985     PL_runops           = proto_perl->Irunops;
12986
12987     PL_subline          = proto_perl->Isubline;
12988
12989 #ifdef FCRYPT
12990     PL_cryptseen        = proto_perl->Icryptseen;
12991 #endif
12992
12993     PL_hints            = proto_perl->Ihints;
12994
12995     PL_amagic_generation        = proto_perl->Iamagic_generation;
12996
12997 #ifdef USE_LOCALE_COLLATE
12998     PL_collation_ix     = proto_perl->Icollation_ix;
12999     PL_collation_standard       = proto_perl->Icollation_standard;
13000     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
13001     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
13002 #endif /* USE_LOCALE_COLLATE */
13003
13004 #ifdef USE_LOCALE_NUMERIC
13005     PL_numeric_standard = proto_perl->Inumeric_standard;
13006     PL_numeric_local    = proto_perl->Inumeric_local;
13007 #endif /* !USE_LOCALE_NUMERIC */
13008
13009     /* Did the locale setup indicate UTF-8? */
13010     PL_utf8locale       = proto_perl->Iutf8locale;
13011     /* Unicode features (see perlrun/-C) */
13012     PL_unicode          = proto_perl->Iunicode;
13013
13014     /* Pre-5.8 signals control */
13015     PL_signals          = proto_perl->Isignals;
13016
13017     /* times() ticks per second */
13018     PL_clocktick        = proto_perl->Iclocktick;
13019
13020     /* Recursion stopper for PerlIO_find_layer */
13021     PL_in_load_module   = proto_perl->Iin_load_module;
13022
13023     /* sort() routine */
13024     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
13025
13026     /* Not really needed/useful since the reenrant_retint is "volatile",
13027      * but do it for consistency's sake. */
13028     PL_reentrant_retint = proto_perl->Ireentrant_retint;
13029
13030     /* Hooks to shared SVs and locks. */
13031     PL_sharehook        = proto_perl->Isharehook;
13032     PL_lockhook         = proto_perl->Ilockhook;
13033     PL_unlockhook       = proto_perl->Iunlockhook;
13034     PL_threadhook       = proto_perl->Ithreadhook;
13035     PL_destroyhook      = proto_perl->Idestroyhook;
13036     PL_signalhook       = proto_perl->Isignalhook;
13037
13038 #ifdef THREADS_HAVE_PIDS
13039     PL_ppid             = proto_perl->Ippid;
13040 #endif
13041
13042     /* swatch cache */
13043     PL_last_swash_hv    = NULL; /* reinits on demand */
13044     PL_last_swash_klen  = 0;
13045     PL_last_swash_key[0]= '\0';
13046     PL_last_swash_tmps  = (U8*)NULL;
13047     PL_last_swash_slen  = 0;
13048
13049     PL_glob_index       = proto_perl->Iglob_index;
13050     PL_srand_called     = proto_perl->Isrand_called;
13051
13052     if (flags & CLONEf_COPY_STACKS) {
13053         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13054         PL_tmps_ix              = proto_perl->Itmps_ix;
13055         PL_tmps_max             = proto_perl->Itmps_max;
13056         PL_tmps_floor           = proto_perl->Itmps_floor;
13057
13058         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13059          * NOTE: unlike the others! */
13060         PL_scopestack_ix        = proto_perl->Iscopestack_ix;
13061         PL_scopestack_max       = proto_perl->Iscopestack_max;
13062
13063         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13064          * NOTE: unlike the others! */
13065         PL_savestack_ix         = proto_perl->Isavestack_ix;
13066         PL_savestack_max        = proto_perl->Isavestack_max;
13067     }
13068
13069     PL_start_env        = proto_perl->Istart_env;       /* XXXXXX */
13070     PL_top_env          = &PL_start_env;
13071
13072     PL_op               = proto_perl->Iop;
13073
13074     PL_Sv               = NULL;
13075     PL_Xpv              = (XPV*)NULL;
13076     my_perl->Ina        = proto_perl->Ina;
13077
13078     PL_statbuf          = proto_perl->Istatbuf;
13079     PL_statcache        = proto_perl->Istatcache;
13080
13081 #ifdef HAS_TIMES
13082     PL_timesbuf         = proto_perl->Itimesbuf;
13083 #endif
13084
13085     PL_tainted          = proto_perl->Itainted;
13086     PL_curpm            = proto_perl->Icurpm;   /* XXX No PMOP ref count */
13087
13088     PL_chopset          = proto_perl->Ichopset; /* XXX never deallocated */
13089
13090     PL_restartjmpenv    = proto_perl->Irestartjmpenv;
13091     PL_restartop        = proto_perl->Irestartop;
13092     PL_in_eval          = proto_perl->Iin_eval;
13093     PL_delaymagic       = proto_perl->Idelaymagic;
13094     PL_phase            = proto_perl->Iphase;
13095     PL_localizing       = proto_perl->Ilocalizing;
13096
13097     PL_hv_fetch_ent_mh  = NULL;
13098     PL_modcount         = proto_perl->Imodcount;
13099     PL_lastgotoprobe    = NULL;
13100     PL_dumpindent       = proto_perl->Idumpindent;
13101
13102     PL_efloatbuf        = NULL;         /* reinits on demand */
13103     PL_efloatsize       = 0;                    /* reinits on demand */
13104
13105     /* regex stuff */
13106
13107     PL_screamfirst      = NULL;
13108     PL_screamnext       = NULL;
13109     PL_maxscream        = -1;                   /* reinits on demand */
13110     PL_lastscream       = NULL;
13111
13112
13113     PL_regdummy         = proto_perl->Iregdummy;
13114     PL_colorset         = 0;            /* reinits PL_colors[] */
13115     /*PL_colors[6]      = {0,0,0,0,0,0};*/
13116
13117     /* Pluggable optimizer */
13118     PL_peepp            = proto_perl->Ipeepp;
13119     PL_rpeepp           = proto_perl->Irpeepp;
13120     /* op_free() hook */
13121     PL_opfreehook       = proto_perl->Iopfreehook;
13122
13123 #ifdef USE_REENTRANT_API
13124     /* XXX: things like -Dm will segfault here in perlio, but doing
13125      *  PERL_SET_CONTEXT(proto_perl);
13126      * breaks too many other things
13127      */
13128     Perl_reentrant_init(aTHX);
13129 #endif
13130
13131     /* create SV map for pointer relocation */
13132     PL_ptr_table = ptr_table_new();
13133
13134     /* initialize these special pointers as early as possible */
13135     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
13136
13137     SvANY(&PL_sv_no)            = new_XPVNV();
13138     SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
13139     SvCUR_set(&PL_sv_no, 0);
13140     SvLEN_set(&PL_sv_no, 1);
13141     SvIV_set(&PL_sv_no, 0);
13142     SvNV_set(&PL_sv_no, 0);
13143     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
13144
13145     SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
13146     SvCUR_set(&PL_sv_yes, 1);
13147     SvLEN_set(&PL_sv_yes, 2);
13148     SvIV_set(&PL_sv_yes, 1);
13149     SvNV_set(&PL_sv_yes, 1);
13150     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
13151
13152     /* create (a non-shared!) shared string table */
13153     PL_strtab           = newHV();
13154     HvSHAREKEYS_off(PL_strtab);
13155     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
13156     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
13157
13158     /* These two PVs will be free'd special way so must set them same way op.c does */
13159     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
13160     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
13161
13162     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
13163     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
13164
13165     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
13166     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
13167     CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
13168     PL_curcop           = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
13169
13170     param->stashes      = newAV();  /* Setup array of objects to call clone on */
13171     /* This makes no difference to the implementation, as it always pushes
13172        and shifts pointers to other SVs without changing their reference
13173        count, with the array becoming empty before it is freed. However, it
13174        makes it conceptually clear what is going on, and will avoid some
13175        work inside av.c, filling slots between AvFILL() and AvMAX() with
13176        &PL_sv_undef, and SvREFCNT_dec()ing those.  */
13177     AvREAL_off(param->stashes);
13178
13179     if (!(flags & CLONEf_COPY_STACKS)) {
13180         param->unreferenced = newAV();
13181     }
13182
13183 #ifdef PERLIO_LAYERS
13184     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
13185     PerlIO_clone(aTHX_ proto_perl, param);
13186 #endif
13187
13188     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
13189     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
13190     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
13191     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
13192     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
13193     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
13194
13195     /* switches */
13196     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
13197     PL_apiversion       = sv_dup_inc(proto_perl->Iapiversion, param);
13198     PL_inplace          = SAVEPV(proto_perl->Iinplace);
13199     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
13200
13201     /* magical thingies */
13202     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
13203
13204     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
13205
13206     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
13207     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
13208     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
13209
13210
13211     /* Clone the regex array */
13212     /* ORANGE FIXME for plugins, probably in the SV dup code.
13213        newSViv(PTR2IV(CALLREGDUPE(
13214        INT2PTR(REGEXP *, SvIVX(regex)), param))))
13215     */
13216     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
13217     PL_regex_pad = AvARRAY(PL_regex_padav);
13218
13219     /* shortcuts to various I/O objects */
13220     PL_ofsgv            = gv_dup_inc(proto_perl->Iofsgv, param);
13221     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
13222     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
13223     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
13224     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
13225     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
13226     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
13227
13228     /* shortcuts to regexp stuff */
13229     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
13230
13231     /* shortcuts to misc objects */
13232     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
13233
13234     /* shortcuts to debugging objects */
13235     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
13236     PL_DBline           = gv_dup(proto_perl->IDBline, param);
13237     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
13238     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
13239     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
13240     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
13241
13242     /* symbol tables */
13243     PL_defstash         = hv_dup_inc(proto_perl->Idefstash, param);
13244     PL_curstash         = hv_dup(proto_perl->Icurstash, param);
13245     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
13246     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
13247     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
13248
13249     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
13250     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
13251     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
13252     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
13253     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
13254     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
13255     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
13256     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
13257
13258     PL_isarev           = hv_dup_inc(proto_perl->Iisarev, param);
13259
13260     /* subprocess state */
13261     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
13262
13263     if (proto_perl->Iop_mask)
13264         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
13265     else
13266         PL_op_mask      = NULL;
13267     /* PL_asserting        = proto_perl->Iasserting; */
13268
13269     /* current interpreter roots */
13270     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
13271     OP_REFCNT_LOCK;
13272     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
13273     OP_REFCNT_UNLOCK;
13274
13275     /* runtime control stuff */
13276     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
13277
13278     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
13279
13280     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
13281
13282     /* interpreter atexit processing */
13283     PL_exitlistlen      = proto_perl->Iexitlistlen;
13284     if (PL_exitlistlen) {
13285         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13286         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13287     }
13288     else
13289         PL_exitlist     = (PerlExitListEntry*)NULL;
13290
13291     PL_my_cxt_size = proto_perl->Imy_cxt_size;
13292     if (PL_my_cxt_size) {
13293         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
13294         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
13295 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13296         Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
13297         Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
13298 #endif
13299     }
13300     else {
13301         PL_my_cxt_list  = (void**)NULL;
13302 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13303         PL_my_cxt_keys  = (const char**)NULL;
13304 #endif
13305     }
13306     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
13307     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
13308     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
13309     PL_custom_ops       = hv_dup_inc(proto_perl->Icustom_ops, param);
13310
13311     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
13312
13313     PAD_CLONE_VARS(proto_perl, param);
13314
13315 #ifdef HAVE_INTERP_INTERN
13316     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
13317 #endif
13318
13319     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
13320
13321 #ifdef PERL_USES_PL_PIDSTATUS
13322     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
13323 #endif
13324     PL_osname           = SAVEPV(proto_perl->Iosname);
13325     PL_parser           = parser_dup(proto_perl->Iparser, param);
13326
13327     /* XXX this only works if the saved cop has already been cloned */
13328     if (proto_perl->Iparser) {
13329         PL_parser->saved_curcop = (COP*)any_dup(
13330                                     proto_perl->Iparser->saved_curcop,
13331                                     proto_perl);
13332     }
13333
13334     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
13335
13336 #ifdef USE_LOCALE_COLLATE
13337     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
13338 #endif /* USE_LOCALE_COLLATE */
13339
13340 #ifdef USE_LOCALE_NUMERIC
13341     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
13342     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13343 #endif /* !USE_LOCALE_NUMERIC */
13344
13345     /* utf8 character classes */
13346     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
13347     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
13348     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
13349     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
13350     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
13351     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
13352     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
13353     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
13354     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
13355     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
13356     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
13357     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
13358     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
13359     PL_utf8_X_begin     = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
13360     PL_utf8_X_extend    = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13361     PL_utf8_X_prepend   = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
13362     PL_utf8_X_non_hangul        = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
13363     PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
13364     PL_utf8_X_LV        = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
13365     PL_utf8_X_LVT       = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
13366     PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
13367     PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
13368     PL_utf8_X_LV_LVT_V  = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
13369     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13370     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13371     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13372     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13373     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13374     PL_utf8_xidstart    = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
13375     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13376     PL_utf8_xidcont     = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
13377     PL_utf8_foldable    = hv_dup_inc(proto_perl->Iutf8_foldable, param);
13378
13379
13380     if (proto_perl->Ipsig_pend) {
13381         Newxz(PL_psig_pend, SIG_SIZE, int);
13382     }
13383     else {
13384         PL_psig_pend    = (int*)NULL;
13385     }
13386
13387     if (proto_perl->Ipsig_name) {
13388         Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13389         sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13390                             param);
13391         PL_psig_ptr = PL_psig_name + SIG_SIZE;
13392     }
13393     else {
13394         PL_psig_ptr     = (SV**)NULL;
13395         PL_psig_name    = (SV**)NULL;
13396     }
13397
13398     if (flags & CLONEf_COPY_STACKS) {
13399         Newx(PL_tmps_stack, PL_tmps_max, SV*);
13400         sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13401                             PL_tmps_ix+1, param);
13402
13403         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13404         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13405         Newxz(PL_markstack, i, I32);
13406         PL_markstack_max        = PL_markstack + (proto_perl->Imarkstack_max
13407                                                   - proto_perl->Imarkstack);
13408         PL_markstack_ptr        = PL_markstack + (proto_perl->Imarkstack_ptr
13409                                                   - proto_perl->Imarkstack);
13410         Copy(proto_perl->Imarkstack, PL_markstack,
13411              PL_markstack_ptr - PL_markstack + 1, I32);
13412
13413         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13414          * NOTE: unlike the others! */
13415         Newxz(PL_scopestack, PL_scopestack_max, I32);
13416         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13417
13418 #ifdef DEBUGGING
13419         Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13420         Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13421 #endif
13422         /* NOTE: si_dup() looks at PL_markstack */
13423         PL_curstackinfo         = si_dup(proto_perl->Icurstackinfo, param);
13424
13425         /* PL_curstack          = PL_curstackinfo->si_stack; */
13426         PL_curstack             = av_dup(proto_perl->Icurstack, param);
13427         PL_mainstack            = av_dup(proto_perl->Imainstack, param);
13428
13429         /* next PUSHs() etc. set *(PL_stack_sp+1) */
13430         PL_stack_base           = AvARRAY(PL_curstack);
13431         PL_stack_sp             = PL_stack_base + (proto_perl->Istack_sp
13432                                                    - proto_perl->Istack_base);
13433         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
13434
13435         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13436         PL_savestack            = ss_dup(proto_perl, param);
13437     }
13438     else {
13439         init_stacks();
13440         ENTER;                  /* perl_destruct() wants to LEAVE; */
13441     }
13442
13443     PL_statgv           = gv_dup(proto_perl->Istatgv, param);
13444     PL_statname         = sv_dup_inc(proto_perl->Istatname, param);
13445
13446     PL_rs               = sv_dup_inc(proto_perl->Irs, param);
13447     PL_last_in_gv       = gv_dup(proto_perl->Ilast_in_gv, param);
13448     PL_defoutgv         = gv_dup_inc(proto_perl->Idefoutgv, param);
13449     PL_toptarget        = sv_dup_inc(proto_perl->Itoptarget, param);
13450     PL_bodytarget       = sv_dup_inc(proto_perl->Ibodytarget, param);
13451     PL_formtarget       = sv_dup(proto_perl->Iformtarget, param);
13452
13453     PL_errors           = sv_dup_inc(proto_perl->Ierrors, param);
13454
13455     PL_sortcop          = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13456     PL_sortstash        = hv_dup(proto_perl->Isortstash, param);
13457     PL_firstgv          = gv_dup(proto_perl->Ifirstgv, param);
13458     PL_secondgv         = gv_dup(proto_perl->Isecondgv, param);
13459
13460     PL_stashcache       = newHV();
13461
13462     PL_watchaddr        = (char **) ptr_table_fetch(PL_ptr_table,
13463                                             proto_perl->Iwatchaddr);
13464     PL_watchok          = PL_watchaddr ? * PL_watchaddr : NULL;
13465     if (PL_debug && PL_watchaddr) {
13466         PerlIO_printf(Perl_debug_log,
13467           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13468           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13469           PTR2UV(PL_watchok));
13470     }
13471
13472     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
13473     PL_blockhooks       = av_dup_inc(proto_perl->Iblockhooks, param);
13474     PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13475
13476     /* Call the ->CLONE method, if it exists, for each of the stashes
13477        identified by sv_dup() above.
13478     */
13479     while(av_len(param->stashes) != -1) {
13480         HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13481         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13482         if (cloner && GvCV(cloner)) {
13483             dSP;
13484             ENTER;
13485             SAVETMPS;
13486             PUSHMARK(SP);
13487             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13488             PUTBACK;
13489             call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13490             FREETMPS;
13491             LEAVE;
13492         }
13493     }
13494
13495     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13496         ptr_table_free(PL_ptr_table);
13497         PL_ptr_table = NULL;
13498     }
13499
13500     if (!(flags & CLONEf_COPY_STACKS)) {
13501         unreferenced_to_tmp_stack(param->unreferenced);
13502     }
13503
13504     SvREFCNT_dec(param->stashes);
13505
13506     /* orphaned? eg threads->new inside BEGIN or use */
13507     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13508         SvREFCNT_inc_simple_void(PL_compcv);
13509         SAVEFREESV(PL_compcv);
13510     }
13511
13512     return my_perl;
13513 }
13514
13515 static void
13516 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13517 {
13518     PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13519
13520     if (AvFILLp(unreferenced) > -1) {
13521         SV **svp = AvARRAY(unreferenced);
13522         SV **const last = svp + AvFILLp(unreferenced);
13523         SSize_t count = 0;
13524
13525         do {
13526             if (SvREFCNT(*svp) == 1)
13527                 ++count;
13528         } while (++svp <= last);
13529
13530         EXTEND_MORTAL(count);
13531         svp = AvARRAY(unreferenced);
13532
13533         do {
13534             if (SvREFCNT(*svp) == 1) {
13535                 /* Our reference is the only one to this SV. This means that
13536                    in this thread, the scalar effectively has a 0 reference.
13537                    That doesn't work (cleanup never happens), so donate our
13538                    reference to it onto the save stack. */
13539                 PL_tmps_stack[++PL_tmps_ix] = *svp;
13540             } else {
13541                 /* As an optimisation, because we are already walking the
13542                    entire array, instead of above doing either
13543                    SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13544                    release our reference to the scalar, so that at the end of
13545                    the array owns zero references to the scalars it happens to
13546                    point to. We are effectively converting the array from
13547                    AvREAL() on to AvREAL() off. This saves the av_clear()
13548                    (triggered by the SvREFCNT_dec(unreferenced) below) from
13549                    walking the array a second time.  */
13550                 SvREFCNT_dec(*svp);
13551             }
13552
13553         } while (++svp <= last);
13554         AvREAL_off(unreferenced);
13555     }
13556     SvREFCNT_dec(unreferenced);
13557 }
13558
13559 void
13560 Perl_clone_params_del(CLONE_PARAMS *param)
13561 {
13562     /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13563        happy: */
13564     PerlInterpreter *const to = param->new_perl;
13565     dTHXa(to);
13566     PerlInterpreter *const was = PERL_GET_THX;
13567
13568     PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13569
13570     if (was != to) {
13571         PERL_SET_THX(to);
13572     }
13573
13574     SvREFCNT_dec(param->stashes);
13575     if (param->unreferenced)
13576         unreferenced_to_tmp_stack(param->unreferenced);
13577
13578     Safefree(param);
13579
13580     if (was != to) {
13581         PERL_SET_THX(was);
13582     }
13583 }
13584
13585 CLONE_PARAMS *
13586 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13587 {
13588     dVAR;
13589     /* Need to play this game, as newAV() can call safesysmalloc(), and that
13590        does a dTHX; to get the context from thread local storage.
13591        FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13592        a version that passes in my_perl.  */
13593     PerlInterpreter *const was = PERL_GET_THX;
13594     CLONE_PARAMS *param;
13595
13596     PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13597
13598     if (was != to) {
13599         PERL_SET_THX(to);
13600     }
13601
13602     /* Given that we've set the context, we can do this unshared.  */
13603     Newx(param, 1, CLONE_PARAMS);
13604
13605     param->flags = 0;
13606     param->proto_perl = from;
13607     param->new_perl = to;
13608     param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13609     AvREAL_off(param->stashes);
13610     param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13611
13612     if (was != to) {
13613         PERL_SET_THX(was);
13614     }
13615     return param;
13616 }
13617
13618 #endif /* USE_ITHREADS */
13619
13620 /*
13621 =head1 Unicode Support
13622
13623 =for apidoc sv_recode_to_utf8
13624
13625 The encoding is assumed to be an Encode object, on entry the PV
13626 of the sv is assumed to be octets in that encoding, and the sv
13627 will be converted into Unicode (and UTF-8).
13628
13629 If the sv already is UTF-8 (or if it is not POK), or if the encoding
13630 is not a reference, nothing is done to the sv.  If the encoding is not
13631 an C<Encode::XS> Encoding object, bad things will happen.
13632 (See F<lib/encoding.pm> and L<Encode>).
13633
13634 The PV of the sv is returned.
13635
13636 =cut */
13637
13638 char *
13639 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
13640 {
13641     dVAR;
13642
13643     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
13644
13645     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
13646         SV *uni;
13647         STRLEN len;
13648         const char *s;
13649         dSP;
13650         ENTER;
13651         SAVETMPS;
13652         save_re_context();
13653         PUSHMARK(sp);
13654         EXTEND(SP, 3);
13655         XPUSHs(encoding);
13656         XPUSHs(sv);
13657 /*
13658   NI-S 2002/07/09
13659   Passing sv_yes is wrong - it needs to be or'ed set of constants
13660   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
13661   remove converted chars from source.
13662
13663   Both will default the value - let them.
13664
13665         XPUSHs(&PL_sv_yes);
13666 */
13667         PUTBACK;
13668         call_method("decode", G_SCALAR);
13669         SPAGAIN;
13670         uni = POPs;
13671         PUTBACK;
13672         s = SvPV_const(uni, len);
13673         if (s != SvPVX_const(sv)) {
13674             SvGROW(sv, len + 1);
13675             Move(s, SvPVX(sv), len + 1, char);
13676             SvCUR_set(sv, len);
13677         }
13678         FREETMPS;
13679         LEAVE;
13680         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
13681             /* clear pos and any utf8 cache */
13682             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
13683             if (mg)
13684                 mg->mg_len = -1;
13685             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
13686                 magic_setutf8(sv,mg); /* clear UTF8 cache */
13687         }
13688         SvUTF8_on(sv);
13689         return SvPVX(sv);
13690     }
13691     return SvPOKp(sv) ? SvPVX(sv) : NULL;
13692 }
13693
13694 /*
13695 =for apidoc sv_cat_decode
13696
13697 The encoding is assumed to be an Encode object, the PV of the ssv is
13698 assumed to be octets in that encoding and decoding the input starts
13699 from the position which (PV + *offset) pointed to.  The dsv will be
13700 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
13701 when the string tstr appears in decoding output or the input ends on
13702 the PV of the ssv. The value which the offset points will be modified
13703 to the last input position on the ssv.
13704
13705 Returns TRUE if the terminator was found, else returns FALSE.
13706
13707 =cut */
13708
13709 bool
13710 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13711                    SV *ssv, int *offset, char *tstr, int tlen)
13712 {
13713     dVAR;
13714     bool ret = FALSE;
13715
13716     PERL_ARGS_ASSERT_SV_CAT_DECODE;
13717
13718     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13719         SV *offsv;
13720         dSP;
13721         ENTER;
13722         SAVETMPS;
13723         save_re_context();
13724         PUSHMARK(sp);
13725         EXTEND(SP, 6);
13726         XPUSHs(encoding);
13727         XPUSHs(dsv);
13728         XPUSHs(ssv);
13729         offsv = newSViv(*offset);
13730         mXPUSHs(offsv);
13731         mXPUSHp(tstr, tlen);
13732         PUTBACK;
13733         call_method("cat_decode", G_SCALAR);
13734         SPAGAIN;
13735         ret = SvTRUE(TOPs);
13736         *offset = SvIV(offsv);
13737         PUTBACK;
13738         FREETMPS;
13739         LEAVE;
13740     }
13741     else
13742         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13743     return ret;
13744
13745 }
13746
13747 /* ---------------------------------------------------------------------
13748  *
13749  * support functions for report_uninit()
13750  */
13751
13752 /* the maxiumum size of array or hash where we will scan looking
13753  * for the undefined element that triggered the warning */
13754
13755 #define FUV_MAX_SEARCH_SIZE 1000
13756
13757 /* Look for an entry in the hash whose value has the same SV as val;
13758  * If so, return a mortal copy of the key. */
13759
13760 STATIC SV*
13761 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13762 {
13763     dVAR;
13764     register HE **array;
13765     I32 i;
13766
13767     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13768
13769     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13770                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13771         return NULL;
13772
13773     array = HvARRAY(hv);
13774
13775     for (i=HvMAX(hv); i>0; i--) {
13776         register HE *entry;
13777         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13778             if (HeVAL(entry) != val)
13779                 continue;
13780             if (    HeVAL(entry) == &PL_sv_undef ||
13781                     HeVAL(entry) == &PL_sv_placeholder)
13782                 continue;
13783             if (!HeKEY(entry))
13784                 return NULL;
13785             if (HeKLEN(entry) == HEf_SVKEY)
13786                 return sv_mortalcopy(HeKEY_sv(entry));
13787             return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13788         }
13789     }
13790     return NULL;
13791 }
13792
13793 /* Look for an entry in the array whose value has the same SV as val;
13794  * If so, return the index, otherwise return -1. */
13795
13796 STATIC I32
13797 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13798 {
13799     dVAR;
13800
13801     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13802
13803     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13804                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13805         return -1;
13806
13807     if (val != &PL_sv_undef) {
13808         SV ** const svp = AvARRAY(av);
13809         I32 i;
13810
13811         for (i=AvFILLp(av); i>=0; i--)
13812             if (svp[i] == val)
13813                 return i;
13814     }
13815     return -1;
13816 }
13817
13818 /* S_varname(): return the name of a variable, optionally with a subscript.
13819  * If gv is non-zero, use the name of that global, along with gvtype (one
13820  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13821  * targ.  Depending on the value of the subscript_type flag, return:
13822  */
13823
13824 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
13825 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
13826 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
13827 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
13828
13829 STATIC SV*
13830 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13831         const SV *const keyname, I32 aindex, int subscript_type)
13832 {
13833
13834     SV * const name = sv_newmortal();
13835     if (gv) {
13836         char buffer[2];
13837         buffer[0] = gvtype;
13838         buffer[1] = 0;
13839
13840         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
13841
13842         gv_fullname4(name, gv, buffer, 0);
13843
13844         if ((unsigned int)SvPVX(name)[1] <= 26) {
13845             buffer[0] = '^';
13846             buffer[1] = SvPVX(name)[1] + 'A' - 1;
13847
13848             /* Swap the 1 unprintable control character for the 2 byte pretty
13849                version - ie substr($name, 1, 1) = $buffer; */
13850             sv_insert(name, 1, 1, buffer, 2);
13851         }
13852     }
13853     else {
13854         CV * const cv = find_runcv(NULL);
13855         SV *sv;
13856         AV *av;
13857
13858         if (!cv || !CvPADLIST(cv))
13859             return NULL;
13860         av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13861         sv = *av_fetch(av, targ, FALSE);
13862         sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
13863     }
13864
13865     if (subscript_type == FUV_SUBSCRIPT_HASH) {
13866         SV * const sv = newSV(0);
13867         *SvPVX(name) = '$';
13868         Perl_sv_catpvf(aTHX_ name, "{%s}",
13869             pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
13870         SvREFCNT_dec(sv);
13871     }
13872     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13873         *SvPVX(name) = '$';
13874         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13875     }
13876     else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13877         /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13878         Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
13879     }
13880
13881     return name;
13882 }
13883
13884
13885 /*
13886 =for apidoc find_uninit_var
13887
13888 Find the name of the undefined variable (if any) that caused the operator o
13889 to issue a "Use of uninitialized value" warning.
13890 If match is true, only return a name if it's value matches uninit_sv.
13891 So roughly speaking, if a unary operator (such as OP_COS) generates a
13892 warning, then following the direct child of the op may yield an
13893 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
13894 other hand, with OP_ADD there are two branches to follow, so we only print
13895 the variable name if we get an exact match.
13896
13897 The name is returned as a mortal SV.
13898
13899 Assumes that PL_op is the op that originally triggered the error, and that
13900 PL_comppad/PL_curpad points to the currently executing pad.
13901
13902 =cut
13903 */
13904
13905 STATIC SV *
13906 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
13907                   bool match)
13908 {
13909     dVAR;
13910     SV *sv;
13911     const GV *gv;
13912     const OP *o, *o2, *kid;
13913
13914     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
13915                             uninit_sv == &PL_sv_placeholder)))
13916         return NULL;
13917
13918     switch (obase->op_type) {
13919
13920     case OP_RV2AV:
13921     case OP_RV2HV:
13922     case OP_PADAV:
13923     case OP_PADHV:
13924       {
13925         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
13926         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
13927         I32 index = 0;
13928         SV *keysv = NULL;
13929         int subscript_type = FUV_SUBSCRIPT_WITHIN;
13930
13931         if (pad) { /* @lex, %lex */
13932             sv = PAD_SVl(obase->op_targ);
13933             gv = NULL;
13934         }
13935         else {
13936             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
13937             /* @global, %global */
13938                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
13939                 if (!gv)
13940                     break;
13941                 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
13942             }
13943             else /* @{expr}, %{expr} */
13944                 return find_uninit_var(cUNOPx(obase)->op_first,
13945                                                     uninit_sv, match);
13946         }
13947
13948         /* attempt to find a match within the aggregate */
13949         if (hash) {
13950             keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13951             if (keysv)
13952                 subscript_type = FUV_SUBSCRIPT_HASH;
13953         }
13954         else {
13955             index = find_array_subscript((const AV *)sv, uninit_sv);
13956             if (index >= 0)
13957                 subscript_type = FUV_SUBSCRIPT_ARRAY;
13958         }
13959
13960         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
13961             break;
13962
13963         return varname(gv, hash ? '%' : '@', obase->op_targ,
13964                                     keysv, index, subscript_type);
13965       }
13966
13967     case OP_PADSV:
13968         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
13969             break;
13970         return varname(NULL, '$', obase->op_targ,
13971                                     NULL, 0, FUV_SUBSCRIPT_NONE);
13972
13973     case OP_GVSV:
13974         gv = cGVOPx_gv(obase);
13975         if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
13976             break;
13977         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
13978
13979     case OP_AELEMFAST:
13980         if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
13981             if (match) {
13982                 SV **svp;
13983                 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
13984                 if (!av || SvRMAGICAL(av))
13985                     break;
13986                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13987                 if (!svp || *svp != uninit_sv)
13988                     break;
13989             }
13990             return varname(NULL, '$', obase->op_targ,
13991                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13992         }
13993         else {
13994             gv = cGVOPx_gv(obase);
13995             if (!gv)
13996                 break;
13997             if (match) {
13998                 SV **svp;
13999                 AV *const av = GvAV(gv);
14000                 if (!av || SvRMAGICAL(av))
14001                     break;
14002                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
14003                 if (!svp || *svp != uninit_sv)
14004                     break;
14005             }
14006             return varname(gv, '$', 0,
14007                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14008         }
14009         break;
14010
14011     case OP_EXISTS:
14012         o = cUNOPx(obase)->op_first;
14013         if (!o || o->op_type != OP_NULL ||
14014                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
14015             break;
14016         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
14017
14018     case OP_AELEM:
14019     case OP_HELEM:
14020         if (PL_op == obase)
14021             /* $a[uninit_expr] or $h{uninit_expr} */
14022             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
14023
14024         gv = NULL;
14025         o = cBINOPx(obase)->op_first;
14026         kid = cBINOPx(obase)->op_last;
14027
14028         /* get the av or hv, and optionally the gv */
14029         sv = NULL;
14030         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
14031             sv = PAD_SV(o->op_targ);
14032         }
14033         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
14034                 && cUNOPo->op_first->op_type == OP_GV)
14035         {
14036             gv = cGVOPx_gv(cUNOPo->op_first);
14037             if (!gv)
14038                 break;
14039             sv = o->op_type
14040                 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
14041         }
14042         if (!sv)
14043             break;
14044
14045         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
14046             /* index is constant */
14047             if (match) {
14048                 if (SvMAGICAL(sv))
14049                     break;
14050                 if (obase->op_type == OP_HELEM) {
14051                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
14052                     if (!he || HeVAL(he) != uninit_sv)
14053                         break;
14054                 }
14055                 else {
14056                     SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
14057                     if (!svp || *svp != uninit_sv)
14058                         break;
14059                 }
14060             }
14061             if (obase->op_type == OP_HELEM)
14062                 return varname(gv, '%', o->op_targ,
14063                             cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
14064             else
14065                 return varname(gv, '@', o->op_targ, NULL,
14066                             SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
14067         }
14068         else  {
14069             /* index is an expression;
14070              * attempt to find a match within the aggregate */
14071             if (obase->op_type == OP_HELEM) {
14072                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14073                 if (keysv)
14074                     return varname(gv, '%', o->op_targ,
14075                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
14076             }
14077             else {
14078                 const I32 index
14079                     = find_array_subscript((const AV *)sv, uninit_sv);
14080                 if (index >= 0)
14081                     return varname(gv, '@', o->op_targ,
14082                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
14083             }
14084             if (match)
14085                 break;
14086             return varname(gv,
14087                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
14088                 ? '@' : '%',
14089                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
14090         }
14091         break;
14092
14093     case OP_AASSIGN:
14094         /* only examine RHS */
14095         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
14096
14097     case OP_OPEN:
14098         o = cUNOPx(obase)->op_first;
14099         if (o->op_type == OP_PUSHMARK)
14100             o = o->op_sibling;
14101
14102         if (!o->op_sibling) {
14103             /* one-arg version of open is highly magical */
14104
14105             if (o->op_type == OP_GV) { /* open FOO; */
14106                 gv = cGVOPx_gv(o);
14107                 if (match && GvSV(gv) != uninit_sv)
14108                     break;
14109                 return varname(gv, '$', 0,
14110                             NULL, 0, FUV_SUBSCRIPT_NONE);
14111             }
14112             /* other possibilities not handled are:
14113              * open $x; or open my $x;  should return '${*$x}'
14114              * open expr;               should return '$'.expr ideally
14115              */
14116              break;
14117         }
14118         goto do_op;
14119
14120     /* ops where $_ may be an implicit arg */
14121     case OP_TRANS:
14122     case OP_SUBST:
14123     case OP_MATCH:
14124         if ( !(obase->op_flags & OPf_STACKED)) {
14125             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
14126                                  ? PAD_SVl(obase->op_targ)
14127                                  : DEFSV))
14128             {
14129                 sv = sv_newmortal();
14130                 sv_setpvs(sv, "$_");
14131                 return sv;
14132             }
14133         }
14134         goto do_op;
14135
14136     case OP_PRTF:
14137     case OP_PRINT:
14138     case OP_SAY:
14139         match = 1; /* print etc can return undef on defined args */
14140         /* skip filehandle as it can't produce 'undef' warning  */
14141         o = cUNOPx(obase)->op_first;
14142         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
14143             o = o->op_sibling->op_sibling;
14144         goto do_op2;
14145
14146
14147     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
14148     case OP_RV2SV:
14149     case OP_CUSTOM: /* XS or custom code could trigger random warnings */
14150
14151         /* the following ops are capable of returning PL_sv_undef even for
14152          * defined arg(s) */
14153
14154     case OP_BACKTICK:
14155     case OP_PIPE_OP:
14156     case OP_FILENO:
14157     case OP_BINMODE:
14158     case OP_TIED:
14159     case OP_GETC:
14160     case OP_SYSREAD:
14161     case OP_SEND:
14162     case OP_IOCTL:
14163     case OP_SOCKET:
14164     case OP_SOCKPAIR:
14165     case OP_BIND:
14166     case OP_CONNECT:
14167     case OP_LISTEN:
14168     case OP_ACCEPT:
14169     case OP_SHUTDOWN:
14170     case OP_SSOCKOPT:
14171     case OP_GETPEERNAME:
14172     case OP_FTRREAD:
14173     case OP_FTRWRITE:
14174     case OP_FTREXEC:
14175     case OP_FTROWNED:
14176     case OP_FTEREAD:
14177     case OP_FTEWRITE:
14178     case OP_FTEEXEC:
14179     case OP_FTEOWNED:
14180     case OP_FTIS:
14181     case OP_FTZERO:
14182     case OP_FTSIZE:
14183     case OP_FTFILE:
14184     case OP_FTDIR:
14185     case OP_FTLINK:
14186     case OP_FTPIPE:
14187     case OP_FTSOCK:
14188     case OP_FTBLK:
14189     case OP_FTCHR:
14190     case OP_FTTTY:
14191     case OP_FTSUID:
14192     case OP_FTSGID:
14193     case OP_FTSVTX:
14194     case OP_FTTEXT:
14195     case OP_FTBINARY:
14196     case OP_FTMTIME:
14197     case OP_FTATIME:
14198     case OP_FTCTIME:
14199     case OP_READLINK:
14200     case OP_OPEN_DIR:
14201     case OP_READDIR:
14202     case OP_TELLDIR:
14203     case OP_SEEKDIR:
14204     case OP_REWINDDIR:
14205     case OP_CLOSEDIR:
14206     case OP_GMTIME:
14207     case OP_ALARM:
14208     case OP_SEMGET:
14209     case OP_GETLOGIN:
14210     case OP_UNDEF:
14211     case OP_SUBSTR:
14212     case OP_AEACH:
14213     case OP_EACH:
14214     case OP_SORT:
14215     case OP_CALLER:
14216     case OP_DOFILE:
14217     case OP_PROTOTYPE:
14218     case OP_NCMP:
14219     case OP_SMARTMATCH:
14220     case OP_UNPACK:
14221     case OP_SYSOPEN:
14222     case OP_SYSSEEK:
14223         match = 1;
14224         goto do_op;
14225
14226     case OP_ENTERSUB:
14227     case OP_GOTO:
14228         /* XXX tmp hack: these two may call an XS sub, and currently
14229           XS subs don't have a SUB entry on the context stack, so CV and
14230           pad determination goes wrong, and BAD things happen. So, just
14231           don't try to determine the value under those circumstances.
14232           Need a better fix at dome point. DAPM 11/2007 */
14233         break;
14234
14235     case OP_FLIP:
14236     case OP_FLOP:
14237     {
14238         GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
14239         if (gv && GvSV(gv) == uninit_sv)
14240             return newSVpvs_flags("$.", SVs_TEMP);
14241         goto do_op;
14242     }
14243
14244     case OP_POS:
14245         /* def-ness of rval pos() is independent of the def-ness of its arg */
14246         if ( !(obase->op_flags & OPf_MOD))
14247             break;
14248
14249     case OP_SCHOMP:
14250     case OP_CHOMP:
14251         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
14252             return newSVpvs_flags("${$/}", SVs_TEMP);
14253         /*FALLTHROUGH*/
14254
14255     default:
14256     do_op:
14257         if (!(obase->op_flags & OPf_KIDS))
14258             break;
14259         o = cUNOPx(obase)->op_first;
14260
14261     do_op2:
14262         if (!o)
14263             break;
14264
14265         /* if all except one arg are constant, or have no side-effects,
14266          * or are optimized away, then it's unambiguous */
14267         o2 = NULL;
14268         for (kid=o; kid; kid = kid->op_sibling) {
14269             if (kid) {
14270                 const OPCODE type = kid->op_type;
14271                 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
14272                   || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
14273                   || (type == OP_PUSHMARK)
14274                   || (
14275                       /* @$a and %$a, but not @a or %a */
14276                         (type == OP_RV2AV || type == OP_RV2HV)
14277                      && cUNOPx(kid)->op_first
14278                      && cUNOPx(kid)->op_first->op_type != OP_GV
14279                      )
14280                 )
14281                 continue;
14282             }
14283             if (o2) { /* more than one found */
14284                 o2 = NULL;
14285                 break;
14286             }
14287             o2 = kid;
14288         }
14289         if (o2)
14290             return find_uninit_var(o2, uninit_sv, match);
14291
14292         /* scan all args */
14293         while (o) {
14294             sv = find_uninit_var(o, uninit_sv, 1);
14295             if (sv)
14296                 return sv;
14297             o = o->op_sibling;
14298         }
14299         break;
14300     }
14301     return NULL;
14302 }
14303
14304
14305 /*
14306 =for apidoc report_uninit
14307
14308 Print appropriate "Use of uninitialized variable" warning
14309
14310 =cut
14311 */
14312
14313 void
14314 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14315 {
14316     dVAR;
14317     if (PL_op) {
14318         SV* varname = NULL;
14319         if (uninit_sv) {
14320             varname = find_uninit_var(PL_op, uninit_sv,0);
14321             if (varname)
14322                 sv_insert(varname, 0, 0, " ", 1);
14323         }
14324         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14325                 varname ? SvPV_nolen_const(varname) : "",
14326                 " in ", OP_DESC(PL_op));
14327     }
14328     else
14329         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14330                     "", "", "");
14331 }
14332
14333 /*
14334  * Local variables:
14335  * c-indentation-style: bsd
14336  * c-basic-offset: 4
14337  * indent-tabs-mode: t
14338  * End:
14339  *
14340  * ex: set ts=8 sts=4 sw=4 noet:
14341  */