sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
   5  *    and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'I wonder what the Entish is for "yes" and "no",' he thought.
  14  *                                                      --Pippin
  15  *
  16  *     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
  17  */
  18
  19 /*
  20  *
  21  *
  22  * This file contains the code that creates, manipulates and destroys
  23  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
  24  * structure of an SV, so their creation and destruction is handled
  25  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
  26  * level functions (eg. substr, split, join) for each of the types are
  27  * in the pp*.c files.
  28  */
  29
  30 #include "EXTERN.h"
  31 #define PERL_IN_SV_C
  32 #include "perl.h"
  33 #include "regcomp.h"
  34
  35 #ifndef HAS_C99
  36 # if __STDC_VERSION__ >= 199901L && !defined(VMS)
  37 #  define HAS_C99 1
  38 # endif
  39 #endif
  40 #if HAS_C99
  41 # include <stdint.h>
  42 #endif
  43
  44 #define FCALL *f
  45
  46 #ifdef __Lynx__
  47 /* Missing proto on LynxOS */
  48   char *gconvert(double, int, int,  char *);
  49 #endif
  50
  51 #ifdef PERL_UTF8_CACHE_ASSERT
  52 /* if adding more checks watch out for the following tests:
  53  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
  54  *   lib/utf8.t lib/Unicode/Collate/t/index.t
  55  * --jhi
  56  */
  57 #   define ASSERT_UTF8_CACHE(cache) \
  58     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
  59                               assert((cache)[2] <= (cache)[3]); \
  60                               assert((cache)[3] <= (cache)[1]);} \
  61                               } STMT_END
  62 #else
  63 #   define ASSERT_UTF8_CACHE(cache) NOOP
  64 #endif
  65
  66 #ifdef PERL_OLD_COPY_ON_WRITE
  67 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
  68 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
  69 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
  70    on-write.  */
  71 #endif
  72
  73 /* ============================================================================
  74
  75 =head1 Allocation and deallocation of SVs.
  76
  77 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
  78 sv, av, hv...) contains type and reference count information, and for
  79 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
  80 contains fields specific to each type.  Some types store all they need
  81 in the head, so don't have a body.
  82
  83 In all but the most memory-paranoid configurations (ex: PURIFY), heads
  84 and bodies are allocated out of arenas, which by default are
  85 approximately 4K chunks of memory parcelled up into N heads or bodies.
  86 Sv-bodies are allocated by their sv-type, guaranteeing size
  87 consistency needed to allocate safely from arrays.
  88
  89 For SV-heads, the first slot in each arena is reserved, and holds a
  90 link to the next arena, some flags, and a note of the number of slots.
  91 Snaked through each arena chain is a linked list of free items; when
  92 this becomes empty, an extra arena is allocated and divided up into N
  93 items which are threaded into the free list.
  94
  95 SV-bodies are similar, but they use arena-sets by default, which
  96 separate the link and info from the arena itself, and reclaim the 1st
  97 slot in the arena.  SV-bodies are further described later.
  98
  99 The following global variables are associated with arenas:
 100
 101     PL_sv_arenaroot     pointer to list of SV arenas
 102     PL_sv_root          pointer to list of free SV structures
 103
 104     PL_body_arenas      head of linked-list of body arenas
 105     PL_body_roots[]     array of pointers to list of free bodies of svtype
 106                         arrays are indexed by the svtype needed
 107
 108 A few special SV heads are not allocated from an arena, but are
 109 instead directly created in the interpreter structure, eg PL_sv_undef.
 110 The size of arenas can be changed from the default by setting
 111 PERL_ARENA_SIZE appropriately at compile time.
 112
 113 The SV arena serves the secondary purpose of allowing still-live SVs
 114 to be located and destroyed during final cleanup.
 115
 116 At the lowest level, the macros new_SV() and del_SV() grab and free
 117 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
 118 to return the SV to the free list with error checking.) new_SV() calls
 119 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
 120 SVs in the free list have their SvTYPE field set to all ones.
 121
 122 At the time of very final cleanup, sv_free_arenas() is called from
 123 perl_destruct() to physically free all the arenas allocated since the
 124 start of the interpreter.
 125
 126 The function visit() scans the SV arenas list, and calls a specified
 127 function for each SV it finds which is still live - ie which has an SvTYPE
 128 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
 129 following functions (specified as [function that calls visit()] / [function
 130 called by visit() for each SV]):
 131
 132     sv_report_used() / do_report_used()
 133                         dump all remaining SVs (debugging aid)
 134
 135     sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
 136                       do_clean_named_io_objs()
 137                         Attempt to free all objects pointed to by RVs,
 138                         and try to do the same for all objects indirectly
 139                         referenced by typeglobs too.  Called once from
 140                         perl_destruct(), prior to calling sv_clean_all()
 141                         below.
 142
 143     sv_clean_all() / do_clean_all()
 144                         SvREFCNT_dec(sv) each remaining SV, possibly
 145                         triggering an sv_free(). It also sets the
 146                         SVf_BREAK flag on the SV to indicate that the
 147                         refcnt has been artificially lowered, and thus
 148                         stopping sv_free() from giving spurious warnings
 149                         about SVs which unexpectedly have a refcnt
 150                         of zero.  called repeatedly from perl_destruct()
 151                         until there are no SVs left.
 152
 153 =head2 Arena allocator API Summary
 154
 155 Private API to rest of sv.c
 156
 157     new_SV(),  del_SV(),
 158
 159     new_XPVNV(), del_XPVGV(),
 160     etc
 161
 162 Public API:
 163
 164     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
 165
 166 =cut
 167
 168  * ========================================================================= */
 169
 170 /*
 171  * "A time to plant, and a time to uproot what was planted..."
 172  */
 173
 174 #ifdef PERL_MEM_LOG
 175 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
 176             Perl_mem_log_new_sv(sv, file, line, func)
 177 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
 178             Perl_mem_log_del_sv(sv, file, line, func)
 179 #else
 180 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
 181 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
 182 #endif
 183
 184 #ifdef DEBUG_LEAKING_SCALARS
 185 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
 186 #  define DEBUG_SV_SERIAL(sv)                                               \
 187     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
 188             PTR2UV(sv), (long)(sv)->sv_debug_serial))
 189 #else
 190 #  define FREE_SV_DEBUG_FILE(sv)
 191 #  define DEBUG_SV_SERIAL(sv)   NOOP
 192 #endif
 193
 194 #ifdef PERL_POISON
 195 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
 196 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = MUTABLE_SV((val))
 197 /* Whilst I'd love to do this, it seems that things like to check on
 198    unreferenced scalars
 199 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
 200 */
 201 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
 202                                 PoisonNew(&SvREFCNT(sv), 1, U32)
 203 #else
 204 #  define SvARENA_CHAIN(sv)     SvANY(sv)
 205 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
 206 #  define POSION_SV_HEAD(sv)
 207 #endif
 208
 209 /* Mark an SV head as unused, and add to free list.
 210  *
 211  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
 212  * its refcount artificially decremented during global destruction, so
 213  * there may be dangling pointers to it. The last thing we want in that
 214  * case is for it to be reused. */
 215
 216 #define plant_SV(p) \
 217     STMT_START {                                        \
 218         const U32 old_flags = SvFLAGS(p);                       \
 219         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 220         DEBUG_SV_SERIAL(p);                             \
 221         FREE_SV_DEBUG_FILE(p);                          \
 222         POSION_SV_HEAD(p);                              \
 223         SvFLAGS(p) = SVTYPEMASK;                        \
 224         if (!(old_flags & SVf_BREAK)) {         \
 225             SvARENA_CHAIN_SET(p, PL_sv_root);   \
 226             PL_sv_root = (p);                           \
 227         }                                               \
 228         --PL_sv_count;                                  \
 229     } STMT_END
 230
 231 #define uproot_SV(p) \
 232     STMT_START {                                        \
 233         (p) = PL_sv_root;                               \
 234         PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p));              \
 235         ++PL_sv_count;                                  \
 236     } STMT_END
 237
 238
 239 /* make some more SVs by adding another arena */
 240
 241 STATIC SV*
 242 S_more_sv(pTHX)
 243 {
 244     dVAR;
 245     SV* sv;
 246     char *chunk;                /* must use New here to match call to */
 247     Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
 248     sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
 249     uproot_SV(sv);
 250     return sv;
 251 }
 252
 253 /* new_SV(): return a new, empty SV head */
 254
 255 #ifdef DEBUG_LEAKING_SCALARS
 256 /* provide a real function for a debugger to play with */
 257 STATIC SV*
 258 S_new_SV(pTHX_ const char *file, int line, const char *func)
 259 {
 260     SV* sv;
 261
 262     if (PL_sv_root)
 263         uproot_SV(sv);
 264     else
 265         sv = S_more_sv(aTHX);
 266     SvANY(sv) = 0;
 267     SvREFCNT(sv) = 1;
 268     SvFLAGS(sv) = 0;
 269     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
 270     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
 271                 ? PL_parser->copline
 272                 :  PL_curcop
 273                     ? CopLINE(PL_curcop)
 274                     : 0
 275             );
 276     sv->sv_debug_inpad = 0;
 277     sv->sv_debug_parent = NULL;
 278     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 279
 280     sv->sv_debug_serial = PL_sv_serial++;
 281
 282     MEM_LOG_NEW_SV(sv, file, line, func);
 283     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
 284             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
 285
 286     return sv;
 287 }
 288 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
 289
 290 #else
 291 #  define new_SV(p) \
 292     STMT_START {                                        \
 293         if (PL_sv_root)                                 \
 294             uproot_SV(p);                               \
 295         else                                            \
 296             (p) = S_more_sv(aTHX);                      \
 297         SvANY(p) = 0;                                   \
 298         SvREFCNT(p) = 1;                                \
 299         SvFLAGS(p) = 0;                                 \
 300         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 301     } STMT_END
 302 #endif
 303
 304
 305 /* del_SV(): return an empty SV head to the free list */
 306
 307 #ifdef DEBUGGING
 308
 309 #define del_SV(p) \
 310     STMT_START {                                        \
 311         if (DEBUG_D_TEST)                               \
 312             del_sv(p);                                  \
 313         else                                            \
 314             plant_SV(p);                                \
 315     } STMT_END
 316
 317 STATIC void
 318 S_del_sv(pTHX_ SV *p)
 319 {
 320     dVAR;
 321
 322     PERL_ARGS_ASSERT_DEL_SV;
 323
 324     if (DEBUG_D_TEST) {
 325         SV* sva;
 326         bool ok = 0;
 327         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 328             const SV * const sv = sva + 1;
 329             const SV * const svend = &sva[SvREFCNT(sva)];
 330             if (p >= sv && p < svend) {
 331                 ok = 1;
 332                 break;
 333             }
 334         }
 335         if (!ok) {
 336             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
 337                              "Attempt to free non-arena SV: 0x%"UVxf
 338                              pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
 339             return;
 340         }
 341     }
 342     plant_SV(p);
 343 }
 344
 345 #else /* ! DEBUGGING */
 346
 347 #define del_SV(p)   plant_SV(p)
 348
 349 #endif /* DEBUGGING */
 350
 351
 352 /*
 353 =head1 SV Manipulation Functions
 354
 355 =for apidoc sv_add_arena
 356
 357 Given a chunk of memory, link it to the head of the list of arenas,
 358 and split it into a list of free SVs.
 359
 360 =cut
 361 */
 362
 363 static void
 364 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
 365 {
 366     dVAR;
 367     SV *const sva = MUTABLE_SV(ptr);
 368     register SV* sv;
 369     register SV* svend;
 370
 371     PERL_ARGS_ASSERT_SV_ADD_ARENA;
 372
 373     /* The first SV in an arena isn't an SV. */
 374     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 375     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 376     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 377
 378     PL_sv_arenaroot = sva;
 379     PL_sv_root = sva + 1;
 380
 381     svend = &sva[SvREFCNT(sva) - 1];
 382     sv = sva + 1;
 383     while (sv < svend) {
 384         SvARENA_CHAIN_SET(sv, (sv + 1));
 385 #ifdef DEBUGGING
 386         SvREFCNT(sv) = 0;
 387 #endif
 388         /* Must always set typemask because it's always checked in on cleanup
 389            when the arenas are walked looking for objects.  */
 390         SvFLAGS(sv) = SVTYPEMASK;
 391         sv++;
 392     }
 393     SvARENA_CHAIN_SET(sv, 0);
 394 #ifdef DEBUGGING
 395     SvREFCNT(sv) = 0;
 396 #endif
 397     SvFLAGS(sv) = SVTYPEMASK;
 398 }
 399
 400 /* visit(): call the named function for each non-free SV in the arenas
 401  * whose flags field matches the flags/mask args. */
 402
 403 STATIC I32
 404 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
 405 {
 406     dVAR;
 407     SV* sva;
 408     I32 visited = 0;
 409
 410     PERL_ARGS_ASSERT_VISIT;
 411
 412     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 413         register const SV * const svend = &sva[SvREFCNT(sva)];
 414         register SV* sv;
 415         for (sv = sva + 1; sv < svend; ++sv) {
 416             if (SvTYPE(sv) != (svtype)SVTYPEMASK
 417                     && (sv->sv_flags & mask) == flags
 418                     && SvREFCNT(sv))
 419             {
 420                 (FCALL)(aTHX_ sv);
 421                 ++visited;
 422             }
 423         }
 424     }
 425     return visited;
 426 }
 427
 428 #ifdef DEBUGGING
 429
 430 /* called by sv_report_used() for each live SV */
 431
 432 static void
 433 do_report_used(pTHX_ SV *const sv)
 434 {
 435     if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
 436         PerlIO_printf(Perl_debug_log, "****\n");
 437         sv_dump(sv);
 438     }
 439 }
 440 #endif
 441
 442 /*
 443 =for apidoc sv_report_used
 444
 445 Dump the contents of all SVs not yet freed (debugging aid).
 446
 447 =cut
 448 */
 449
 450 void
 451 Perl_sv_report_used(pTHX)
 452 {
 453 #ifdef DEBUGGING
 454     visit(do_report_used, 0, 0);
 455 #else
 456     PERL_UNUSED_CONTEXT;
 457 #endif
 458 }
 459
 460 /* called by sv_clean_objs() for each live SV */
 461
 462 static void
 463 do_clean_objs(pTHX_ SV *const ref)
 464 {
 465     dVAR;
 466     assert (SvROK(ref));
 467     {
 468         SV * const target = SvRV(ref);
 469         if (SvOBJECT(target)) {
 470             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
 471             if (SvWEAKREF(ref)) {
 472                 sv_del_backref(target, ref);
 473                 SvWEAKREF_off(ref);
 474                 SvRV_set(ref, NULL);
 475             } else {
 476                 SvROK_off(ref);
 477                 SvRV_set(ref, NULL);
 478                 SvREFCNT_dec(target);
 479             }
 480         }
 481     }
 482
 483     /* XXX Might want to check arrays, etc. */
 484 }
 485
 486
 487 /* clear any slots in a GV which hold objects - except IO;
 488  * called by sv_clean_objs() for each live GV */
 489
 490 static void
 491 do_clean_named_objs(pTHX_ SV *const sv)
 492 {
 493     dVAR;
 494     SV *obj;
 495     assert(SvTYPE(sv) == SVt_PVGV);
 496     assert(isGV_with_GP(sv));
 497     if (!GvGP(sv))
 498         return;
 499
 500     /* freeing GP entries may indirectly free the current GV;
 501      * hold onto it while we mess with the GP slots */
 502     SvREFCNT_inc(sv);
 503
 504     if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
 505         DEBUG_D((PerlIO_printf(Perl_debug_log,
 506                 "Cleaning named glob SV object:\n "), sv_dump(obj)));
 507         GvSV(sv) = NULL;
 508         SvREFCNT_dec(obj);
 509     }
 510     if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
 511         DEBUG_D((PerlIO_printf(Perl_debug_log,
 512                 "Cleaning named glob AV object:\n "), sv_dump(obj)));
 513         GvAV(sv) = NULL;
 514         SvREFCNT_dec(obj);
 515     }
 516     if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
 517         DEBUG_D((PerlIO_printf(Perl_debug_log,
 518                 "Cleaning named glob HV object:\n "), sv_dump(obj)));
 519         GvHV(sv) = NULL;
 520         SvREFCNT_dec(obj);
 521     }
 522     if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
 523         DEBUG_D((PerlIO_printf(Perl_debug_log,
 524                 "Cleaning named glob CV object:\n "), sv_dump(obj)));
 525         GvCV_set(sv, NULL);
 526         SvREFCNT_dec(obj);
 527     }
 528     SvREFCNT_dec(sv); /* undo the inc above */
 529 }
 530
 531 /* clear any IO slots in a GV which hold objects (except stderr, defout);
 532  * called by sv_clean_objs() for each live GV */
 533
 534 static void
 535 do_clean_named_io_objs(pTHX_ SV *const sv)
 536 {
 537     dVAR;
 538     SV *obj;
 539     assert(SvTYPE(sv) == SVt_PVGV);
 540     assert(isGV_with_GP(sv));
 541     if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
 542         return;
 543
 544     SvREFCNT_inc(sv);
 545     if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
 546         DEBUG_D((PerlIO_printf(Perl_debug_log,
 547                 "Cleaning named glob IO object:\n "), sv_dump(obj)));
 548         GvIOp(sv) = NULL;
 549         SvREFCNT_dec(obj);
 550     }
 551     SvREFCNT_dec(sv); /* undo the inc above */
 552 }
 553
 554 /* Void wrapper to pass to visit() */
 555 static void
 556 do_curse(pTHX_ SV * const sv) {
 557     if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
 558      || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
 559         return;
 560     (void)curse(sv, 0);
 561 }
 562
 563 /*
 564 =for apidoc sv_clean_objs
 565
 566 Attempt to destroy all objects not yet freed.
 567
 568 =cut
 569 */
 570
 571 void
 572 Perl_sv_clean_objs(pTHX)
 573 {
 574     dVAR;
 575     GV *olddef, *olderr;
 576     PL_in_clean_objs = TRUE;
 577     visit(do_clean_objs, SVf_ROK, SVf_ROK);
 578     /* Some barnacles may yet remain, clinging to typeglobs.
 579      * Run the non-IO destructors first: they may want to output
 580      * error messages, close files etc */
 581     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
 582     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
 583     /* And if there are some very tenacious barnacles clinging to arrays,
 584        closures, or what have you.... */
 585     visit(do_curse, SVs_OBJECT, SVs_OBJECT);
 586     olddef = PL_defoutgv;
 587     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
 588     if (olddef && isGV_with_GP(olddef))
 589         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
 590     olderr = PL_stderrgv;
 591     PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
 592     if (olderr && isGV_with_GP(olderr))
 593         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
 594     SvREFCNT_dec(olddef);
 595     PL_in_clean_objs = FALSE;
 596 }
 597
 598 /* called by sv_clean_all() for each live SV */
 599
 600 static void
 601 do_clean_all(pTHX_ SV *const sv)
 602 {
 603     dVAR;
 604     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
 605         /* don't clean pid table and strtab */
 606         return;
 607     }
 608     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
 609     SvFLAGS(sv) |= SVf_BREAK;
 610     SvREFCNT_dec(sv);
 611 }
 612
 613 /*
 614 =for apidoc sv_clean_all
 615
 616 Decrement the refcnt of each remaining SV, possibly triggering a
 617 cleanup.  This function may have to be called multiple times to free
 618 SVs which are in complex self-referential hierarchies.
 619
 620 =cut
 621 */
 622
 623 I32
 624 Perl_sv_clean_all(pTHX)
 625 {
 626     dVAR;
 627     I32 cleaned;
 628     PL_in_clean_all = TRUE;
 629     cleaned = visit(do_clean_all, 0,0);
 630     return cleaned;
 631 }
 632
 633 /*
 634   ARENASETS: a meta-arena implementation which separates arena-info
 635   into struct arena_set, which contains an array of struct
 636   arena_descs, each holding info for a single arena.  By separating
 637   the meta-info from the arena, we recover the 1st slot, formerly
 638   borrowed for list management.  The arena_set is about the size of an
 639   arena, avoiding the needless malloc overhead of a naive linked-list.
 640
 641   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
 642   memory in the last arena-set (1/2 on average).  In trade, we get
 643   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
 644   smaller types).  The recovery of the wasted space allows use of
 645   small arenas for large, rare body types, by changing array* fields
 646   in body_details_by_type[] below.
 647 */
 648 struct arena_desc {
 649     char       *arena;          /* the raw storage, allocated aligned */
 650     size_t      size;           /* its size ~4k typ */
 651     svtype      utype;          /* bodytype stored in arena */
 652 };
 653
 654 struct arena_set;
 655
 656 /* Get the maximum number of elements in set[] such that struct arena_set
 657    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
 658    therefore likely to be 1 aligned memory page.  */
 659
 660 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
 661                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
 662
 663 struct arena_set {
 664     struct arena_set* next;
 665     unsigned int   set_size;    /* ie ARENAS_PER_SET */
 666     unsigned int   curr;        /* index of next available arena-desc */
 667     struct arena_desc set[ARENAS_PER_SET];
 668 };
 669
 670 /*
 671 =for apidoc sv_free_arenas
 672
 673 Deallocate the memory used by all arenas.  Note that all the individual SV
 674 heads and bodies within the arenas must already have been freed.
 675
 676 =cut
 677 */
 678 void
 679 Perl_sv_free_arenas(pTHX)
 680 {
 681     dVAR;
 682     SV* sva;
 683     SV* svanext;
 684     unsigned int i;
 685
 686     /* Free arenas here, but be careful about fake ones.  (We assume
 687        contiguity of the fake ones with the corresponding real ones.) */
 688
 689     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 690         svanext = MUTABLE_SV(SvANY(sva));
 691         while (svanext && SvFAKE(svanext))
 692             svanext = MUTABLE_SV(SvANY(svanext));
 693
 694         if (!SvFAKE(sva))
 695             Safefree(sva);
 696     }
 697
 698     {
 699         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 700
 701         while (aroot) {
 702             struct arena_set *current = aroot;
 703             i = aroot->curr;
 704             while (i--) {
 705                 assert(aroot->set[i].arena);
 706                 Safefree(aroot->set[i].arena);
 707             }
 708             aroot = aroot->next;
 709             Safefree(current);
 710         }
 711     }
 712     PL_body_arenas = 0;
 713
 714     i = PERL_ARENA_ROOTS_SIZE;
 715     while (i--)
 716         PL_body_roots[i] = 0;
 717
 718     PL_sv_arenaroot = 0;
 719     PL_sv_root = 0;
 720 }
 721
 722 /*
 723   Here are mid-level routines that manage the allocation of bodies out
 724   of the various arenas.  There are 5 kinds of arenas:
 725
 726   1. SV-head arenas, which are discussed and handled above
 727   2. regular body arenas
 728   3. arenas for reduced-size bodies
 729   4. Hash-Entry arenas
 730
 731   Arena types 2 & 3 are chained by body-type off an array of
 732   arena-root pointers, which is indexed by svtype.  Some of the
 733   larger/less used body types are malloced singly, since a large
 734   unused block of them is wasteful.  Also, several svtypes dont have
 735   bodies; the data fits into the sv-head itself.  The arena-root
 736   pointer thus has a few unused root-pointers (which may be hijacked
 737   later for arena types 4,5)
 738
 739   3 differs from 2 as an optimization; some body types have several
 740   unused fields in the front of the structure (which are kept in-place
 741   for consistency).  These bodies can be allocated in smaller chunks,
 742   because the leading fields arent accessed.  Pointers to such bodies
 743   are decremented to point at the unused 'ghost' memory, knowing that
 744   the pointers are used with offsets to the real memory.
 745
 746
 747 =head1 SV-Body Allocation
 748
 749 Allocation of SV-bodies is similar to SV-heads, differing as follows;
 750 the allocation mechanism is used for many body types, so is somewhat
 751 more complicated, it uses arena-sets, and has no need for still-live
 752 SV detection.
 753
 754 At the outermost level, (new|del)_X*V macros return bodies of the
 755 appropriate type.  These macros call either (new|del)_body_type or
 756 (new|del)_body_allocated macro pairs, depending on specifics of the
 757 type.  Most body types use the former pair, the latter pair is used to
 758 allocate body types with "ghost fields".
 759
 760 "ghost fields" are fields that are unused in certain types, and
 761 consequently don't need to actually exist.  They are declared because
 762 they're part of a "base type", which allows use of functions as
 763 methods.  The simplest examples are AVs and HVs, 2 aggregate types
 764 which don't use the fields which support SCALAR semantics.
 765
 766 For these types, the arenas are carved up into appropriately sized
 767 chunks, we thus avoid wasted memory for those unaccessed members.
 768 When bodies are allocated, we adjust the pointer back in memory by the
 769 size of the part not allocated, so it's as if we allocated the full
 770 structure.  (But things will all go boom if you write to the part that
 771 is "not there", because you'll be overwriting the last members of the
 772 preceding structure in memory.)
 773
 774 We calculate the correction using the STRUCT_OFFSET macro on the first
 775 member present. If the allocated structure is smaller (no initial NV
 776 actually allocated) then the net effect is to subtract the size of the NV
 777 from the pointer, to return a new pointer as if an initial NV were actually
 778 allocated. (We were using structures named *_allocated for this, but
 779 this turned out to be a subtle bug, because a structure without an NV
 780 could have a lower alignment constraint, but the compiler is allowed to
 781 optimised accesses based on the alignment constraint of the actual pointer
 782 to the full structure, for example, using a single 64 bit load instruction
 783 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
 784
 785 This is the same trick as was used for NV and IV bodies. Ironically it
 786 doesn't need to be used for NV bodies any more, because NV is now at
 787 the start of the structure. IV bodies don't need it either, because
 788 they are no longer allocated.
 789
 790 In turn, the new_body_* allocators call S_new_body(), which invokes
 791 new_body_inline macro, which takes a lock, and takes a body off the
 792 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
 793 necessary to refresh an empty list.  Then the lock is released, and
 794 the body is returned.
 795
 796 Perl_more_bodies allocates a new arena, and carves it up into an array of N
 797 bodies, which it strings into a linked list.  It looks up arena-size
 798 and body-size from the body_details table described below, thus
 799 supporting the multiple body-types.
 800
 801 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
 802 the (new|del)_X*V macros are mapped directly to malloc/free.
 803
 804 For each sv-type, struct body_details bodies_by_type[] carries
 805 parameters which control these aspects of SV handling:
 806
 807 Arena_size determines whether arenas are used for this body type, and if
 808 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
 809 zero, forcing individual mallocs and frees.
 810
 811 Body_size determines how big a body is, and therefore how many fit into
 812 each arena.  Offset carries the body-pointer adjustment needed for
 813 "ghost fields", and is used in *_allocated macros.
 814
 815 But its main purpose is to parameterize info needed in
 816 Perl_sv_upgrade().  The info here dramatically simplifies the function
 817 vs the implementation in 5.8.8, making it table-driven.  All fields
 818 are used for this, except for arena_size.
 819
 820 For the sv-types that have no bodies, arenas are not used, so those
 821 PL_body_roots[sv_type] are unused, and can be overloaded.  In
 822 something of a special case, SVt_NULL is borrowed for HE arenas;
 823 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
 824 bodies_by_type[SVt_NULL] slot is not used, as the table is not
 825 available in hv.c.
 826
 827 */
 828
 829 struct body_details {
 830     U8 body_size;       /* Size to allocate  */
 831     U8 copy;            /* Size of structure to copy (may be shorter)  */
 832     U8 offset;
 833     unsigned int type : 4;          /* We have space for a sanity check.  */
 834     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
 835     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
 836     unsigned int arena : 1;         /* Allocated from an arena */
 837     size_t arena_size;              /* Size of arena to allocate */
 838 };
 839
 840 #define HADNV FALSE
 841 #define NONV TRUE
 842
 843
 844 #ifdef PURIFY
 845 /* With -DPURFIY we allocate everything directly, and don't use arenas.
 846    This seems a rather elegant way to simplify some of the code below.  */
 847 #define HASARENA FALSE
 848 #else
 849 #define HASARENA TRUE
 850 #endif
 851 #define NOARENA FALSE
 852
 853 /* Size the arenas to exactly fit a given number of bodies.  A count
 854    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
 855    simplifying the default.  If count > 0, the arena is sized to fit
 856    only that many bodies, allowing arenas to be used for large, rare
 857    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
 858    limited by PERL_ARENA_SIZE, so we can safely oversize the
 859    declarations.
 860  */
 861 #define FIT_ARENA0(body_size)                           \
 862     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
 863 #define FIT_ARENAn(count,body_size)                     \
 864     ( count * body_size <= PERL_ARENA_SIZE)             \
 865     ? count * body_size                                 \
 866     : FIT_ARENA0 (body_size)
 867 #define FIT_ARENA(count,body_size)                      \
 868     count                                               \
 869     ? FIT_ARENAn (count, body_size)                     \
 870     : FIT_ARENA0 (body_size)
 871
 872 /* Calculate the length to copy. Specifically work out the length less any
 873    final padding the compiler needed to add.  See the comment in sv_upgrade
 874    for why copying the padding proved to be a bug.  */
 875
 876 #define copy_length(type, last_member) \
 877         STRUCT_OFFSET(type, last_member) \
 878         + sizeof (((type*)SvANY((const SV *)0))->last_member)
 879
 880 static const struct body_details bodies_by_type[] = {
 881     /* HEs use this offset for their arena.  */
 882     { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
 883
 884     /* The bind placeholder pretends to be an RV for now.
 885        Also it's marked as "can't upgrade" to stop anyone using it before it's
 886        implemented.  */
 887     { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
 888
 889     /* IVs are in the head, so the allocation size is 0.  */
 890     { 0,
 891       sizeof(IV), /* This is used to copy out the IV body.  */
 892       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
 893       NOARENA /* IVS don't need an arena  */, 0
 894     },
 895
 896     { sizeof(NV), sizeof(NV),
 897       STRUCT_OFFSET(XPVNV, xnv_u),
 898       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
 899
 900     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
 901       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
 902       + STRUCT_OFFSET(XPV, xpv_cur),
 903       SVt_PV, FALSE, NONV, HASARENA,
 904       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 905
 906     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
 907       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 908       + STRUCT_OFFSET(XPV, xpv_cur),
 909       SVt_PVIV, FALSE, NONV, HASARENA,
 910       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 911
 912     { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
 913       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 914       + STRUCT_OFFSET(XPV, xpv_cur),
 915       SVt_PVNV, FALSE, HADNV, HASARENA,
 916       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 917
 918     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
 919       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 920
 921     { sizeof(regexp),
 922       sizeof(regexp),
 923       0,
 924       SVt_REGEXP, FALSE, NONV, HASARENA,
 925       FIT_ARENA(0, sizeof(regexp))
 926     },
 927
 928     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
 929       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
 930
 931     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
 932       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
 933
 934     { sizeof(XPVAV),
 935       copy_length(XPVAV, xav_alloc),
 936       0,
 937       SVt_PVAV, TRUE, NONV, HASARENA,
 938       FIT_ARENA(0, sizeof(XPVAV)) },
 939
 940     { sizeof(XPVHV),
 941       copy_length(XPVHV, xhv_max),
 942       0,
 943       SVt_PVHV, TRUE, NONV, HASARENA,
 944       FIT_ARENA(0, sizeof(XPVHV)) },
 945
 946     { sizeof(XPVCV),
 947       sizeof(XPVCV),
 948       0,
 949       SVt_PVCV, TRUE, NONV, HASARENA,
 950       FIT_ARENA(0, sizeof(XPVCV)) },
 951
 952     { sizeof(XPVFM),
 953       sizeof(XPVFM),
 954       0,
 955       SVt_PVFM, TRUE, NONV, NOARENA,
 956       FIT_ARENA(20, sizeof(XPVFM)) },
 957
 958     { sizeof(XPVIO),
 959       sizeof(XPVIO),
 960       0,
 961       SVt_PVIO, TRUE, NONV, HASARENA,
 962       FIT_ARENA(24, sizeof(XPVIO)) },
 963 };
 964
 965 #define new_body_allocated(sv_type)             \
 966     (void *)((char *)S_new_body(aTHX_ sv_type)  \
 967              - bodies_by_type[sv_type].offset)
 968
 969 /* return a thing to the free list */
 970
 971 #define del_body(thing, root)                           \
 972     STMT_START {                                        \
 973         void ** const thing_copy = (void **)thing;      \
 974         *thing_copy = *root;                            \
 975         *root = (void*)thing_copy;                      \
 976     } STMT_END
 977
 978 #ifdef PURIFY
 979
 980 #define new_XNV()       safemalloc(sizeof(XPVNV))
 981 #define new_XPVNV()     safemalloc(sizeof(XPVNV))
 982 #define new_XPVMG()     safemalloc(sizeof(XPVMG))
 983
 984 #define del_XPVGV(p)    safefree(p)
 985
 986 #else /* !PURIFY */
 987
 988 #define new_XNV()       new_body_allocated(SVt_NV)
 989 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
 990 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
 991
 992 #define del_XPVGV(p)    del_body(p + bodies_by_type[SVt_PVGV].offset,   \
 993                                  &PL_body_roots[SVt_PVGV])
 994
 995 #endif /* PURIFY */
 996
 997 /* no arena for you! */
 998
 999 #define new_NOARENA(details) \
1000         safemalloc((details)->body_size + (details)->offset)
1001 #define new_NOARENAZ(details) \
1002         safecalloc((details)->body_size + (details)->offset, 1)
1003
1004 void *
1005 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1006                   const size_t arena_size)
1007 {
1008     dVAR;
1009     void ** const root = &PL_body_roots[sv_type];
1010     struct arena_desc *adesc;
1011     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1012     unsigned int curr;
1013     char *start;
1014     const char *end;
1015     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1016 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1017     static bool done_sanity_check;
1018
1019     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1020      * variables like done_sanity_check. */
1021     if (!done_sanity_check) {
1022         unsigned int i = SVt_LAST;
1023
1024         done_sanity_check = TRUE;
1025
1026         while (i--)
1027             assert (bodies_by_type[i].type == i);
1028     }
1029 #endif
1030
1031     assert(arena_size);
1032
1033     /* may need new arena-set to hold new arena */
1034     if (!aroot || aroot->curr >= aroot->set_size) {
1035         struct arena_set *newroot;
1036         Newxz(newroot, 1, struct arena_set);
1037         newroot->set_size = ARENAS_PER_SET;
1038         newroot->next = aroot;
1039         aroot = newroot;
1040         PL_body_arenas = (void *) newroot;
1041         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1042     }
1043
1044     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1045     curr = aroot->curr++;
1046     adesc = &(aroot->set[curr]);
1047     assert(!adesc->arena);
1048
1049     Newx(adesc->arena, good_arena_size, char);
1050     adesc->size = good_arena_size;
1051     adesc->utype = sv_type;
1052     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1053                           curr, (void*)adesc->arena, (UV)good_arena_size));
1054
1055     start = (char *) adesc->arena;
1056
1057     /* Get the address of the byte after the end of the last body we can fit.
1058        Remember, this is integer division:  */
1059     end = start + good_arena_size / body_size * body_size;
1060
1061     /* computed count doesn't reflect the 1st slot reservation */
1062 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1063     DEBUG_m(PerlIO_printf(Perl_debug_log,
1064                           "arena %p end %p arena-size %d (from %d) type %d "
1065                           "size %d ct %d\n",
1066                           (void*)start, (void*)end, (int)good_arena_size,
1067                           (int)arena_size, sv_type, (int)body_size,
1068                           (int)good_arena_size / (int)body_size));
1069 #else
1070     DEBUG_m(PerlIO_printf(Perl_debug_log,
1071                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1072                           (void*)start, (void*)end,
1073                           (int)arena_size, sv_type, (int)body_size,
1074                           (int)good_arena_size / (int)body_size));
1075 #endif
1076     *root = (void *)start;
1077
1078     while (1) {
1079         /* Where the next body would start:  */
1080         char * const next = start + body_size;
1081
1082         if (next >= end) {
1083             /* This is the last body:  */
1084             assert(next == end);
1085
1086             *(void **)start = 0;
1087             return *root;
1088         }
1089
1090         *(void**) start = (void *)next;
1091         start = next;
1092     }
1093 }
1094
1095 /* grab a new thing from the free list, allocating more if necessary.
1096    The inline version is used for speed in hot routines, and the
1097    function using it serves the rest (unless PURIFY).
1098 */
1099 #define new_body_inline(xpv, sv_type) \
1100     STMT_START { \
1101         void ** const r3wt = &PL_body_roots[sv_type]; \
1102         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1103           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1104                                              bodies_by_type[sv_type].body_size,\
1105                                              bodies_by_type[sv_type].arena_size)); \
1106         *(r3wt) = *(void**)(xpv); \
1107     } STMT_END
1108
1109 #ifndef PURIFY
1110
1111 STATIC void *
1112 S_new_body(pTHX_ const svtype sv_type)
1113 {
1114     dVAR;
1115     void *xpv;
1116     new_body_inline(xpv, sv_type);
1117     return xpv;
1118 }
1119
1120 #endif
1121
1122 static const struct body_details fake_rv =
1123     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1124
1125 /*
1126 =for apidoc sv_upgrade
1127
1128 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1129 SV, then copies across as much information as possible from the old body.
1130 It croaks if the SV is already in a more complex form than requested.  You
1131 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1132 before calling C<sv_upgrade>, and hence does not croak.  See also
1133 C<svtype>.
1134
1135 =cut
1136 */
1137
1138 void
1139 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1140 {
1141     dVAR;
1142     void*       old_body;
1143     void*       new_body;
1144     const svtype old_type = SvTYPE(sv);
1145     const struct body_details *new_type_details;
1146     const struct body_details *old_type_details
1147         = bodies_by_type + old_type;
1148     SV *referant = NULL;
1149
1150     PERL_ARGS_ASSERT_SV_UPGRADE;
1151
1152     if (old_type == new_type)
1153         return;
1154
1155     /* This clause was purposefully added ahead of the early return above to
1156        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1157        inference by Nick I-S that it would fix other troublesome cases. See
1158        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1159
1160        Given that shared hash key scalars are no longer PVIV, but PV, there is
1161        no longer need to unshare so as to free up the IVX slot for its proper
1162        purpose. So it's safe to move the early return earlier.  */
1163
1164     if (new_type != SVt_PV && SvIsCOW(sv)) {
1165         sv_force_normal_flags(sv, 0);
1166     }
1167
1168     old_body = SvANY(sv);
1169
1170     /* Copying structures onto other structures that have been neatly zeroed
1171        has a subtle gotcha. Consider XPVMG
1172
1173        +------+------+------+------+------+-------+-------+
1174        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1175        +------+------+------+------+------+-------+-------+
1176        0      4      8     12     16     20      24      28
1177
1178        where NVs are aligned to 8 bytes, so that sizeof that structure is
1179        actually 32 bytes long, with 4 bytes of padding at the end:
1180
1181        +------+------+------+------+------+-------+-------+------+
1182        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1183        +------+------+------+------+------+-------+-------+------+
1184        0      4      8     12     16     20      24      28     32
1185
1186        so what happens if you allocate memory for this structure:
1187
1188        +------+------+------+------+------+-------+-------+------+------+...
1189        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1190        +------+------+------+------+------+-------+-------+------+------+...
1191        0      4      8     12     16     20      24      28     32     36
1192
1193        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1194        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1195        started out as zero once, but it's quite possible that it isn't. So now,
1196        rather than a nicely zeroed GP, you have it pointing somewhere random.
1197        Bugs ensue.
1198
1199        (In fact, GP ends up pointing at a previous GP structure, because the
1200        principle cause of the padding in XPVMG getting garbage is a copy of
1201        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1202        this happens to be moot because XPVGV has been re-ordered, with GP
1203        no longer after STASH)
1204
1205        So we are careful and work out the size of used parts of all the
1206        structures.  */
1207
1208     switch (old_type) {
1209     case SVt_NULL:
1210         break;
1211     case SVt_IV:
1212         if (SvROK(sv)) {
1213             referant = SvRV(sv);
1214             old_type_details = &fake_rv;
1215             if (new_type == SVt_NV)
1216                 new_type = SVt_PVNV;
1217         } else {
1218             if (new_type < SVt_PVIV) {
1219                 new_type = (new_type == SVt_NV)
1220                     ? SVt_PVNV : SVt_PVIV;
1221             }
1222         }
1223         break;
1224     case SVt_NV:
1225         if (new_type < SVt_PVNV) {
1226             new_type = SVt_PVNV;
1227         }
1228         break;
1229     case SVt_PV:
1230         assert(new_type > SVt_PV);
1231         assert(SVt_IV < SVt_PV);
1232         assert(SVt_NV < SVt_PV);
1233         break;
1234     case SVt_PVIV:
1235         break;
1236     case SVt_PVNV:
1237         break;
1238     case SVt_PVMG:
1239         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1240            there's no way that it can be safely upgraded, because perl.c
1241            expects to Safefree(SvANY(PL_mess_sv))  */
1242         assert(sv != PL_mess_sv);
1243         /* This flag bit is used to mean other things in other scalar types.
1244            Given that it only has meaning inside the pad, it shouldn't be set
1245            on anything that can get upgraded.  */
1246         assert(!SvPAD_TYPED(sv));
1247         break;
1248     default:
1249         if (old_type_details->cant_upgrade)
1250             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1251                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1252     }
1253
1254     if (old_type > new_type)
1255         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1256                 (int)old_type, (int)new_type);
1257
1258     new_type_details = bodies_by_type + new_type;
1259
1260     SvFLAGS(sv) &= ~SVTYPEMASK;
1261     SvFLAGS(sv) |= new_type;
1262
1263     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1264        the return statements above will have triggered.  */
1265     assert (new_type != SVt_NULL);
1266     switch (new_type) {
1267     case SVt_IV:
1268         assert(old_type == SVt_NULL);
1269         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1270         SvIV_set(sv, 0);
1271         return;
1272     case SVt_NV:
1273         assert(old_type == SVt_NULL);
1274         SvANY(sv) = new_XNV();
1275         SvNV_set(sv, 0);
1276         return;
1277     case SVt_PVHV:
1278     case SVt_PVAV:
1279         assert(new_type_details->body_size);
1280
1281 #ifndef PURIFY
1282         assert(new_type_details->arena);
1283         assert(new_type_details->arena_size);
1284         /* This points to the start of the allocated area.  */
1285         new_body_inline(new_body, new_type);
1286         Zero(new_body, new_type_details->body_size, char);
1287         new_body = ((char *)new_body) - new_type_details->offset;
1288 #else
1289         /* We always allocated the full length item with PURIFY. To do this
1290            we fake things so that arena is false for all 16 types..  */
1291         new_body = new_NOARENAZ(new_type_details);
1292 #endif
1293         SvANY(sv) = new_body;
1294         if (new_type == SVt_PVAV) {
1295             AvMAX(sv)   = -1;
1296             AvFILLp(sv) = -1;
1297             AvREAL_only(sv);
1298             if (old_type_details->body_size) {
1299                 AvALLOC(sv) = 0;
1300             } else {
1301                 /* It will have been zeroed when the new body was allocated.
1302                    Lets not write to it, in case it confuses a write-back
1303                    cache.  */
1304             }
1305         } else {
1306             assert(!SvOK(sv));
1307             SvOK_off(sv);
1308 #ifndef NODEFAULT_SHAREKEYS
1309             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1310 #endif
1311             HvMAX(sv) = 7; /* (start with 8 buckets) */
1312         }
1313
1314         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1315            The target created by newSVrv also is, and it can have magic.
1316            However, it never has SvPVX set.
1317         */
1318         if (old_type == SVt_IV) {
1319             assert(!SvROK(sv));
1320         } else if (old_type >= SVt_PV) {
1321             assert(SvPVX_const(sv) == 0);
1322         }
1323
1324         if (old_type >= SVt_PVMG) {
1325             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1326             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1327         } else {
1328             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1329         }
1330         break;
1331
1332
1333     case SVt_REGEXP:
1334         /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1335            sv_force_normal_flags(sv) is called.  */
1336         SvFAKE_on(sv);
1337     case SVt_PVIV:
1338         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1339            no route from NV to PVIV, NOK can never be true  */
1340         assert(!SvNOKp(sv));
1341         assert(!SvNOK(sv));
1342     case SVt_PVIO:
1343     case SVt_PVFM:
1344     case SVt_PVGV:
1345     case SVt_PVCV:
1346     case SVt_PVLV:
1347     case SVt_PVMG:
1348     case SVt_PVNV:
1349     case SVt_PV:
1350
1351         assert(new_type_details->body_size);
1352         /* We always allocated the full length item with PURIFY. To do this
1353            we fake things so that arena is false for all 16 types..  */
1354         if(new_type_details->arena) {
1355             /* This points to the start of the allocated area.  */
1356             new_body_inline(new_body, new_type);
1357             Zero(new_body, new_type_details->body_size, char);
1358             new_body = ((char *)new_body) - new_type_details->offset;
1359         } else {
1360             new_body = new_NOARENAZ(new_type_details);
1361         }
1362         SvANY(sv) = new_body;
1363
1364         if (old_type_details->copy) {
1365             /* There is now the potential for an upgrade from something without
1366                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1367             int offset = old_type_details->offset;
1368             int length = old_type_details->copy;
1369
1370             if (new_type_details->offset > old_type_details->offset) {
1371                 const int difference
1372                     = new_type_details->offset - old_type_details->offset;
1373                 offset += difference;
1374                 length -= difference;
1375             }
1376             assert (length >= 0);
1377
1378             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1379                  char);
1380         }
1381
1382 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1383         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1384          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1385          * NV slot, but the new one does, then we need to initialise the
1386          * freshly created NV slot with whatever the correct bit pattern is
1387          * for 0.0  */
1388         if (old_type_details->zero_nv && !new_type_details->zero_nv
1389             && !isGV_with_GP(sv))
1390             SvNV_set(sv, 0);
1391 #endif
1392
1393         if (new_type == SVt_PVIO) {
1394             IO * const io = MUTABLE_IO(sv);
1395             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1396
1397             SvOBJECT_on(io);
1398             /* Clear the stashcache because a new IO could overrule a package
1399                name */
1400             hv_clear(PL_stashcache);
1401
1402             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1403             IoPAGE_LEN(sv) = 60;
1404         }
1405         if (old_type < SVt_PV) {
1406             /* referant will be NULL unless the old type was SVt_IV emulating
1407                SVt_RV */
1408             sv->sv_u.svu_rv = referant;
1409         }
1410         break;
1411     default:
1412         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1413                    (unsigned long)new_type);
1414     }
1415
1416     if (old_type > SVt_IV) {
1417 #ifdef PURIFY
1418         safefree(old_body);
1419 #else
1420         /* Note that there is an assumption that all bodies of types that
1421            can be upgraded came from arenas. Only the more complex non-
1422            upgradable types are allowed to be directly malloc()ed.  */
1423         assert(old_type_details->arena);
1424         del_body((void*)((char*)old_body + old_type_details->offset),
1425                  &PL_body_roots[old_type]);
1426 #endif
1427     }
1428 }
1429
1430 /*
1431 =for apidoc sv_backoff
1432
1433 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1434 wrapper instead.
1435
1436 =cut
1437 */
1438
1439 int
1440 Perl_sv_backoff(pTHX_ register SV *const sv)
1441 {
1442     STRLEN delta;
1443     const char * const s = SvPVX_const(sv);
1444
1445     PERL_ARGS_ASSERT_SV_BACKOFF;
1446     PERL_UNUSED_CONTEXT;
1447
1448     assert(SvOOK(sv));
1449     assert(SvTYPE(sv) != SVt_PVHV);
1450     assert(SvTYPE(sv) != SVt_PVAV);
1451
1452     SvOOK_offset(sv, delta);
1453
1454     SvLEN_set(sv, SvLEN(sv) + delta);
1455     SvPV_set(sv, SvPVX(sv) - delta);
1456     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1457     SvFLAGS(sv) &= ~SVf_OOK;
1458     return 0;
1459 }
1460
1461 /*
1462 =for apidoc sv_grow
1463
1464 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1465 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1466 Use the C<SvGROW> wrapper instead.
1467
1468 =cut
1469 */
1470
1471 char *
1472 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1473 {
1474     register char *s;
1475
1476     PERL_ARGS_ASSERT_SV_GROW;
1477
1478     if (PL_madskills && newlen >= 0x100000) {
1479         PerlIO_printf(Perl_debug_log,
1480                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1481     }
1482 #ifdef HAS_64K_LIMIT
1483     if (newlen >= 0x10000) {
1484         PerlIO_printf(Perl_debug_log,
1485                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1486         my_exit(1);
1487     }
1488 #endif /* HAS_64K_LIMIT */
1489     if (SvROK(sv))
1490         sv_unref(sv);
1491     if (SvTYPE(sv) < SVt_PV) {
1492         sv_upgrade(sv, SVt_PV);
1493         s = SvPVX_mutable(sv);
1494     }
1495     else if (SvOOK(sv)) {       /* pv is offset? */
1496         sv_backoff(sv);
1497         s = SvPVX_mutable(sv);
1498         if (newlen > SvLEN(sv))
1499             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1500 #ifdef HAS_64K_LIMIT
1501         if (newlen >= 0x10000)
1502             newlen = 0xFFFF;
1503 #endif
1504     }
1505     else
1506         s = SvPVX_mutable(sv);
1507
1508     if (newlen > SvLEN(sv)) {           /* need more room? */
1509         STRLEN minlen = SvCUR(sv);
1510         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1511         if (newlen < minlen)
1512             newlen = minlen;
1513 #ifndef Perl_safesysmalloc_size
1514         newlen = PERL_STRLEN_ROUNDUP(newlen);
1515 #endif
1516         if (SvLEN(sv) && s) {
1517             s = (char*)saferealloc(s, newlen);
1518         }
1519         else {
1520             s = (char*)safemalloc(newlen);
1521             if (SvPVX_const(sv) && SvCUR(sv)) {
1522                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1523             }
1524         }
1525         SvPV_set(sv, s);
1526 #ifdef Perl_safesysmalloc_size
1527         /* Do this here, do it once, do it right, and then we will never get
1528            called back into sv_grow() unless there really is some growing
1529            needed.  */
1530         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1531 #else
1532         SvLEN_set(sv, newlen);
1533 #endif
1534     }
1535     return s;
1536 }
1537
1538 /*
1539 =for apidoc sv_setiv
1540
1541 Copies an integer into the given SV, upgrading first if necessary.
1542 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1543
1544 =cut
1545 */
1546
1547 void
1548 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1549 {
1550     dVAR;
1551
1552     PERL_ARGS_ASSERT_SV_SETIV;
1553
1554     SV_CHECK_THINKFIRST_COW_DROP(sv);
1555     switch (SvTYPE(sv)) {
1556     case SVt_NULL:
1557     case SVt_NV:
1558         sv_upgrade(sv, SVt_IV);
1559         break;
1560     case SVt_PV:
1561         sv_upgrade(sv, SVt_PVIV);
1562         break;
1563
1564     case SVt_PVGV:
1565         if (!isGV_with_GP(sv))
1566             break;
1567     case SVt_PVAV:
1568     case SVt_PVHV:
1569     case SVt_PVCV:
1570     case SVt_PVFM:
1571     case SVt_PVIO:
1572         /* diag_listed_as: Can't coerce %s to %s in %s */
1573         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1574                    OP_DESC(PL_op));
1575     default: NOOP;
1576     }
1577     (void)SvIOK_only(sv);                       /* validate number */
1578     SvIV_set(sv, i);
1579     SvTAINT(sv);
1580 }
1581
1582 /*
1583 =for apidoc sv_setiv_mg
1584
1585 Like C<sv_setiv>, but also handles 'set' magic.
1586
1587 =cut
1588 */
1589
1590 void
1591 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1592 {
1593     PERL_ARGS_ASSERT_SV_SETIV_MG;
1594
1595     sv_setiv(sv,i);
1596     SvSETMAGIC(sv);
1597 }
1598
1599 /*
1600 =for apidoc sv_setuv
1601
1602 Copies an unsigned integer into the given SV, upgrading first if necessary.
1603 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1604
1605 =cut
1606 */
1607
1608 void
1609 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1610 {
1611     PERL_ARGS_ASSERT_SV_SETUV;
1612
1613     /* With the if statement to ensure that integers are stored as IVs whenever
1614        possible:
1615        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1616
1617        without
1618        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1619
1620        If you wish to remove the following if statement, so that this routine
1621        (and its callers) always return UVs, please benchmark to see what the
1622        effect is. Modern CPUs may be different. Or may not :-)
1623     */
1624     if (u <= (UV)IV_MAX) {
1625        sv_setiv(sv, (IV)u);
1626        return;
1627     }
1628     sv_setiv(sv, 0);
1629     SvIsUV_on(sv);
1630     SvUV_set(sv, u);
1631 }
1632
1633 /*
1634 =for apidoc sv_setuv_mg
1635
1636 Like C<sv_setuv>, but also handles 'set' magic.
1637
1638 =cut
1639 */
1640
1641 void
1642 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1643 {
1644     PERL_ARGS_ASSERT_SV_SETUV_MG;
1645
1646     sv_setuv(sv,u);
1647     SvSETMAGIC(sv);
1648 }
1649
1650 /*
1651 =for apidoc sv_setnv
1652
1653 Copies a double into the given SV, upgrading first if necessary.
1654 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1655
1656 =cut
1657 */
1658
1659 void
1660 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1661 {
1662     dVAR;
1663
1664     PERL_ARGS_ASSERT_SV_SETNV;
1665
1666     SV_CHECK_THINKFIRST_COW_DROP(sv);
1667     switch (SvTYPE(sv)) {
1668     case SVt_NULL:
1669     case SVt_IV:
1670         sv_upgrade(sv, SVt_NV);
1671         break;
1672     case SVt_PV:
1673     case SVt_PVIV:
1674         sv_upgrade(sv, SVt_PVNV);
1675         break;
1676
1677     case SVt_PVGV:
1678         if (!isGV_with_GP(sv))
1679             break;
1680     case SVt_PVAV:
1681     case SVt_PVHV:
1682     case SVt_PVCV:
1683     case SVt_PVFM:
1684     case SVt_PVIO:
1685         /* diag_listed_as: Can't coerce %s to %s in %s */
1686         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1687                    OP_DESC(PL_op));
1688     default: NOOP;
1689     }
1690     SvNV_set(sv, num);
1691     (void)SvNOK_only(sv);                       /* validate number */
1692     SvTAINT(sv);
1693 }
1694
1695 /*
1696 =for apidoc sv_setnv_mg
1697
1698 Like C<sv_setnv>, but also handles 'set' magic.
1699
1700 =cut
1701 */
1702
1703 void
1704 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1705 {
1706     PERL_ARGS_ASSERT_SV_SETNV_MG;
1707
1708     sv_setnv(sv,num);
1709     SvSETMAGIC(sv);
1710 }
1711
1712 /* Print an "isn't numeric" warning, using a cleaned-up,
1713  * printable version of the offending string
1714  */
1715
1716 STATIC void
1717 S_not_a_number(pTHX_ SV *const sv)
1718 {
1719      dVAR;
1720      SV *dsv;
1721      char tmpbuf[64];
1722      const char *pv;
1723
1724      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1725
1726      if (DO_UTF8(sv)) {
1727           dsv = newSVpvs_flags("", SVs_TEMP);
1728           pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1729      } else {
1730           char *d = tmpbuf;
1731           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1732           /* each *s can expand to 4 chars + "...\0",
1733              i.e. need room for 8 chars */
1734
1735           const char *s = SvPVX_const(sv);
1736           const char * const end = s + SvCUR(sv);
1737           for ( ; s < end && d < limit; s++ ) {
1738                int ch = *s & 0xFF;
1739                if (ch & 128 && !isPRINT_LC(ch)) {
1740                     *d++ = 'M';
1741                     *d++ = '-';
1742                     ch &= 127;
1743                }
1744                if (ch == '\n') {
1745                     *d++ = '\\';
1746                     *d++ = 'n';
1747                }
1748                else if (ch == '\r') {
1749                     *d++ = '\\';
1750                     *d++ = 'r';
1751                }
1752                else if (ch == '\f') {
1753                     *d++ = '\\';
1754                     *d++ = 'f';
1755                }
1756                else if (ch == '\\') {
1757                     *d++ = '\\';
1758                     *d++ = '\\';
1759                }
1760                else if (ch == '\0') {
1761                     *d++ = '\\';
1762                     *d++ = '0';
1763                }
1764                else if (isPRINT_LC(ch))
1765                     *d++ = ch;
1766                else {
1767                     *d++ = '^';
1768                     *d++ = toCTRL(ch);
1769                }
1770           }
1771           if (s < end) {
1772                *d++ = '.';
1773                *d++ = '.';
1774                *d++ = '.';
1775           }
1776           *d = '\0';
1777           pv = tmpbuf;
1778     }
1779
1780     if (PL_op)
1781         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1782                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1783                     "Argument \"%s\" isn't numeric in %s", pv,
1784                     OP_DESC(PL_op));
1785     else
1786         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1787                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1788                     "Argument \"%s\" isn't numeric", pv);
1789 }
1790
1791 /*
1792 =for apidoc looks_like_number
1793
1794 Test if the content of an SV looks like a number (or is a number).
1795 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1796 non-numeric warning), even if your atof() doesn't grok them.  Get-magic is
1797 ignored.
1798
1799 =cut
1800 */
1801
1802 I32
1803 Perl_looks_like_number(pTHX_ SV *const sv)
1804 {
1805     register const char *sbegin;
1806     STRLEN len;
1807
1808     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1809
1810     if (SvPOK(sv) || SvPOKp(sv)) {
1811         sbegin = SvPV_nomg_const(sv, len);
1812     }
1813     else
1814         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1815     return grok_number(sbegin, len, NULL);
1816 }
1817
1818 STATIC bool
1819 S_glob_2number(pTHX_ GV * const gv)
1820 {
1821     SV *const buffer = sv_newmortal();
1822
1823     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1824
1825     gv_efullname3(buffer, gv, "*");
1826
1827     /* We know that all GVs stringify to something that is not-a-number,
1828         so no need to test that.  */
1829     if (ckWARN(WARN_NUMERIC))
1830         not_a_number(buffer);
1831     /* We just want something true to return, so that S_sv_2iuv_common
1832         can tail call us and return true.  */
1833     return TRUE;
1834 }
1835
1836 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1837    until proven guilty, assume that things are not that bad... */
1838
1839 /*
1840    NV_PRESERVES_UV:
1841
1842    As 64 bit platforms often have an NV that doesn't preserve all bits of
1843    an IV (an assumption perl has been based on to date) it becomes necessary
1844    to remove the assumption that the NV always carries enough precision to
1845    recreate the IV whenever needed, and that the NV is the canonical form.
1846    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1847    precision as a side effect of conversion (which would lead to insanity
1848    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1849    1) to distinguish between IV/UV/NV slots that have cached a valid
1850       conversion where precision was lost and IV/UV/NV slots that have a
1851       valid conversion which has lost no precision
1852    2) to ensure that if a numeric conversion to one form is requested that
1853       would lose precision, the precise conversion (or differently
1854       imprecise conversion) is also performed and cached, to prevent
1855       requests for different numeric formats on the same SV causing
1856       lossy conversion chains. (lossless conversion chains are perfectly
1857       acceptable (still))
1858
1859
1860    flags are used:
1861    SvIOKp is true if the IV slot contains a valid value
1862    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1863    SvNOKp is true if the NV slot contains a valid value
1864    SvNOK  is true only if the NV value is accurate
1865
1866    so
1867    while converting from PV to NV, check to see if converting that NV to an
1868    IV(or UV) would lose accuracy over a direct conversion from PV to
1869    IV(or UV). If it would, cache both conversions, return NV, but mark
1870    SV as IOK NOKp (ie not NOK).
1871
1872    While converting from PV to IV, check to see if converting that IV to an
1873    NV would lose accuracy over a direct conversion from PV to NV. If it
1874    would, cache both conversions, flag similarly.
1875
1876    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1877    correctly because if IV & NV were set NV *always* overruled.
1878    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1879    changes - now IV and NV together means that the two are interchangeable:
1880    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1881
1882    The benefit of this is that operations such as pp_add know that if
1883    SvIOK is true for both left and right operands, then integer addition
1884    can be used instead of floating point (for cases where the result won't
1885    overflow). Before, floating point was always used, which could lead to
1886    loss of precision compared with integer addition.
1887
1888    * making IV and NV equal status should make maths accurate on 64 bit
1889      platforms
1890    * may speed up maths somewhat if pp_add and friends start to use
1891      integers when possible instead of fp. (Hopefully the overhead in
1892      looking for SvIOK and checking for overflow will not outweigh the
1893      fp to integer speedup)
1894    * will slow down integer operations (callers of SvIV) on "inaccurate"
1895      values, as the change from SvIOK to SvIOKp will cause a call into
1896      sv_2iv each time rather than a macro access direct to the IV slot
1897    * should speed up number->string conversion on integers as IV is
1898      favoured when IV and NV are equally accurate
1899
1900    ####################################################################
1901    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1902    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1903    On the other hand, SvUOK is true iff UV.
1904    ####################################################################
1905
1906    Your mileage will vary depending your CPU's relative fp to integer
1907    performance ratio.
1908 */
1909
1910 #ifndef NV_PRESERVES_UV
1911 #  define IS_NUMBER_UNDERFLOW_IV 1
1912 #  define IS_NUMBER_UNDERFLOW_UV 2
1913 #  define IS_NUMBER_IV_AND_UV    2
1914 #  define IS_NUMBER_OVERFLOW_IV  4
1915 #  define IS_NUMBER_OVERFLOW_UV  5
1916
1917 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1918
1919 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1920 STATIC int
1921 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1922 #  ifdef DEBUGGING
1923                        , I32 numtype
1924 #  endif
1925                        )
1926 {
1927     dVAR;
1928
1929     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1930
1931     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1932     if (SvNVX(sv) < (NV)IV_MIN) {
1933         (void)SvIOKp_on(sv);
1934         (void)SvNOK_on(sv);
1935         SvIV_set(sv, IV_MIN);
1936         return IS_NUMBER_UNDERFLOW_IV;
1937     }
1938     if (SvNVX(sv) > (NV)UV_MAX) {
1939         (void)SvIOKp_on(sv);
1940         (void)SvNOK_on(sv);
1941         SvIsUV_on(sv);
1942         SvUV_set(sv, UV_MAX);
1943         return IS_NUMBER_OVERFLOW_UV;
1944     }
1945     (void)SvIOKp_on(sv);
1946     (void)SvNOK_on(sv);
1947     /* Can't use strtol etc to convert this string.  (See truth table in
1948        sv_2iv  */
1949     if (SvNVX(sv) <= (UV)IV_MAX) {
1950         SvIV_set(sv, I_V(SvNVX(sv)));
1951         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1952             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1953         } else {
1954             /* Integer is imprecise. NOK, IOKp */
1955         }
1956         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1957     }
1958     SvIsUV_on(sv);
1959     SvUV_set(sv, U_V(SvNVX(sv)));
1960     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1961         if (SvUVX(sv) == UV_MAX) {
1962             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1963                possibly be preserved by NV. Hence, it must be overflow.
1964                NOK, IOKp */
1965             return IS_NUMBER_OVERFLOW_UV;
1966         }
1967         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1968     } else {
1969         /* Integer is imprecise. NOK, IOKp */
1970     }
1971     return IS_NUMBER_OVERFLOW_IV;
1972 }
1973 #endif /* !NV_PRESERVES_UV*/
1974
1975 STATIC bool
1976 S_sv_2iuv_common(pTHX_ SV *const sv)
1977 {
1978     dVAR;
1979
1980     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1981
1982     if (SvNOKp(sv)) {
1983         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1984          * without also getting a cached IV/UV from it at the same time
1985          * (ie PV->NV conversion should detect loss of accuracy and cache
1986          * IV or UV at same time to avoid this. */
1987         /* IV-over-UV optimisation - choose to cache IV if possible */
1988
1989         if (SvTYPE(sv) == SVt_NV)
1990             sv_upgrade(sv, SVt_PVNV);
1991
1992         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1993         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1994            certainly cast into the IV range at IV_MAX, whereas the correct
1995            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1996            cases go to UV */
1997 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1998         if (Perl_isnan(SvNVX(sv))) {
1999             SvUV_set(sv, 0);
2000             SvIsUV_on(sv);
2001             return FALSE;
2002         }
2003 #endif
2004         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2005             SvIV_set(sv, I_V(SvNVX(sv)));
2006             if (SvNVX(sv) == (NV) SvIVX(sv)
2007 #ifndef NV_PRESERVES_UV
2008                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2009                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2010                 /* Don't flag it as "accurately an integer" if the number
2011                    came from a (by definition imprecise) NV operation, and
2012                    we're outside the range of NV integer precision */
2013 #endif
2014                 ) {
2015                 if (SvNOK(sv))
2016                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2017                 else {
2018                     /* scalar has trailing garbage, eg "42a" */
2019                 }
2020                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2021                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2022                                       PTR2UV(sv),
2023                                       SvNVX(sv),
2024                                       SvIVX(sv)));
2025
2026             } else {
2027                 /* IV not precise.  No need to convert from PV, as NV
2028                    conversion would already have cached IV if it detected
2029                    that PV->IV would be better than PV->NV->IV
2030                    flags already correct - don't set public IOK.  */
2031                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2032                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2033                                       PTR2UV(sv),
2034                                       SvNVX(sv),
2035                                       SvIVX(sv)));
2036             }
2037             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2038                but the cast (NV)IV_MIN rounds to a the value less (more
2039                negative) than IV_MIN which happens to be equal to SvNVX ??
2040                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2041                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2042                (NV)UVX == NVX are both true, but the values differ. :-(
2043                Hopefully for 2s complement IV_MIN is something like
2044                0x8000000000000000 which will be exact. NWC */
2045         }
2046         else {
2047             SvUV_set(sv, U_V(SvNVX(sv)));
2048             if (
2049                 (SvNVX(sv) == (NV) SvUVX(sv))
2050 #ifndef  NV_PRESERVES_UV
2051                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2052                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2053                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2054                 /* Don't flag it as "accurately an integer" if the number
2055                    came from a (by definition imprecise) NV operation, and
2056                    we're outside the range of NV integer precision */
2057 #endif
2058                 && SvNOK(sv)
2059                 )
2060                 SvIOK_on(sv);
2061             SvIsUV_on(sv);
2062             DEBUG_c(PerlIO_printf(Perl_debug_log,
2063                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2064                                   PTR2UV(sv),
2065                                   SvUVX(sv),
2066                                   SvUVX(sv)));
2067         }
2068     }
2069     else if (SvPOKp(sv) && SvLEN(sv)) {
2070         UV value;
2071         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2072         /* We want to avoid a possible problem when we cache an IV/ a UV which
2073            may be later translated to an NV, and the resulting NV is not
2074            the same as the direct translation of the initial string
2075            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2076            be careful to ensure that the value with the .456 is around if the
2077            NV value is requested in the future).
2078
2079            This means that if we cache such an IV/a UV, we need to cache the
2080            NV as well.  Moreover, we trade speed for space, and do not
2081            cache the NV if we are sure it's not needed.
2082          */
2083
2084         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2085         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2086              == IS_NUMBER_IN_UV) {
2087             /* It's definitely an integer, only upgrade to PVIV */
2088             if (SvTYPE(sv) < SVt_PVIV)
2089                 sv_upgrade(sv, SVt_PVIV);
2090             (void)SvIOK_on(sv);
2091         } else if (SvTYPE(sv) < SVt_PVNV)
2092             sv_upgrade(sv, SVt_PVNV);
2093
2094         /* If NVs preserve UVs then we only use the UV value if we know that
2095            we aren't going to call atof() below. If NVs don't preserve UVs
2096            then the value returned may have more precision than atof() will
2097            return, even though value isn't perfectly accurate.  */
2098         if ((numtype & (IS_NUMBER_IN_UV
2099 #ifdef NV_PRESERVES_UV
2100                         | IS_NUMBER_NOT_INT
2101 #endif
2102             )) == IS_NUMBER_IN_UV) {
2103             /* This won't turn off the public IOK flag if it was set above  */
2104             (void)SvIOKp_on(sv);
2105
2106             if (!(numtype & IS_NUMBER_NEG)) {
2107                 /* positive */;
2108                 if (value <= (UV)IV_MAX) {
2109                     SvIV_set(sv, (IV)value);
2110                 } else {
2111                     /* it didn't overflow, and it was positive. */
2112                     SvUV_set(sv, value);
2113                     SvIsUV_on(sv);
2114                 }
2115             } else {
2116                 /* 2s complement assumption  */
2117                 if (value <= (UV)IV_MIN) {
2118                     SvIV_set(sv, -(IV)value);
2119                 } else {
2120                     /* Too negative for an IV.  This is a double upgrade, but
2121                        I'm assuming it will be rare.  */
2122                     if (SvTYPE(sv) < SVt_PVNV)
2123                         sv_upgrade(sv, SVt_PVNV);
2124                     SvNOK_on(sv);
2125                     SvIOK_off(sv);
2126                     SvIOKp_on(sv);
2127                     SvNV_set(sv, -(NV)value);
2128                     SvIV_set(sv, IV_MIN);
2129                 }
2130             }
2131         }
2132         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2133            will be in the previous block to set the IV slot, and the next
2134            block to set the NV slot.  So no else here.  */
2135
2136         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2137             != IS_NUMBER_IN_UV) {
2138             /* It wasn't an (integer that doesn't overflow the UV). */
2139             SvNV_set(sv, Atof(SvPVX_const(sv)));
2140
2141             if (! numtype && ckWARN(WARN_NUMERIC))
2142                 not_a_number(sv);
2143
2144 #if defined(USE_LONG_DOUBLE)
2145             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2146                                   PTR2UV(sv), SvNVX(sv)));
2147 #else
2148             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2149                                   PTR2UV(sv), SvNVX(sv)));
2150 #endif
2151
2152 #ifdef NV_PRESERVES_UV
2153             (void)SvIOKp_on(sv);
2154             (void)SvNOK_on(sv);
2155             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2156                 SvIV_set(sv, I_V(SvNVX(sv)));
2157                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2158                     SvIOK_on(sv);
2159                 } else {
2160                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2161                 }
2162                 /* UV will not work better than IV */
2163             } else {
2164                 if (SvNVX(sv) > (NV)UV_MAX) {
2165                     SvIsUV_on(sv);
2166                     /* Integer is inaccurate. NOK, IOKp, is UV */
2167                     SvUV_set(sv, UV_MAX);
2168                 } else {
2169                     SvUV_set(sv, U_V(SvNVX(sv)));
2170                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2171                        NV preservse UV so can do correct comparison.  */
2172                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2173                         SvIOK_on(sv);
2174                     } else {
2175                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2176                     }
2177                 }
2178                 SvIsUV_on(sv);
2179             }
2180 #else /* NV_PRESERVES_UV */
2181             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2182                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2183                 /* The IV/UV slot will have been set from value returned by
2184                    grok_number above.  The NV slot has just been set using
2185                    Atof.  */
2186                 SvNOK_on(sv);
2187                 assert (SvIOKp(sv));
2188             } else {
2189                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2190                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2191                     /* Small enough to preserve all bits. */
2192                     (void)SvIOKp_on(sv);
2193                     SvNOK_on(sv);
2194                     SvIV_set(sv, I_V(SvNVX(sv)));
2195                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2196                         SvIOK_on(sv);
2197                     /* Assumption: first non-preserved integer is < IV_MAX,
2198                        this NV is in the preserved range, therefore: */
2199                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2200                           < (UV)IV_MAX)) {
2201                         Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2202                     }
2203                 } else {
2204                     /* IN_UV NOT_INT
2205                          0      0       already failed to read UV.
2206                          0      1       already failed to read UV.
2207                          1      0       you won't get here in this case. IV/UV
2208                                         slot set, public IOK, Atof() unneeded.
2209                          1      1       already read UV.
2210                        so there's no point in sv_2iuv_non_preserve() attempting
2211                        to use atol, strtol, strtoul etc.  */
2212 #  ifdef DEBUGGING
2213                     sv_2iuv_non_preserve (sv, numtype);
2214 #  else
2215                     sv_2iuv_non_preserve (sv);
2216 #  endif
2217                 }
2218             }
2219 #endif /* NV_PRESERVES_UV */
2220         /* It might be more code efficient to go through the entire logic above
2221            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2222            gets complex and potentially buggy, so more programmer efficient
2223            to do it this way, by turning off the public flags:  */
2224         if (!numtype)
2225             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2226         }
2227     }
2228     else  {
2229         if (isGV_with_GP(sv))
2230             return glob_2number(MUTABLE_GV(sv));
2231
2232         if (!SvPADTMP(sv)) {
2233             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2234                 report_uninit(sv);
2235         }
2236         if (SvTYPE(sv) < SVt_IV)
2237             /* Typically the caller expects that sv_any is not NULL now.  */
2238             sv_upgrade(sv, SVt_IV);
2239         /* Return 0 from the caller.  */
2240         return TRUE;
2241     }
2242     return FALSE;
2243 }
2244
2245 /*
2246 =for apidoc sv_2iv_flags
2247
2248 Return the integer value of an SV, doing any necessary string
2249 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2250 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2251
2252 =cut
2253 */
2254
2255 IV
2256 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2257 {
2258     dVAR;
2259     if (!sv)
2260         return 0;
2261     if (SvGMAGICAL(sv) || SvVALID(sv)) {
2262         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2263            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2264            In practice they are extremely unlikely to actually get anywhere
2265            accessible by user Perl code - the only way that I'm aware of is when
2266            a constant subroutine which is used as the second argument to index.
2267         */
2268         if (flags & SV_GMAGIC)
2269             mg_get(sv);
2270         if (SvIOKp(sv))
2271             return SvIVX(sv);
2272         if (SvNOKp(sv)) {
2273             return I_V(SvNVX(sv));
2274         }
2275         if (SvPOKp(sv) && SvLEN(sv)) {
2276             UV value;
2277             const int numtype
2278                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2279
2280             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2281                 == IS_NUMBER_IN_UV) {
2282                 /* It's definitely an integer */
2283                 if (numtype & IS_NUMBER_NEG) {
2284                     if (value < (UV)IV_MIN)
2285                         return -(IV)value;
2286                 } else {
2287                     if (value < (UV)IV_MAX)
2288                         return (IV)value;
2289                 }
2290             }
2291             if (!numtype) {
2292                 if (ckWARN(WARN_NUMERIC))
2293                     not_a_number(sv);
2294             }
2295             return I_V(Atof(SvPVX_const(sv)));
2296         }
2297         if (SvROK(sv)) {
2298             goto return_rok;
2299         }
2300         assert(SvTYPE(sv) >= SVt_PVMG);
2301         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2302     } else if (SvTHINKFIRST(sv)) {
2303         if (SvROK(sv)) {
2304         return_rok:
2305             if (SvAMAGIC(sv)) {
2306                 SV * tmpstr;
2307                 if (flags & SV_SKIP_OVERLOAD)
2308                     return 0;
2309                 tmpstr = AMG_CALLunary(sv, numer_amg);
2310                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2311                     return SvIV(tmpstr);
2312                 }
2313             }
2314             return PTR2IV(SvRV(sv));
2315         }
2316         if (SvIsCOW(sv)) {
2317             sv_force_normal_flags(sv, 0);
2318         }
2319         if (SvREADONLY(sv) && !SvOK(sv)) {
2320             if (ckWARN(WARN_UNINITIALIZED))
2321                 report_uninit(sv);
2322             return 0;
2323         }
2324     }
2325     if (!SvIOKp(sv)) {
2326         if (S_sv_2iuv_common(aTHX_ sv))
2327             return 0;
2328     }
2329     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2330         PTR2UV(sv),SvIVX(sv)));
2331     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2332 }
2333
2334 /*
2335 =for apidoc sv_2uv_flags
2336
2337 Return the unsigned integer value of an SV, doing any necessary string
2338 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2339 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2340
2341 =cut
2342 */
2343
2344 UV
2345 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2346 {
2347     dVAR;
2348     if (!sv)
2349         return 0;
2350     if (SvGMAGICAL(sv) || SvVALID(sv)) {
2351         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2352            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  */
2353         if (flags & SV_GMAGIC)
2354             mg_get(sv);
2355         if (SvIOKp(sv))
2356             return SvUVX(sv);
2357         if (SvNOKp(sv))
2358             return U_V(SvNVX(sv));
2359         if (SvPOKp(sv) && SvLEN(sv)) {
2360             UV value;
2361             const int numtype
2362                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2363
2364             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2365                 == IS_NUMBER_IN_UV) {
2366                 /* It's definitely an integer */
2367                 if (!(numtype & IS_NUMBER_NEG))
2368                     return value;
2369             }
2370             if (!numtype) {
2371                 if (ckWARN(WARN_NUMERIC))
2372                     not_a_number(sv);
2373             }
2374             return U_V(Atof(SvPVX_const(sv)));
2375         }
2376         if (SvROK(sv)) {
2377             goto return_rok;
2378         }
2379         assert(SvTYPE(sv) >= SVt_PVMG);
2380         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2381     } else if (SvTHINKFIRST(sv)) {
2382         if (SvROK(sv)) {
2383         return_rok:
2384             if (SvAMAGIC(sv)) {
2385                 SV *tmpstr;
2386                 if (flags & SV_SKIP_OVERLOAD)
2387                     return 0;
2388                 tmpstr = AMG_CALLunary(sv, numer_amg);
2389                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2390                     return SvUV(tmpstr);
2391                 }
2392             }
2393             return PTR2UV(SvRV(sv));
2394         }
2395         if (SvIsCOW(sv)) {
2396             sv_force_normal_flags(sv, 0);
2397         }
2398         if (SvREADONLY(sv) && !SvOK(sv)) {
2399             if (ckWARN(WARN_UNINITIALIZED))
2400                 report_uninit(sv);
2401             return 0;
2402         }
2403     }
2404     if (!SvIOKp(sv)) {
2405         if (S_sv_2iuv_common(aTHX_ sv))
2406             return 0;
2407     }
2408
2409     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2410                           PTR2UV(sv),SvUVX(sv)));
2411     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2412 }
2413
2414 /*
2415 =for apidoc sv_2nv_flags
2416
2417 Return the num value of an SV, doing any necessary string or integer
2418 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2419 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2420
2421 =cut
2422 */
2423
2424 NV
2425 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2426 {
2427     dVAR;
2428     if (!sv)
2429         return 0.0;
2430     if (SvGMAGICAL(sv) || SvVALID(sv)) {
2431         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2432            the same flag bit as SVf_IVisUV, so must not let them cache NVs.  */
2433         if (flags & SV_GMAGIC)
2434             mg_get(sv);
2435         if (SvNOKp(sv))
2436             return SvNVX(sv);
2437         if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2438             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2439                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2440                 not_a_number(sv);
2441             return Atof(SvPVX_const(sv));
2442         }
2443         if (SvIOKp(sv)) {
2444             if (SvIsUV(sv))
2445                 return (NV)SvUVX(sv);
2446             else
2447                 return (NV)SvIVX(sv);
2448         }
2449         if (SvROK(sv)) {
2450             goto return_rok;
2451         }
2452         assert(SvTYPE(sv) >= SVt_PVMG);
2453         /* This falls through to the report_uninit near the end of the
2454            function. */
2455     } else if (SvTHINKFIRST(sv)) {
2456         if (SvROK(sv)) {
2457         return_rok:
2458             if (SvAMAGIC(sv)) {
2459                 SV *tmpstr;
2460                 if (flags & SV_SKIP_OVERLOAD)
2461                     return 0;
2462                 tmpstr = AMG_CALLunary(sv, numer_amg);
2463                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2464                     return SvNV(tmpstr);
2465                 }
2466             }
2467             return PTR2NV(SvRV(sv));
2468         }
2469         if (SvIsCOW(sv)) {
2470             sv_force_normal_flags(sv, 0);
2471         }
2472         if (SvREADONLY(sv) && !SvOK(sv)) {
2473             if (ckWARN(WARN_UNINITIALIZED))
2474                 report_uninit(sv);
2475             return 0.0;
2476         }
2477     }
2478     if (SvTYPE(sv) < SVt_NV) {
2479         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2480         sv_upgrade(sv, SVt_NV);
2481 #ifdef USE_LONG_DOUBLE
2482         DEBUG_c({
2483             STORE_NUMERIC_LOCAL_SET_STANDARD();
2484             PerlIO_printf(Perl_debug_log,
2485                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2486                           PTR2UV(sv), SvNVX(sv));
2487             RESTORE_NUMERIC_LOCAL();
2488         });
2489 #else
2490         DEBUG_c({
2491             STORE_NUMERIC_LOCAL_SET_STANDARD();
2492             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2493                           PTR2UV(sv), SvNVX(sv));
2494             RESTORE_NUMERIC_LOCAL();
2495         });
2496 #endif
2497     }
2498     else if (SvTYPE(sv) < SVt_PVNV)
2499         sv_upgrade(sv, SVt_PVNV);
2500     if (SvNOKp(sv)) {
2501         return SvNVX(sv);
2502     }
2503     if (SvIOKp(sv)) {
2504         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2505 #ifdef NV_PRESERVES_UV
2506         if (SvIOK(sv))
2507             SvNOK_on(sv);
2508         else
2509             SvNOKp_on(sv);
2510 #else
2511         /* Only set the public NV OK flag if this NV preserves the IV  */
2512         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2513         if (SvIOK(sv) &&
2514             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2515                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2516             SvNOK_on(sv);
2517         else
2518             SvNOKp_on(sv);
2519 #endif
2520     }
2521     else if (SvPOKp(sv) && SvLEN(sv)) {
2522         UV value;
2523         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2524         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2525             not_a_number(sv);
2526 #ifdef NV_PRESERVES_UV
2527         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2528             == IS_NUMBER_IN_UV) {
2529             /* It's definitely an integer */
2530             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2531         } else
2532             SvNV_set(sv, Atof(SvPVX_const(sv)));
2533         if (numtype)
2534             SvNOK_on(sv);
2535         else
2536             SvNOKp_on(sv);
2537 #else
2538         SvNV_set(sv, Atof(SvPVX_const(sv)));
2539         /* Only set the public NV OK flag if this NV preserves the value in
2540            the PV at least as well as an IV/UV would.
2541            Not sure how to do this 100% reliably. */
2542         /* if that shift count is out of range then Configure's test is
2543            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2544            UV_BITS */
2545         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2546             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2547             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2548         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2549             /* Can't use strtol etc to convert this string, so don't try.
2550                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2551             SvNOK_on(sv);
2552         } else {
2553             /* value has been set.  It may not be precise.  */
2554             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2555                 /* 2s complement assumption for (UV)IV_MIN  */
2556                 SvNOK_on(sv); /* Integer is too negative.  */
2557             } else {
2558                 SvNOKp_on(sv);
2559                 SvIOKp_on(sv);
2560
2561                 if (numtype & IS_NUMBER_NEG) {
2562                     SvIV_set(sv, -(IV)value);
2563                 } else if (value <= (UV)IV_MAX) {
2564                     SvIV_set(sv, (IV)value);
2565                 } else {
2566                     SvUV_set(sv, value);
2567                     SvIsUV_on(sv);
2568                 }
2569
2570                 if (numtype & IS_NUMBER_NOT_INT) {
2571                     /* I believe that even if the original PV had decimals,
2572                        they are lost beyond the limit of the FP precision.
2573                        However, neither is canonical, so both only get p
2574                        flags.  NWC, 2000/11/25 */
2575                     /* Both already have p flags, so do nothing */
2576                 } else {
2577                     const NV nv = SvNVX(sv);
2578                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2579                         if (SvIVX(sv) == I_V(nv)) {
2580                             SvNOK_on(sv);
2581                         } else {
2582                             /* It had no "." so it must be integer.  */
2583                         }
2584                         SvIOK_on(sv);
2585                     } else {
2586                         /* between IV_MAX and NV(UV_MAX).
2587                            Could be slightly > UV_MAX */
2588
2589                         if (numtype & IS_NUMBER_NOT_INT) {
2590                             /* UV and NV both imprecise.  */
2591                         } else {
2592                             const UV nv_as_uv = U_V(nv);
2593
2594                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2595                                 SvNOK_on(sv);
2596                             }
2597                             SvIOK_on(sv);
2598                         }
2599                     }
2600                 }
2601             }
2602         }
2603         /* It might be more code efficient to go through the entire logic above
2604            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2605            gets complex and potentially buggy, so more programmer efficient
2606            to do it this way, by turning off the public flags:  */
2607         if (!numtype)
2608             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2609 #endif /* NV_PRESERVES_UV */
2610     }
2611     else  {
2612         if (isGV_with_GP(sv)) {
2613             glob_2number(MUTABLE_GV(sv));
2614             return 0.0;
2615         }
2616
2617         if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
2618             report_uninit(sv);
2619         assert (SvTYPE(sv) >= SVt_NV);
2620         /* Typically the caller expects that sv_any is not NULL now.  */
2621         /* XXX Ilya implies that this is a bug in callers that assume this
2622            and ideally should be fixed.  */
2623         return 0.0;
2624     }
2625 #if defined(USE_LONG_DOUBLE)
2626     DEBUG_c({
2627         STORE_NUMERIC_LOCAL_SET_STANDARD();
2628         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2629                       PTR2UV(sv), SvNVX(sv));
2630         RESTORE_NUMERIC_LOCAL();
2631     });
2632 #else
2633     DEBUG_c({
2634         STORE_NUMERIC_LOCAL_SET_STANDARD();
2635         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2636                       PTR2UV(sv), SvNVX(sv));
2637         RESTORE_NUMERIC_LOCAL();
2638     });
2639 #endif
2640     return SvNVX(sv);
2641 }
2642
2643 /*
2644 =for apidoc sv_2num
2645
2646 Return an SV with the numeric value of the source SV, doing any necessary
2647 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2648 access this function.
2649
2650 =cut
2651 */
2652
2653 SV *
2654 Perl_sv_2num(pTHX_ register SV *const sv)
2655 {
2656     PERL_ARGS_ASSERT_SV_2NUM;
2657
2658     if (!SvROK(sv))
2659         return sv;
2660     if (SvAMAGIC(sv)) {
2661         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2662         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2663         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2664             return sv_2num(tmpsv);
2665     }
2666     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2667 }
2668
2669 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2670  * UV as a string towards the end of buf, and return pointers to start and
2671  * end of it.
2672  *
2673  * We assume that buf is at least TYPE_CHARS(UV) long.
2674  */
2675
2676 static char *
2677 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2678 {
2679     char *ptr = buf + TYPE_CHARS(UV);
2680     char * const ebuf = ptr;
2681     int sign;
2682
2683     PERL_ARGS_ASSERT_UIV_2BUF;
2684
2685     if (is_uv)
2686         sign = 0;
2687     else if (iv >= 0) {
2688         uv = iv;
2689         sign = 0;
2690     } else {
2691         uv = -iv;
2692         sign = 1;
2693     }
2694     do {
2695         *--ptr = '0' + (char)(uv % 10);
2696     } while (uv /= 10);
2697     if (sign)
2698         *--ptr = '-';
2699     *peob = ebuf;
2700     return ptr;
2701 }
2702
2703 /*
2704 =for apidoc sv_2pv_flags
2705
2706 Returns a pointer to the string value of an SV, and sets *lp to its length.
2707 If flags includes SV_GMAGIC, does an mg_get() first.  Coerces sv to a
2708 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2709 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2710
2711 =cut
2712 */
2713
2714 char *
2715 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2716 {
2717     dVAR;
2718     register char *s;
2719
2720     if (!sv) {
2721         if (lp)
2722             *lp = 0;
2723         return (char *)"";
2724     }
2725     if (SvGMAGICAL(sv)) {
2726         if (flags & SV_GMAGIC)
2727             mg_get(sv);
2728         if (SvPOKp(sv)) {
2729             if (lp)
2730                 *lp = SvCUR(sv);
2731             if (flags & SV_MUTABLE_RETURN)
2732                 return SvPVX_mutable(sv);
2733             if (flags & SV_CONST_RETURN)
2734                 return (char *)SvPVX_const(sv);
2735             return SvPVX(sv);
2736         }
2737         if (SvIOKp(sv) || SvNOKp(sv)) {
2738             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2739             STRLEN len;
2740
2741             if (SvIOKp(sv)) {
2742                 len = SvIsUV(sv)
2743                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2744                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2745             } else if(SvNVX(sv) == 0.0) {
2746                     tbuf[0] = '0';
2747                     tbuf[1] = 0;
2748                     len = 1;
2749             } else {
2750                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2751                 len = strlen(tbuf);
2752             }
2753             assert(!SvROK(sv));
2754             {
2755                 dVAR;
2756
2757                 SvUPGRADE(sv, SVt_PV);
2758                 if (lp)
2759                     *lp = len;
2760                 s = SvGROW_mutable(sv, len + 1);
2761                 SvCUR_set(sv, len);
2762                 SvPOKp_on(sv);
2763                 return (char*)memcpy(s, tbuf, len + 1);
2764             }
2765         }
2766         if (SvROK(sv)) {
2767             goto return_rok;
2768         }
2769         assert(SvTYPE(sv) >= SVt_PVMG);
2770         /* This falls through to the report_uninit near the end of the
2771            function. */
2772     } else if (SvTHINKFIRST(sv)) {
2773         if (SvROK(sv)) {
2774         return_rok:
2775             if (SvAMAGIC(sv)) {
2776                 SV *tmpstr;
2777                 if (flags & SV_SKIP_OVERLOAD)
2778                     return NULL;
2779                 tmpstr = AMG_CALLunary(sv, string_amg);
2780                 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2781                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2782                     /* Unwrap this:  */
2783                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2784                      */
2785
2786                     char *pv;
2787                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2788                         if (flags & SV_CONST_RETURN) {
2789                             pv = (char *) SvPVX_const(tmpstr);
2790                         } else {
2791                             pv = (flags & SV_MUTABLE_RETURN)
2792                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2793                         }
2794                         if (lp)
2795                             *lp = SvCUR(tmpstr);
2796                     } else {
2797                         pv = sv_2pv_flags(tmpstr, lp, flags);
2798                     }
2799                     if (SvUTF8(tmpstr))
2800                         SvUTF8_on(sv);
2801                     else
2802                         SvUTF8_off(sv);
2803                     return pv;
2804                 }
2805             }
2806             {
2807                 STRLEN len;
2808                 char *retval;
2809                 char *buffer;
2810                 SV *const referent = SvRV(sv);
2811
2812                 if (!referent) {
2813                     len = 7;
2814                     retval = buffer = savepvn("NULLREF", len);
2815                 } else if (SvTYPE(referent) == SVt_REGEXP && (
2816                               !(PL_curcop->cop_hints & HINT_NO_AMAGIC)
2817                            || amagic_is_enabled(string_amg)
2818                           )) {
2819                     REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2820                     I32 seen_evals = 0;
2821
2822                     assert(re);
2823
2824                     /* If the regex is UTF-8 we want the containing scalar to
2825                        have an UTF-8 flag too */
2826                     if (RX_UTF8(re))
2827                         SvUTF8_on(sv);
2828                     else
2829                         SvUTF8_off(sv);
2830
2831                     if ((seen_evals = RX_SEEN_EVALS(re)))
2832                         PL_reginterp_cnt += seen_evals;
2833
2834                     if (lp)
2835                         *lp = RX_WRAPLEN(re);
2836
2837                     return RX_WRAPPED(re);
2838                 } else {
2839                     const char *const typestr = sv_reftype(referent, 0);
2840                     const STRLEN typelen = strlen(typestr);
2841                     UV addr = PTR2UV(referent);
2842                     const char *stashname = NULL;
2843                     STRLEN stashnamelen = 0; /* hush, gcc */
2844                     const char *buffer_end;
2845
2846                     if (SvOBJECT(referent)) {
2847                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2848
2849                         if (name) {
2850                             stashname = HEK_KEY(name);
2851                             stashnamelen = HEK_LEN(name);
2852
2853                             if (HEK_UTF8(name)) {
2854                                 SvUTF8_on(sv);
2855                             } else {
2856                                 SvUTF8_off(sv);
2857                             }
2858                         } else {
2859                             stashname = "__ANON__";
2860                             stashnamelen = 8;
2861                         }
2862                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2863                             + 2 * sizeof(UV) + 2 /* )\0 */;
2864                     } else {
2865                         len = typelen + 3 /* (0x */
2866                             + 2 * sizeof(UV) + 2 /* )\0 */;
2867                     }
2868
2869                     Newx(buffer, len, char);
2870                     buffer_end = retval = buffer + len;
2871
2872                     /* Working backwards  */
2873                     *--retval = '\0';
2874                     *--retval = ')';
2875                     do {
2876                         *--retval = PL_hexdigit[addr & 15];
2877                     } while (addr >>= 4);
2878                     *--retval = 'x';
2879                     *--retval = '0';
2880                     *--retval = '(';
2881
2882                     retval -= typelen;
2883                     memcpy(retval, typestr, typelen);
2884
2885                     if (stashname) {
2886                         *--retval = '=';
2887                         retval -= stashnamelen;
2888                         memcpy(retval, stashname, stashnamelen);
2889                     }
2890                     /* retval may not necessarily have reached the start of the
2891                        buffer here.  */
2892                     assert (retval >= buffer);
2893
2894                     len = buffer_end - retval - 1; /* -1 for that \0  */
2895                 }
2896                 if (lp)
2897                     *lp = len;
2898                 SAVEFREEPV(buffer);
2899                 return retval;
2900             }
2901         }
2902         if (SvREADONLY(sv) && !SvOK(sv)) {
2903             if (lp)
2904                 *lp = 0;
2905             if (flags & SV_UNDEF_RETURNS_NULL)
2906                 return NULL;
2907             if (ckWARN(WARN_UNINITIALIZED))
2908                 report_uninit(sv);
2909             return (char *)"";
2910         }
2911     }
2912     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2913         /* I'm assuming that if both IV and NV are equally valid then
2914            converting the IV is going to be more efficient */
2915         const U32 isUIOK = SvIsUV(sv);
2916         char buf[TYPE_CHARS(UV)];
2917         char *ebuf, *ptr;
2918         STRLEN len;
2919
2920         if (SvTYPE(sv) < SVt_PVIV)
2921             sv_upgrade(sv, SVt_PVIV);
2922         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2923         len = ebuf - ptr;
2924         /* inlined from sv_setpvn */
2925         s = SvGROW_mutable(sv, len + 1);
2926         Move(ptr, s, len, char);
2927         s += len;
2928         *s = '\0';
2929     }
2930     else if (SvNOKp(sv)) {
2931         if (SvTYPE(sv) < SVt_PVNV)
2932             sv_upgrade(sv, SVt_PVNV);
2933         if (SvNVX(sv) == 0.0) {
2934             s = SvGROW_mutable(sv, 2);
2935             *s++ = '0';
2936             *s = '\0';
2937         } else {
2938             dSAVE_ERRNO;
2939             /* The +20 is pure guesswork.  Configure test needed. --jhi */
2940             s = SvGROW_mutable(sv, NV_DIG + 20);
2941             /* some Xenix systems wipe out errno here */
2942             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2943             RESTORE_ERRNO;
2944             while (*s) s++;
2945         }
2946 #ifdef hcx
2947         if (s[-1] == '.')
2948             *--s = '\0';
2949 #endif
2950     }
2951     else {
2952         if (isGV_with_GP(sv)) {
2953             GV *const gv = MUTABLE_GV(sv);
2954             SV *const buffer = sv_newmortal();
2955
2956             gv_efullname3(buffer, gv, "*");
2957
2958             assert(SvPOK(buffer));
2959             if (lp) {
2960                     *lp = SvCUR(buffer);
2961             }
2962             if ( SvUTF8(buffer) ) SvUTF8_on(sv);
2963             return SvPVX(buffer);
2964         }
2965
2966         if (lp)
2967             *lp = 0;
2968         if (flags & SV_UNDEF_RETURNS_NULL)
2969             return NULL;
2970         if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
2971             report_uninit(sv);
2972         if (SvTYPE(sv) < SVt_PV)
2973             /* Typically the caller expects that sv_any is not NULL now.  */
2974             sv_upgrade(sv, SVt_PV);
2975         return (char *)"";
2976     }
2977     {
2978         const STRLEN len = s - SvPVX_const(sv);
2979         if (lp)
2980             *lp = len;
2981         SvCUR_set(sv, len);
2982     }
2983     SvPOK_on(sv);
2984     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2985                           PTR2UV(sv),SvPVX_const(sv)));
2986     if (flags & SV_CONST_RETURN)
2987         return (char *)SvPVX_const(sv);
2988     if (flags & SV_MUTABLE_RETURN)
2989         return SvPVX_mutable(sv);
2990     return SvPVX(sv);
2991 }
2992
2993 /*
2994 =for apidoc sv_copypv
2995
2996 Copies a stringified representation of the source SV into the
2997 destination SV.  Automatically performs any necessary mg_get and
2998 coercion of numeric values into strings.  Guaranteed to preserve
2999 UTF8 flag even from overloaded objects.  Similar in nature to
3000 sv_2pv[_flags] but operates directly on an SV instead of just the
3001 string.  Mostly uses sv_2pv_flags to do its work, except when that
3002 would lose the UTF-8'ness of the PV.
3003
3004 =cut
3005 */
3006
3007 void
3008 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3009 {
3010     STRLEN len;
3011     const char * const s = SvPV_const(ssv,len);
3012
3013     PERL_ARGS_ASSERT_SV_COPYPV;
3014
3015     sv_setpvn(dsv,s,len);
3016     if (SvUTF8(ssv))
3017         SvUTF8_on(dsv);
3018     else
3019         SvUTF8_off(dsv);
3020 }
3021
3022 /*
3023 =for apidoc sv_2pvbyte
3024
3025 Return a pointer to the byte-encoded representation of the SV, and set *lp
3026 to its length.  May cause the SV to be downgraded from UTF-8 as a
3027 side-effect.
3028
3029 Usually accessed via the C<SvPVbyte> macro.
3030
3031 =cut
3032 */
3033
3034 char *
3035 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *const lp)
3036 {
3037     PERL_ARGS_ASSERT_SV_2PVBYTE;
3038
3039     if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv)) {
3040         SV *sv2 = sv_newmortal();
3041         sv_copypv(sv2,sv);
3042         sv = sv2;
3043     }
3044     else SvGETMAGIC(sv);
3045     sv_utf8_downgrade(sv,0);
3046     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3047 }
3048
3049 /*
3050 =for apidoc sv_2pvutf8
3051
3052 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3053 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3054
3055 Usually accessed via the C<SvPVutf8> macro.
3056
3057 =cut
3058 */
3059
3060 char *
3061 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp)
3062 {
3063     PERL_ARGS_ASSERT_SV_2PVUTF8;
3064
3065     if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv))
3066         sv = sv_mortalcopy(sv);
3067     sv_utf8_upgrade(sv);
3068     if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~SVf_POK;
3069     assert(SvPOKp(sv));
3070     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3071 }
3072
3073
3074 /*
3075 =for apidoc sv_2bool
3076
3077 This macro is only used by sv_true() or its macro equivalent, and only if
3078 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3079 It calls sv_2bool_flags with the SV_GMAGIC flag.
3080
3081 =for apidoc sv_2bool_flags
3082
3083 This function is only used by sv_true() and friends,  and only if
3084 the latter's argument is neither SvPOK, SvIOK nor SvNOK.  If the flags
3085 contain SV_GMAGIC, then it does an mg_get() first.
3086
3087
3088 =cut
3089 */
3090
3091 bool
3092 Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
3093 {
3094     dVAR;
3095
3096     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3097
3098     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3099
3100     if (!SvOK(sv))
3101         return 0;
3102     if (SvROK(sv)) {
3103         if (SvAMAGIC(sv)) {
3104             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3105             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3106                 return cBOOL(SvTRUE(tmpsv));
3107         }
3108         return SvRV(sv) != 0;
3109     }
3110     if (SvPOKp(sv)) {
3111         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3112         if (Xpvtmp &&
3113                 (*sv->sv_u.svu_pv > '0' ||
3114                 Xpvtmp->xpv_cur > 1 ||
3115                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3116             return 1;
3117         else
3118             return 0;
3119     }
3120     else {
3121         if (SvIOKp(sv))
3122             return SvIVX(sv) != 0;
3123         else {
3124             if (SvNOKp(sv))
3125                 return SvNVX(sv) != 0.0;
3126             else {
3127                 if (isGV_with_GP(sv))
3128                     return TRUE;
3129                 else
3130                     return FALSE;
3131             }
3132         }
3133     }
3134 }
3135
3136 /*
3137 =for apidoc sv_utf8_upgrade
3138
3139 Converts the PV of an SV to its UTF-8-encoded form.
3140 Forces the SV to string form if it is not already.
3141 Will C<mg_get> on C<sv> if appropriate.
3142 Always sets the SvUTF8 flag to avoid future validity checks even
3143 if the whole string is the same in UTF-8 as not.
3144 Returns the number of bytes in the converted string
3145
3146 This is not as a general purpose byte encoding to Unicode interface:
3147 use the Encode extension for that.
3148
3149 =for apidoc sv_utf8_upgrade_nomg
3150
3151 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3152
3153 =for apidoc sv_utf8_upgrade_flags
3154
3155 Converts the PV of an SV to its UTF-8-encoded form.
3156 Forces the SV to string form if it is not already.
3157 Always sets the SvUTF8 flag to avoid future validity checks even
3158 if all the bytes are invariant in UTF-8.
3159 If C<flags> has C<SV_GMAGIC> bit set,
3160 will C<mg_get> on C<sv> if appropriate, else not.
3161 Returns the number of bytes in the converted string
3162 C<sv_utf8_upgrade> and
3163 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3164
3165 This is not as a general purpose byte encoding to Unicode interface:
3166 use the Encode extension for that.
3167
3168 =cut
3169
3170 The grow version is currently not externally documented.  It adds a parameter,
3171 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3172 have free after it upon return.  This allows the caller to reserve extra space
3173 that it intends to fill, to avoid extra grows.
3174
3175 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3176 which can be used to tell this function to not first check to see if there are
3177 any characters that are different in UTF-8 (variant characters) which would
3178 force it to allocate a new string to sv, but to assume there are.  Typically
3179 this flag is used by a routine that has already parsed the string to find that
3180 there are such characters, and passes this information on so that the work
3181 doesn't have to be repeated.
3182
3183 (One might think that the calling routine could pass in the position of the
3184 first such variant, so it wouldn't have to be found again.  But that is not the
3185 case, because typically when the caller is likely to use this flag, it won't be
3186 calling this routine unless it finds something that won't fit into a byte.
3187 Otherwise it tries to not upgrade and just use bytes.  But some things that
3188 do fit into a byte are variants in utf8, and the caller may not have been
3189 keeping track of these.)
3190
3191 If the routine itself changes the string, it adds a trailing NUL.  Such a NUL
3192 isn't guaranteed due to having other routines do the work in some input cases,
3193 or if the input is already flagged as being in utf8.
3194
3195 The speed of this could perhaps be improved for many cases if someone wanted to
3196 write a fast function that counts the number of variant characters in a string,
3197 especially if it could return the position of the first one.
3198
3199 */
3200
3201 STRLEN
3202 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3203 {
3204     dVAR;
3205
3206     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3207
3208     if (sv == &PL_sv_undef)
3209         return 0;
3210     if (!SvPOK(sv)) {
3211         STRLEN len = 0;
3212         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3213             (void) sv_2pv_flags(sv,&len, flags);
3214             if (SvUTF8(sv)) {
3215                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3216                 return len;
3217             }
3218         } else {
3219             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3220         }
3221     }
3222
3223     if (SvUTF8(sv)) {
3224         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3225         return SvCUR(sv);
3226     }
3227
3228     if (SvIsCOW(sv)) {
3229         sv_force_normal_flags(sv, 0);
3230     }
3231
3232     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3233         sv_recode_to_utf8(sv, PL_encoding);
3234         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3235         return SvCUR(sv);
3236     }
3237
3238     if (SvCUR(sv) == 0) {
3239         if (extra) SvGROW(sv, extra);
3240     } else { /* Assume Latin-1/EBCDIC */
3241         /* This function could be much more efficient if we
3242          * had a FLAG in SVs to signal if there are any variant
3243          * chars in the PV.  Given that there isn't such a flag
3244          * make the loop as fast as possible (although there are certainly ways
3245          * to speed this up, eg. through vectorization) */
3246         U8 * s = (U8 *) SvPVX_const(sv);
3247         U8 * e = (U8 *) SvEND(sv);
3248         U8 *t = s;
3249         STRLEN two_byte_count = 0;
3250
3251         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3252
3253         /* See if really will need to convert to utf8.  We mustn't rely on our
3254          * incoming SV being well formed and having a trailing '\0', as certain
3255          * code in pp_formline can send us partially built SVs. */
3256
3257         while (t < e) {
3258             const U8 ch = *t++;
3259             if (NATIVE_IS_INVARIANT(ch)) continue;
3260
3261             t--;    /* t already incremented; re-point to first variant */
3262             two_byte_count = 1;
3263             goto must_be_utf8;
3264         }
3265
3266         /* utf8 conversion not needed because all are invariants.  Mark as
3267          * UTF-8 even if no variant - saves scanning loop */
3268         SvUTF8_on(sv);
3269         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3270         return SvCUR(sv);
3271
3272 must_be_utf8:
3273
3274         /* Here, the string should be converted to utf8, either because of an
3275          * input flag (two_byte_count = 0), or because a character that
3276          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3277          * the beginning of the string (if we didn't examine anything), or to
3278          * the first variant.  In either case, everything from s to t - 1 will
3279          * occupy only 1 byte each on output.
3280          *
3281          * There are two main ways to convert.  One is to create a new string
3282          * and go through the input starting from the beginning, appending each
3283          * converted value onto the new string as we go along.  It's probably
3284          * best to allocate enough space in the string for the worst possible
3285          * case rather than possibly running out of space and having to
3286          * reallocate and then copy what we've done so far.  Since everything
3287          * from s to t - 1 is invariant, the destination can be initialized
3288          * with these using a fast memory copy
3289          *
3290          * The other way is to figure out exactly how big the string should be
3291          * by parsing the entire input.  Then you don't have to make it big
3292          * enough to handle the worst possible case, and more importantly, if
3293          * the string you already have is large enough, you don't have to
3294          * allocate a new string, you can copy the last character in the input
3295          * string to the final position(s) that will be occupied by the
3296          * converted string and go backwards, stopping at t, since everything
3297          * before that is invariant.
3298          *
3299          * There are advantages and disadvantages to each method.
3300          *
3301          * In the first method, we can allocate a new string, do the memory
3302          * copy from the s to t - 1, and then proceed through the rest of the
3303          * string byte-by-byte.
3304          *
3305          * In the second method, we proceed through the rest of the input
3306          * string just calculating how big the converted string will be.  Then
3307          * there are two cases:
3308          *  1)  if the string has enough extra space to handle the converted
3309          *      value.  We go backwards through the string, converting until we
3310          *      get to the position we are at now, and then stop.  If this
3311          *      position is far enough along in the string, this method is
3312          *      faster than the other method.  If the memory copy were the same
3313          *      speed as the byte-by-byte loop, that position would be about
3314          *      half-way, as at the half-way mark, parsing to the end and back
3315          *      is one complete string's parse, the same amount as starting
3316          *      over and going all the way through.  Actually, it would be
3317          *      somewhat less than half-way, as it's faster to just count bytes
3318          *      than to also copy, and we don't have the overhead of allocating
3319          *      a new string, changing the scalar to use it, and freeing the
3320          *      existing one.  But if the memory copy is fast, the break-even
3321          *      point is somewhere after half way.  The counting loop could be
3322          *      sped up by vectorization, etc, to move the break-even point
3323          *      further towards the beginning.
3324          *  2)  if the string doesn't have enough space to handle the converted
3325          *      value.  A new string will have to be allocated, and one might
3326          *      as well, given that, start from the beginning doing the first
3327          *      method.  We've spent extra time parsing the string and in
3328          *      exchange all we've gotten is that we know precisely how big to
3329          *      make the new one.  Perl is more optimized for time than space,
3330          *      so this case is a loser.
3331          * So what I've decided to do is not use the 2nd method unless it is
3332          * guaranteed that a new string won't have to be allocated, assuming
3333          * the worst case.  I also decided not to put any more conditions on it
3334          * than this, for now.  It seems likely that, since the worst case is
3335          * twice as big as the unknown portion of the string (plus 1), we won't
3336          * be guaranteed enough space, causing us to go to the first method,
3337          * unless the string is short, or the first variant character is near
3338          * the end of it.  In either of these cases, it seems best to use the
3339          * 2nd method.  The only circumstance I can think of where this would
3340          * be really slower is if the string had once had much more data in it
3341          * than it does now, but there is still a substantial amount in it  */
3342
3343         {
3344             STRLEN invariant_head = t - s;
3345             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3346             if (SvLEN(sv) < size) {
3347
3348                 /* Here, have decided to allocate a new string */
3349
3350                 U8 *dst;
3351                 U8 *d;
3352
3353                 Newx(dst, size, U8);
3354
3355                 /* If no known invariants at the beginning of the input string,
3356                  * set so starts from there.  Otherwise, can use memory copy to
3357                  * get up to where we are now, and then start from here */
3358
3359                 if (invariant_head <= 0) {
3360                     d = dst;
3361                 } else {
3362                     Copy(s, dst, invariant_head, char);
3363                     d = dst + invariant_head;
3364                 }
3365
3366                 while (t < e) {
3367                     const UV uv = NATIVE8_TO_UNI(*t++);
3368                     if (UNI_IS_INVARIANT(uv))
3369                         *d++ = (U8)UNI_TO_NATIVE(uv);
3370                     else {
3371                         *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3372                         *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3373                     }
3374                 }
3375                 *d = '\0';
3376                 SvPV_free(sv); /* No longer using pre-existing string */
3377                 SvPV_set(sv, (char*)dst);
3378                 SvCUR_set(sv, d - dst);
3379                 SvLEN_set(sv, size);
3380             } else {
3381
3382                 /* Here, have decided to get the exact size of the string.
3383                  * Currently this happens only when we know that there is
3384                  * guaranteed enough space to fit the converted string, so
3385                  * don't have to worry about growing.  If two_byte_count is 0,
3386                  * then t points to the first byte of the string which hasn't
3387                  * been examined yet.  Otherwise two_byte_count is 1, and t
3388                  * points to the first byte in the string that will expand to
3389                  * two.  Depending on this, start examining at t or 1 after t.
3390                  * */
3391
3392                 U8 *d = t + two_byte_count;
3393
3394
3395                 /* Count up the remaining bytes that expand to two */
3396
3397                 while (d < e) {
3398                     const U8 chr = *d++;
3399                     if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3400                 }
3401
3402                 /* The string will expand by just the number of bytes that
3403                  * occupy two positions.  But we are one afterwards because of
3404                  * the increment just above.  This is the place to put the
3405                  * trailing NUL, and to set the length before we decrement */
3406
3407                 d += two_byte_count;
3408                 SvCUR_set(sv, d - s);
3409                 *d-- = '\0';
3410
3411
3412                 /* Having decremented d, it points to the position to put the
3413                  * very last byte of the expanded string.  Go backwards through
3414                  * the string, copying and expanding as we go, stopping when we
3415                  * get to the part that is invariant the rest of the way down */
3416
3417                 e--;
3418                 while (e >= t) {
3419                     const U8 ch = NATIVE8_TO_UNI(*e--);
3420                     if (UNI_IS_INVARIANT(ch)) {
3421                         *d-- = UNI_TO_NATIVE(ch);
3422                     } else {
3423                         *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3424                         *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3425                     }
3426                 }
3427             }
3428
3429             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3430                 /* Update pos. We do it at the end rather than during
3431                  * the upgrade, to avoid slowing down the common case
3432                  * (upgrade without pos) */
3433                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3434                 if (mg) {
3435                     I32 pos = mg->mg_len;
3436                     if (pos > 0 && (U32)pos > invariant_head) {
3437                         U8 *d = (U8*) SvPVX(sv) + invariant_head;
3438                         STRLEN n = (U32)pos - invariant_head;
3439                         while (n > 0) {
3440                             if (UTF8_IS_START(*d))
3441                                 d++;
3442                             d++;
3443                             n--;
3444                         }
3445                         mg->mg_len  = d - (U8*)SvPVX(sv);
3446                     }
3447                 }
3448                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3449                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3450             }
3451         }
3452     }
3453
3454     /* Mark as UTF-8 even if no variant - saves scanning loop */
3455     SvUTF8_on(sv);
3456     return SvCUR(sv);
3457 }
3458
3459 /*
3460 =for apidoc sv_utf8_downgrade
3461
3462 Attempts to convert the PV of an SV from characters to bytes.
3463 If the PV contains a character that cannot fit
3464 in a byte, this conversion will fail;
3465 in this case, either returns false or, if C<fail_ok> is not
3466 true, croaks.
3467
3468 This is not as a general purpose Unicode to byte encoding interface:
3469 use the Encode extension for that.
3470
3471 =cut
3472 */
3473
3474 bool
3475 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3476 {
3477     dVAR;
3478
3479     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3480
3481     if (SvPOKp(sv) && SvUTF8(sv)) {
3482         if (SvCUR(sv)) {
3483             U8 *s;
3484             STRLEN len;
3485             int mg_flags = SV_GMAGIC;
3486
3487             if (SvIsCOW(sv)) {
3488                 sv_force_normal_flags(sv, 0);
3489             }
3490             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3491                 /* update pos */
3492                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3493                 if (mg) {
3494                     I32 pos = mg->mg_len;
3495                     if (pos > 0) {
3496                         sv_pos_b2u(sv, &pos);
3497                         mg_flags = 0; /* sv_pos_b2u does get magic */
3498                         mg->mg_len  = pos;
3499                     }
3500                 }
3501                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3502                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3503
3504             }
3505             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3506
3507             if (!utf8_to_bytes(s, &len)) {
3508                 if (fail_ok)
3509                     return FALSE;
3510                 else {
3511                     if (PL_op)
3512                         Perl_croak(aTHX_ "Wide character in %s",
3513                                    OP_DESC(PL_op));
3514                     else
3515                         Perl_croak(aTHX_ "Wide character");
3516                 }
3517             }
3518             SvCUR_set(sv, len);
3519         }
3520     }
3521     SvUTF8_off(sv);
3522     return TRUE;
3523 }
3524
3525 /*
3526 =for apidoc sv_utf8_encode
3527
3528 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3529 flag off so that it looks like octets again.
3530
3531 =cut
3532 */
3533
3534 void
3535 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3536 {
3537     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3538
3539     if (SvREADONLY(sv)) {
3540         sv_force_normal_flags(sv, 0);
3541     }
3542     (void) sv_utf8_upgrade(sv);
3543     SvUTF8_off(sv);
3544 }
3545
3546 /*
3547 =for apidoc sv_utf8_decode
3548
3549 If the PV of the SV is an octet sequence in UTF-8
3550 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3551 so that it looks like a character.  If the PV contains only single-byte
3552 characters, the C<SvUTF8> flag stays off.
3553 Scans PV for validity and returns false if the PV is invalid UTF-8.
3554
3555 =cut
3556 */
3557
3558 bool
3559 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3560 {
3561     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3562
3563     if (SvPOKp(sv)) {
3564         const U8 *start, *c;
3565         const U8 *e;
3566
3567         /* The octets may have got themselves encoded - get them back as
3568          * bytes
3569          */
3570         if (!sv_utf8_downgrade(sv, TRUE))
3571             return FALSE;
3572
3573         /* it is actually just a matter of turning the utf8 flag on, but
3574          * we want to make sure everything inside is valid utf8 first.
3575          */
3576         c = start = (const U8 *) SvPVX_const(sv);
3577         if (!is_utf8_string(c, SvCUR(sv)))
3578             return FALSE;
3579         e = (const U8 *) SvEND(sv);
3580         while (c < e) {
3581             const U8 ch = *c++;
3582             if (!UTF8_IS_INVARIANT(ch)) {
3583                 SvUTF8_on(sv);
3584                 break;
3585             }
3586         }
3587         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3588             /* adjust pos to the start of a UTF8 char sequence */
3589             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3590             if (mg) {
3591                 I32 pos = mg->mg_len;
3592                 if (pos > 0) {
3593                     for (c = start + pos; c > start; c--) {
3594                         if (UTF8_IS_START(*c))
3595                             break;
3596                     }
3597                     mg->mg_len  = c - start;
3598                 }
3599             }
3600             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3601                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3602         }
3603     }
3604     return TRUE;
3605 }
3606
3607 /*
3608 =for apidoc sv_setsv
3609
3610 Copies the contents of the source SV C<ssv> into the destination SV
3611 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3612 function if the source SV needs to be reused.  Does not handle 'set' magic.
3613 Loosely speaking, it performs a copy-by-value, obliterating any previous
3614 content of the destination.
3615
3616 You probably want to use one of the assortment of wrappers, such as
3617 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3618 C<SvSetMagicSV_nosteal>.
3619
3620 =for apidoc sv_setsv_flags
3621
3622 Copies the contents of the source SV C<ssv> into the destination SV
3623 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3624 function if the source SV needs to be reused.  Does not handle 'set' magic.
3625 Loosely speaking, it performs a copy-by-value, obliterating any previous
3626 content of the destination.
3627 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3628 C<ssv> if appropriate, else not.  If the C<flags>
3629 parameter has the C<NOSTEAL> bit set then the
3630 buffers of temps will not be stolen.  <sv_setsv>
3631 and C<sv_setsv_nomg> are implemented in terms of this function.
3632
3633 You probably want to use one of the assortment of wrappers, such as
3634 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3635 C<SvSetMagicSV_nosteal>.
3636
3637 This is the primary function for copying scalars, and most other
3638 copy-ish functions and macros use this underneath.
3639
3640 =cut
3641 */
3642
3643 static void
3644 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3645 {
3646     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3647     HV *old_stash = NULL;
3648
3649     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3650
3651     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3652         const char * const name = GvNAME(sstr);
3653         const STRLEN len = GvNAMELEN(sstr);
3654         {
3655             if (dtype >= SVt_PV) {
3656                 SvPV_free(dstr);
3657                 SvPV_set(dstr, 0);
3658                 SvLEN_set(dstr, 0);
3659                 SvCUR_set(dstr, 0);
3660             }
3661             SvUPGRADE(dstr, SVt_PVGV);
3662             (void)SvOK_off(dstr);
3663             /* We have to turn this on here, even though we turn it off
3664                below, as GvSTASH will fail an assertion otherwise. */
3665             isGV_with_GP_on(dstr);
3666         }
3667         GvSTASH(dstr) = GvSTASH(sstr);
3668         if (GvSTASH(dstr))
3669             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3670         gv_name_set(MUTABLE_GV(dstr), name, len,
3671                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3672         SvFAKE_on(dstr);        /* can coerce to non-glob */
3673     }
3674
3675     if(GvGP(MUTABLE_GV(sstr))) {
3676         /* If source has method cache entry, clear it */
3677         if(GvCVGEN(sstr)) {
3678             SvREFCNT_dec(GvCV(sstr));
3679             GvCV_set(sstr, NULL);
3680             GvCVGEN(sstr) = 0;
3681         }
3682         /* If source has a real method, then a method is
3683            going to change */
3684         else if(
3685          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3686         ) {
3687             mro_changes = 1;
3688         }
3689     }
3690
3691     /* If dest already had a real method, that's a change as well */
3692     if(
3693         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3694      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3695     ) {
3696         mro_changes = 1;
3697     }
3698
3699     /* We don't need to check the name of the destination if it was not a
3700        glob to begin with. */
3701     if(dtype == SVt_PVGV) {
3702         const char * const name = GvNAME((const GV *)dstr);
3703         if(
3704             strEQ(name,"ISA")
3705          /* The stash may have been detached from the symbol table, so
3706             check its name. */
3707          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3708          && GvAV((const GV *)sstr)
3709         )
3710             mro_changes = 2;
3711         else {
3712             const STRLEN len = GvNAMELEN(dstr);
3713             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3714              || (len == 1 && name[0] == ':')) {
3715                 mro_changes = 3;
3716
3717                 /* Set aside the old stash, so we can reset isa caches on
3718                    its subclasses. */
3719                 if((old_stash = GvHV(dstr)))
3720                     /* Make sure we do not lose it early. */
3721                     SvREFCNT_inc_simple_void_NN(
3722                      sv_2mortal((SV *)old_stash)
3723                     );
3724             }
3725         }
3726     }
3727
3728     gp_free(MUTABLE_GV(dstr));
3729     isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */
3730     (void)SvOK_off(dstr);
3731     isGV_with_GP_on(dstr);
3732     GvINTRO_off(dstr);          /* one-shot flag */
3733     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3734     if (SvTAINTED(sstr))
3735         SvTAINT(dstr);
3736     if (GvIMPORTED(dstr) != GVf_IMPORTED
3737         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3738         {
3739             GvIMPORTED_on(dstr);
3740         }
3741     GvMULTI_on(dstr);
3742     if(mro_changes == 2) {
3743         MAGIC *mg;
3744         SV * const sref = (SV *)GvAV((const GV *)dstr);
3745         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3746             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3747                 AV * const ary = newAV();
3748                 av_push(ary, mg->mg_obj); /* takes the refcount */
3749                 mg->mg_obj = (SV *)ary;
3750             }
3751             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3752         }
3753         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3754         mro_isa_changed_in(GvSTASH(dstr));
3755     }
3756     else if(mro_changes == 3) {
3757         HV * const stash = GvHV(dstr);
3758         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3759             mro_package_moved(
3760                 stash, old_stash,
3761                 (GV *)dstr, 0
3762             );
3763     }
3764     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3765     return;
3766 }
3767
3768 static void
3769 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3770 {
3771     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3772     SV *dref = NULL;
3773     const int intro = GvINTRO(dstr);
3774     SV **location;
3775     U8 import_flag = 0;
3776     const U32 stype = SvTYPE(sref);
3777
3778     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3779
3780     if (intro) {
3781         GvINTRO_off(dstr);      /* one-shot flag */
3782         GvLINE(dstr) = CopLINE(PL_curcop);
3783         GvEGV(dstr) = MUTABLE_GV(dstr);
3784     }
3785     GvMULTI_on(dstr);
3786     switch (stype) {
3787     case SVt_PVCV:
3788         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3789         import_flag = GVf_IMPORTED_CV;
3790         goto common;
3791     case SVt_PVHV:
3792         location = (SV **) &GvHV(dstr);
3793         import_flag = GVf_IMPORTED_HV;
3794         goto common;
3795     case SVt_PVAV:
3796         location = (SV **) &GvAV(dstr);
3797         import_flag = GVf_IMPORTED_AV;
3798         goto common;
3799     case SVt_PVIO:
3800         location = (SV **) &GvIOp(dstr);
3801         goto common;
3802     case SVt_PVFM:
3803         location = (SV **) &GvFORM(dstr);
3804         goto common;
3805     default:
3806         location = &GvSV(dstr);
3807         import_flag = GVf_IMPORTED_SV;
3808     common:
3809         if (intro) {
3810             if (stype == SVt_PVCV) {
3811                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3812                 if (GvCVGEN(dstr)) {
3813                     SvREFCNT_dec(GvCV(dstr));
3814                     GvCV_set(dstr, NULL);
3815                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3816                 }
3817             }
3818             SAVEGENERICSV(*location);
3819         }
3820         else
3821             dref = *location;
3822         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3823             CV* const cv = MUTABLE_CV(*location);
3824             if (cv) {
3825                 if (!GvCVGEN((const GV *)dstr) &&
3826                     (CvROOT(cv) || CvXSUB(cv)) &&
3827                     /* redundant check that avoids creating the extra SV
3828                        most of the time: */
3829                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3830                     {
3831                         SV * const new_const_sv =
3832                             CvCONST((const CV *)sref)
3833                                  ? cv_const_sv((const CV *)sref)
3834                                  : NULL;
3835                         report_redefined_cv(
3836                            sv_2mortal(Perl_newSVpvf(aTHX_
3837                                 "%"HEKf"::%"HEKf,
3838                                 HEKfARG(
3839                                  HvNAME_HEK(GvSTASH((const GV *)dstr))
3840                                 ),
3841                                 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
3842                            )),
3843                            cv,
3844                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
3845                         );
3846                     }
3847                 if (!intro)
3848                     cv_ckproto_len_flags(cv, (const GV *)dstr,
3849                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
3850                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3851                                    SvPOK(sref) ? SvUTF8(sref) : 0);
3852             }
3853             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3854             GvASSUMECV_on(dstr);
3855             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3856         }
3857         *location = sref;
3858         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3859             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3860             GvFLAGS(dstr) |= import_flag;
3861         }
3862         if (stype == SVt_PVHV) {
3863             const char * const name = GvNAME((GV*)dstr);
3864             const STRLEN len = GvNAMELEN(dstr);
3865             if (
3866                 (
3867                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3868                 || (len == 1 && name[0] == ':')
3869                 )
3870              && (!dref || HvENAME_get(dref))
3871             ) {
3872                 mro_package_moved(
3873                     (HV *)sref, (HV *)dref,
3874                     (GV *)dstr, 0
3875                 );
3876             }
3877         }
3878         else if (
3879             stype == SVt_PVAV && sref != dref
3880          && strEQ(GvNAME((GV*)dstr), "ISA")
3881          /* The stash may have been detached from the symbol table, so
3882             check its name before doing anything. */
3883          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3884         ) {
3885             MAGIC *mg;
3886             MAGIC * const omg = dref && SvSMAGICAL(dref)
3887                                  ? mg_find(dref, PERL_MAGIC_isa)
3888                                  : NULL;
3889             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3890                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3891                     AV * const ary = newAV();
3892                     av_push(ary, mg->mg_obj); /* takes the refcount */
3893                     mg->mg_obj = (SV *)ary;
3894                 }
3895                 if (omg) {
3896                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3897                         SV **svp = AvARRAY((AV *)omg->mg_obj);
3898                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3899                         while (items--)
3900                             av_push(
3901                              (AV *)mg->mg_obj,
3902                              SvREFCNT_inc_simple_NN(*svp++)
3903                             );
3904                     }
3905                     else
3906                         av_push(
3907                          (AV *)mg->mg_obj,
3908                          SvREFCNT_inc_simple_NN(omg->mg_obj)
3909                         );
3910                 }
3911                 else
3912                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3913             }
3914             else
3915             {
3916                 sv_magic(
3917                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3918                 );
3919                 mg = mg_find(sref, PERL_MAGIC_isa);
3920             }
3921             /* Since the *ISA assignment could have affected more than
3922                one stash, don't call mro_isa_changed_in directly, but let
3923                magic_clearisa do it for us, as it already has the logic for
3924                dealing with globs vs arrays of globs. */
3925             assert(mg);
3926             Perl_magic_clearisa(aTHX_ NULL, mg);
3927         }
3928         break;
3929     }
3930     SvREFCNT_dec(dref);
3931     if (SvTAINTED(sstr))
3932         SvTAINT(dstr);
3933     return;
3934 }
3935
3936 void
3937 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3938 {
3939     dVAR;
3940     register U32 sflags;
3941     register int dtype;
3942     register svtype stype;
3943
3944     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3945
3946     if (sstr == dstr)
3947         return;
3948
3949     if (SvIS_FREED(dstr)) {
3950         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3951                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3952     }
3953     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3954     if (!sstr)
3955         sstr = &PL_sv_undef;
3956     if (SvIS_FREED(sstr)) {
3957         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3958                    (void*)sstr, (void*)dstr);
3959     }
3960     stype = SvTYPE(sstr);
3961     dtype = SvTYPE(dstr);
3962
3963     (void)SvAMAGIC_off(dstr);
3964     if ( SvVOK(dstr) )
3965     {
3966         /* need to nuke the magic */
3967         sv_unmagic(dstr, PERL_MAGIC_vstring);
3968     }
3969
3970     /* There's a lot of redundancy below but we're going for speed here */
3971
3972     switch (stype) {
3973     case SVt_NULL:
3974       undef_sstr:
3975         if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3976             (void)SvOK_off(dstr);
3977             return;
3978         }
3979         break;
3980     case SVt_IV:
3981         if (SvIOK(sstr)) {
3982             switch (dtype) {
3983             case SVt_NULL:
3984                 sv_upgrade(dstr, SVt_IV);
3985                 break;
3986             case SVt_NV:
3987             case SVt_PV:
3988                 sv_upgrade(dstr, SVt_PVIV);
3989                 break;
3990             case SVt_PVGV:
3991             case SVt_PVLV:
3992                 goto end_of_first_switch;
3993             }
3994             (void)SvIOK_only(dstr);
3995             SvIV_set(dstr,  SvIVX(sstr));
3996             if (SvIsUV(sstr))
3997                 SvIsUV_on(dstr);
3998             /* SvTAINTED can only be true if the SV has taint magic, which in
3999                turn means that the SV type is PVMG (or greater). This is the
4000                case statement for SVt_IV, so this cannot be true (whatever gcov
4001                may say).  */
4002             assert(!SvTAINTED(sstr));
4003             return;
4004         }
4005         if (!SvROK(sstr))
4006             goto undef_sstr;
4007         if (dtype < SVt_PV && dtype != SVt_IV)
4008             sv_upgrade(dstr, SVt_IV);
4009         break;
4010
4011     case SVt_NV:
4012         if (SvNOK(sstr)) {
4013             switch (dtype) {
4014             case SVt_NULL:
4015             case SVt_IV:
4016                 sv_upgrade(dstr, SVt_NV);
4017                 break;
4018             case SVt_PV:
4019             case SVt_PVIV:
4020                 sv_upgrade(dstr, SVt_PVNV);
4021                 break;
4022             case SVt_PVGV:
4023             case SVt_PVLV:
4024                 goto end_of_first_switch;
4025             }
4026             SvNV_set(dstr, SvNVX(sstr));
4027             (void)SvNOK_only(dstr);
4028             /* SvTAINTED can only be true if the SV has taint magic, which in
4029                turn means that the SV type is PVMG (or greater). This is the
4030                case statement for SVt_NV, so this cannot be true (whatever gcov
4031                may say).  */
4032             assert(!SvTAINTED(sstr));
4033             return;
4034         }
4035         goto undef_sstr;
4036
4037     case SVt_PVFM:
4038 #ifdef PERL_OLD_COPY_ON_WRITE
4039         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4040             if (dtype < SVt_PVIV)
4041                 sv_upgrade(dstr, SVt_PVIV);
4042             break;
4043         }
4044         /* Fall through */
4045 #endif
4046     case SVt_PV:
4047         if (dtype < SVt_PV)
4048             sv_upgrade(dstr, SVt_PV);
4049         break;
4050     case SVt_PVIV:
4051         if (dtype < SVt_PVIV)
4052             sv_upgrade(dstr, SVt_PVIV);
4053         break;
4054     case SVt_PVNV:
4055         if (dtype < SVt_PVNV)
4056             sv_upgrade(dstr, SVt_PVNV);
4057         break;
4058     default:
4059         {
4060         const char * const type = sv_reftype(sstr,0);
4061         if (PL_op)
4062             /* diag_listed_as: Bizarre copy of %s */
4063             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4064         else
4065             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4066         }
4067         break;
4068
4069     case SVt_REGEXP:
4070         if (dtype < SVt_REGEXP)
4071             sv_upgrade(dstr, SVt_REGEXP);
4072         break;
4073
4074         /* case SVt_BIND: */
4075     case SVt_PVLV:
4076     case SVt_PVGV:
4077     case SVt_PVMG:
4078         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4079             mg_get(sstr);
4080             if (SvTYPE(sstr) != stype)
4081                 stype = SvTYPE(sstr);
4082         }
4083         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4084                     glob_assign_glob(dstr, sstr, dtype);
4085                     return;
4086         }
4087         if (stype == SVt_PVLV)
4088             SvUPGRADE(dstr, SVt_PVNV);
4089         else
4090             SvUPGRADE(dstr, (svtype)stype);
4091     }
4092  end_of_first_switch:
4093
4094     /* dstr may have been upgraded.  */
4095     dtype = SvTYPE(dstr);
4096     sflags = SvFLAGS(sstr);
4097
4098     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
4099         /* Assigning to a subroutine sets the prototype.  */
4100         if (SvOK(sstr)) {
4101             STRLEN len;
4102             const char *const ptr = SvPV_const(sstr, len);
4103
4104             SvGROW(dstr, len + 1);
4105             Copy(ptr, SvPVX(dstr), len + 1, char);
4106             SvCUR_set(dstr, len);
4107             SvPOK_only(dstr);
4108             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4109             CvAUTOLOAD_off(dstr);
4110         } else {
4111             SvOK_off(dstr);
4112         }
4113     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
4114         const char * const type = sv_reftype(dstr,0);
4115         if (PL_op)
4116             /* diag_listed_as: Cannot copy to %s */
4117             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4118         else
4119             Perl_croak(aTHX_ "Cannot copy to %s", type);
4120     } else if (sflags & SVf_ROK) {
4121         if (isGV_with_GP(dstr)
4122             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4123             sstr = SvRV(sstr);
4124             if (sstr == dstr) {
4125                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4126                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4127                 {
4128                     GvIMPORTED_on(dstr);
4129                 }
4130                 GvMULTI_on(dstr);
4131                 return;
4132             }
4133             glob_assign_glob(dstr, sstr, dtype);
4134             return;
4135         }
4136
4137         if (dtype >= SVt_PV) {
4138             if (isGV_with_GP(dstr)) {
4139                 glob_assign_ref(dstr, sstr);
4140                 return;
4141             }
4142             if (SvPVX_const(dstr)) {
4143                 SvPV_free(dstr);
4144                 SvLEN_set(dstr, 0);
4145                 SvCUR_set(dstr, 0);
4146             }
4147         }
4148         (void)SvOK_off(dstr);
4149         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4150         SvFLAGS(dstr) |= sflags & SVf_ROK;
4151         assert(!(sflags & SVp_NOK));
4152         assert(!(sflags & SVp_IOK));
4153         assert(!(sflags & SVf_NOK));
4154         assert(!(sflags & SVf_IOK));
4155     }
4156     else if (isGV_with_GP(dstr)) {
4157         if (!(sflags & SVf_OK)) {
4158             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4159                            "Undefined value assigned to typeglob");
4160         }
4161         else {
4162             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4163             if (dstr != (const SV *)gv) {
4164                 const char * const name = GvNAME((const GV *)dstr);
4165                 const STRLEN len = GvNAMELEN(dstr);
4166                 HV *old_stash = NULL;
4167                 bool reset_isa = FALSE;
4168                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4169                  || (len == 1 && name[0] == ':')) {
4170                     /* Set aside the old stash, so we can reset isa caches
4171                        on its subclasses. */
4172                     if((old_stash = GvHV(dstr))) {
4173                         /* Make sure we do not lose it early. */
4174                         SvREFCNT_inc_simple_void_NN(
4175                          sv_2mortal((SV *)old_stash)
4176                         );
4177                     }
4178                     reset_isa = TRUE;
4179                 }
4180
4181                 if (GvGP(dstr))
4182                     gp_free(MUTABLE_GV(dstr));
4183                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4184
4185                 if (reset_isa) {
4186                     HV * const stash = GvHV(dstr);
4187                     if(
4188                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4189                     )
4190                         mro_package_moved(
4191                          stash, old_stash,
4192                          (GV *)dstr, 0
4193                         );
4194                 }
4195             }
4196         }
4197     }
4198     else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4199         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4200     }
4201     else if (sflags & SVp_POK) {
4202         bool isSwipe = 0;
4203
4204         /*
4205          * Check to see if we can just swipe the string.  If so, it's a
4206          * possible small lose on short strings, but a big win on long ones.
4207          * It might even be a win on short strings if SvPVX_const(dstr)
4208          * has to be allocated and SvPVX_const(sstr) has to be freed.
4209          * Likewise if we can set up COW rather than doing an actual copy, we
4210          * drop to the else clause, as the swipe code and the COW setup code
4211          * have much in common.
4212          */
4213
4214         /* Whichever path we take through the next code, we want this true,
4215            and doing it now facilitates the COW check.  */
4216         (void)SvPOK_only(dstr);
4217
4218         if (
4219             /* If we're already COW then this clause is not true, and if COW
4220                is allowed then we drop down to the else and make dest COW
4221                with us.  If caller hasn't said that we're allowed to COW
4222                shared hash keys then we don't do the COW setup, even if the
4223                source scalar is a shared hash key scalar.  */
4224             (((flags & SV_COW_SHARED_HASH_KEYS)
4225                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4226                : 1 /* If making a COW copy is forbidden then the behaviour we
4227                        desire is as if the source SV isn't actually already
4228                        COW, even if it is.  So we act as if the source flags
4229                        are not COW, rather than actually testing them.  */
4230               )
4231 #ifndef PERL_OLD_COPY_ON_WRITE
4232              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4233                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4234                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4235                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4236                 but in turn, it's somewhat dead code, never expected to go
4237                 live, but more kept as a placeholder on how to do it better
4238                 in a newer implementation.  */
4239              /* If we are COW and dstr is a suitable target then we drop down
4240                 into the else and make dest a COW of us.  */
4241              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4242 #endif
4243              )
4244             &&
4245             !(isSwipe =
4246                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4247                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4248                  (!(flags & SV_NOSTEAL)) &&
4249                                         /* and we're allowed to steal temps */
4250                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4251                  SvLEN(sstr))             /* and really is a string */
4252 #ifdef PERL_OLD_COPY_ON_WRITE
4253             && ((flags & SV_COW_SHARED_HASH_KEYS)
4254                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4255                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4256                      && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4257                 : 1)
4258 #endif
4259             ) {
4260             /* Failed the swipe test, and it's not a shared hash key either.
4261                Have to copy the string.  */
4262             STRLEN len = SvCUR(sstr);
4263             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4264             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4265             SvCUR_set(dstr, len);
4266             *SvEND(dstr) = '\0';
4267         } else {
4268             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4269                be true in here.  */
4270             /* Either it's a shared hash key, or it's suitable for
4271                copy-on-write or we can swipe the string.  */
4272             if (DEBUG_C_TEST) {
4273                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4274                 sv_dump(sstr);
4275                 sv_dump(dstr);
4276             }
4277 #ifdef PERL_OLD_COPY_ON_WRITE
4278             if (!isSwipe) {
4279                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4280                     != (SVf_FAKE | SVf_READONLY)) {
4281                     SvREADONLY_on(sstr);
4282                     SvFAKE_on(sstr);
4283                     /* Make the source SV into a loop of 1.
4284                        (about to become 2) */
4285                     SV_COW_NEXT_SV_SET(sstr, sstr);
4286                 }
4287             }
4288 #endif
4289             /* Initial code is common.  */
4290             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4291                 SvPV_free(dstr);
4292             }
4293
4294             if (!isSwipe) {
4295                 /* making another shared SV.  */
4296                 STRLEN cur = SvCUR(sstr);
4297                 STRLEN len = SvLEN(sstr);
4298 #ifdef PERL_OLD_COPY_ON_WRITE
4299                 if (len) {
4300                     assert (SvTYPE(dstr) >= SVt_PVIV);
4301                     /* SvIsCOW_normal */
4302                     /* splice us in between source and next-after-source.  */
4303                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4304                     SV_COW_NEXT_SV_SET(sstr, dstr);
4305                     SvPV_set(dstr, SvPVX_mutable(sstr));
4306                 } else
4307 #endif
4308                 {
4309                     /* SvIsCOW_shared_hash */
4310                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4311                                           "Copy on write: Sharing hash\n"));
4312
4313                     assert (SvTYPE(dstr) >= SVt_PV);
4314                     SvPV_set(dstr,
4315                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4316                 }
4317                 SvLEN_set(dstr, len);
4318                 SvCUR_set(dstr, cur);
4319                 SvREADONLY_on(dstr);
4320                 SvFAKE_on(dstr);
4321             }
4322             else
4323                 {       /* Passes the swipe test.  */
4324                 SvPV_set(dstr, SvPVX_mutable(sstr));
4325                 SvLEN_set(dstr, SvLEN(sstr));
4326                 SvCUR_set(dstr, SvCUR(sstr));
4327
4328                 SvTEMP_off(dstr);
4329                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4330                 SvPV_set(sstr, NULL);
4331                 SvLEN_set(sstr, 0);
4332                 SvCUR_set(sstr, 0);
4333                 SvTEMP_off(sstr);
4334             }
4335         }
4336         if (sflags & SVp_NOK) {
4337             SvNV_set(dstr, SvNVX(sstr));
4338         }
4339         if (sflags & SVp_IOK) {
4340             SvIV_set(dstr, SvIVX(sstr));
4341             /* Must do this otherwise some other overloaded use of 0x80000000
4342                gets confused. I guess SVpbm_VALID */
4343             if (sflags & SVf_IVisUV)
4344                 SvIsUV_on(dstr);
4345         }
4346         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4347         {
4348             const MAGIC * const smg = SvVSTRING_mg(sstr);
4349             if (smg) {
4350                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4351                          smg->mg_ptr, smg->mg_len);
4352                 SvRMAGICAL_on(dstr);
4353             }
4354         }
4355     }
4356     else if (sflags & (SVp_IOK|SVp_NOK)) {
4357         (void)SvOK_off(dstr);
4358         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4359         if (sflags & SVp_IOK) {
4360             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4361             SvIV_set(dstr, SvIVX(sstr));
4362         }
4363         if (sflags & SVp_NOK) {
4364             SvNV_set(dstr, SvNVX(sstr));
4365         }
4366     }
4367     else {
4368         if (isGV_with_GP(sstr)) {
4369             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4370         }
4371         else
4372             (void)SvOK_off(dstr);
4373     }
4374     if (SvTAINTED(sstr))
4375         SvTAINT(dstr);
4376 }
4377
4378 /*
4379 =for apidoc sv_setsv_mg
4380
4381 Like C<sv_setsv>, but also handles 'set' magic.
4382
4383 =cut
4384 */
4385
4386 void
4387 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4388 {
4389     PERL_ARGS_ASSERT_SV_SETSV_MG;
4390
4391     sv_setsv(dstr,sstr);
4392     SvSETMAGIC(dstr);
4393 }
4394
4395 #ifdef PERL_OLD_COPY_ON_WRITE
4396 SV *
4397 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4398 {
4399     STRLEN cur = SvCUR(sstr);
4400     STRLEN len = SvLEN(sstr);
4401     register char *new_pv;
4402
4403     PERL_ARGS_ASSERT_SV_SETSV_COW;
4404
4405     if (DEBUG_C_TEST) {
4406         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4407                       (void*)sstr, (void*)dstr);
4408         sv_dump(sstr);
4409         if (dstr)
4410                     sv_dump(dstr);
4411     }
4412
4413     if (dstr) {
4414         if (SvTHINKFIRST(dstr))
4415             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4416         else if (SvPVX_const(dstr))
4417             Safefree(SvPVX_const(dstr));
4418     }
4419     else
4420         new_SV(dstr);
4421     SvUPGRADE(dstr, SVt_PVIV);
4422
4423     assert (SvPOK(sstr));
4424     assert (SvPOKp(sstr));
4425     assert (!SvIOK(sstr));
4426     assert (!SvIOKp(sstr));
4427     assert (!SvNOK(sstr));
4428     assert (!SvNOKp(sstr));
4429
4430     if (SvIsCOW(sstr)) {
4431
4432         if (SvLEN(sstr) == 0) {
4433             /* source is a COW shared hash key.  */
4434             DEBUG_C(PerlIO_printf(Perl_debug_log,
4435                                   "Fast copy on write: Sharing hash\n"));
4436             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4437             goto common_exit;
4438         }
4439         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4440     } else {
4441         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4442         SvUPGRADE(sstr, SVt_PVIV);
4443         SvREADONLY_on(sstr);
4444         SvFAKE_on(sstr);
4445         DEBUG_C(PerlIO_printf(Perl_debug_log,
4446                               "Fast copy on write: Converting sstr to COW\n"));
4447         SV_COW_NEXT_SV_SET(dstr, sstr);
4448     }
4449     SV_COW_NEXT_SV_SET(sstr, dstr);
4450     new_pv = SvPVX_mutable(sstr);
4451
4452   common_exit:
4453     SvPV_set(dstr, new_pv);
4454     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4455     if (SvUTF8(sstr))
4456         SvUTF8_on(dstr);
4457     SvLEN_set(dstr, len);
4458     SvCUR_set(dstr, cur);
4459     if (DEBUG_C_TEST) {
4460         sv_dump(dstr);
4461     }
4462     return dstr;
4463 }
4464 #endif
4465
4466 /*
4467 =for apidoc sv_setpvn
4468
4469 Copies a string into an SV.  The C<len> parameter indicates the number of
4470 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4471 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4472
4473 =cut
4474 */
4475
4476 void
4477 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4478 {
4479     dVAR;
4480     register char *dptr;
4481
4482     PERL_ARGS_ASSERT_SV_SETPVN;
4483
4484     SV_CHECK_THINKFIRST_COW_DROP(sv);
4485     if (!ptr) {
4486         (void)SvOK_off(sv);
4487         return;
4488     }
4489     else {
4490         /* len is STRLEN which is unsigned, need to copy to signed */
4491         const IV iv = len;
4492         if (iv < 0)
4493             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4494                        IVdf, iv);
4495     }
4496     SvUPGRADE(sv, SVt_PV);
4497
4498     dptr = SvGROW(sv, len + 1);
4499     Move(ptr,dptr,len,char);
4500     dptr[len] = '\0';
4501     SvCUR_set(sv, len);
4502     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4503     SvTAINT(sv);
4504     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4505 }
4506
4507 /*
4508 =for apidoc sv_setpvn_mg
4509
4510 Like C<sv_setpvn>, but also handles 'set' magic.
4511
4512 =cut
4513 */
4514
4515 void
4516 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4517 {
4518     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4519
4520     sv_setpvn(sv,ptr,len);
4521     SvSETMAGIC(sv);
4522 }
4523
4524 /*
4525 =for apidoc sv_setpv
4526
4527 Copies a string into an SV.  The string must be null-terminated.  Does not
4528 handle 'set' magic.  See C<sv_setpv_mg>.
4529
4530 =cut
4531 */
4532
4533 void
4534 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4535 {
4536     dVAR;
4537     register STRLEN len;
4538
4539     PERL_ARGS_ASSERT_SV_SETPV;
4540
4541     SV_CHECK_THINKFIRST_COW_DROP(sv);
4542     if (!ptr) {
4543         (void)SvOK_off(sv);
4544         return;
4545     }
4546     len = strlen(ptr);
4547     SvUPGRADE(sv, SVt_PV);
4548
4549     SvGROW(sv, len + 1);
4550     Move(ptr,SvPVX(sv),len+1,char);
4551     SvCUR_set(sv, len);
4552     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4553     SvTAINT(sv);
4554     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4555 }
4556
4557 /*
4558 =for apidoc sv_setpv_mg
4559
4560 Like C<sv_setpv>, but also handles 'set' magic.
4561
4562 =cut
4563 */
4564
4565 void
4566 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4567 {
4568     PERL_ARGS_ASSERT_SV_SETPV_MG;
4569
4570     sv_setpv(sv,ptr);
4571     SvSETMAGIC(sv);
4572 }
4573
4574 void
4575 Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek)
4576 {
4577     dVAR;
4578
4579     PERL_ARGS_ASSERT_SV_SETHEK;
4580
4581     if (!hek) {
4582         return;
4583     }
4584
4585     if (HEK_LEN(hek) == HEf_SVKEY) {
4586         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4587         return;
4588     } else {
4589         const int flags = HEK_FLAGS(hek);
4590         if (flags & HVhek_WASUTF8) {
4591             STRLEN utf8_len = HEK_LEN(hek);
4592             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4593             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4594             SvUTF8_on(sv);
4595             return;
4596         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
4597             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4598             if (HEK_UTF8(hek))
4599                 SvUTF8_on(sv);
4600             else SvUTF8_off(sv);
4601             return;
4602         }
4603         {
4604             SV_CHECK_THINKFIRST_COW_DROP(sv);
4605             SvUPGRADE(sv, SVt_PV);
4606             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4607             SvCUR_set(sv, HEK_LEN(hek));
4608             SvLEN_set(sv, 0);
4609             SvREADONLY_on(sv);
4610             SvFAKE_on(sv);
4611             SvPOK_on(sv);
4612             if (HEK_UTF8(hek))
4613                 SvUTF8_on(sv);
4614             else SvUTF8_off(sv);
4615             return;
4616         }
4617     }
4618 }
4619
4620
4621 /*
4622 =for apidoc sv_usepvn_flags
4623
4624 Tells an SV to use C<ptr> to find its string value.  Normally the
4625 string is stored inside the SV but sv_usepvn allows the SV to use an
4626 outside string.  The C<ptr> should point to memory that was allocated
4627 by C<malloc>.  It must be the start of a mallocked block
4628 of memory, and not a pointer to the middle of it.  The
4629 string length, C<len>, must be supplied.  By default
4630 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4631 so that pointer should not be freed or used by the programmer after
4632 giving it to sv_usepvn, and neither should any pointers from "behind"
4633 that pointer (e.g. ptr + 1) be used.
4634
4635 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC.  If C<flags> &
4636 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4637 will be skipped (i.e. the buffer is actually at least 1 byte longer than
4638 C<len>, and already meets the requirements for storing in C<SvPVX>).
4639
4640 =cut
4641 */
4642
4643 void
4644 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4645 {
4646     dVAR;
4647     STRLEN allocate;
4648
4649     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4650
4651     SV_CHECK_THINKFIRST_COW_DROP(sv);
4652     SvUPGRADE(sv, SVt_PV);
4653     if (!ptr) {
4654         (void)SvOK_off(sv);
4655         if (flags & SV_SMAGIC)
4656             SvSETMAGIC(sv);
4657         return;
4658     }
4659     if (SvPVX_const(sv))
4660         SvPV_free(sv);
4661
4662 #ifdef DEBUGGING
4663     if (flags & SV_HAS_TRAILING_NUL)
4664         assert(ptr[len] == '\0');
4665 #endif
4666
4667     allocate = (flags & SV_HAS_TRAILING_NUL)
4668         ? len + 1 :
4669 #ifdef Perl_safesysmalloc_size
4670         len + 1;
4671 #else
4672         PERL_STRLEN_ROUNDUP(len + 1);
4673 #endif
4674     if (flags & SV_HAS_TRAILING_NUL) {
4675         /* It's long enough - do nothing.
4676            Specifically Perl_newCONSTSUB is relying on this.  */
4677     } else {
4678 #ifdef DEBUGGING
4679         /* Force a move to shake out bugs in callers.  */
4680         char *new_ptr = (char*)safemalloc(allocate);
4681         Copy(ptr, new_ptr, len, char);
4682         PoisonFree(ptr,len,char);
4683         Safefree(ptr);
4684         ptr = new_ptr;
4685 #else
4686         ptr = (char*) saferealloc (ptr, allocate);
4687 #endif
4688     }
4689 #ifdef Perl_safesysmalloc_size
4690     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4691 #else
4692     SvLEN_set(sv, allocate);
4693 #endif
4694     SvCUR_set(sv, len);
4695     SvPV_set(sv, ptr);
4696     if (!(flags & SV_HAS_TRAILING_NUL)) {
4697         ptr[len] = '\0';
4698     }
4699     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4700     SvTAINT(sv);
4701     if (flags & SV_SMAGIC)
4702         SvSETMAGIC(sv);
4703 }
4704
4705 #ifdef PERL_OLD_COPY_ON_WRITE
4706 /* Need to do this *after* making the SV normal, as we need the buffer
4707    pointer to remain valid until after we've copied it.  If we let go too early,
4708    another thread could invalidate it by unsharing last of the same hash key
4709    (which it can do by means other than releasing copy-on-write Svs)
4710    or by changing the other copy-on-write SVs in the loop.  */
4711 STATIC void
4712 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4713 {
4714     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4715
4716     { /* this SV was SvIsCOW_normal(sv) */
4717          /* we need to find the SV pointing to us.  */
4718         SV *current = SV_COW_NEXT_SV(after);
4719
4720         if (current == sv) {
4721             /* The SV we point to points back to us (there were only two of us
4722                in the loop.)
4723                Hence other SV is no longer copy on write either.  */
4724             SvFAKE_off(after);
4725             SvREADONLY_off(after);
4726         } else {
4727             /* We need to follow the pointers around the loop.  */
4728             SV *next;
4729             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4730                 assert (next);
4731                 current = next;
4732                  /* don't loop forever if the structure is bust, and we have
4733                     a pointer into a closed loop.  */
4734                 assert (current != after);
4735                 assert (SvPVX_const(current) == pvx);
4736             }
4737             /* Make the SV before us point to the SV after us.  */
4738             SV_COW_NEXT_SV_SET(current, after);
4739         }
4740     }
4741 }
4742 #endif
4743 /*
4744 =for apidoc sv_force_normal_flags
4745
4746 Undo various types of fakery on an SV: if the PV is a shared string, make
4747 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4748 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4749 we do the copy, and is also used locally.  If C<SV_COW_DROP_PV> is set
4750 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4751 SvPOK_off rather than making a copy.  (Used where this
4752 scalar is about to be set to some other value.)  In addition,
4753 the C<flags> parameter gets passed to C<sv_unref_flags()>
4754 when unreffing.  C<sv_force_normal> calls this function
4755 with flags set to 0.
4756
4757 =cut
4758 */
4759
4760 void
4761 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4762 {
4763     dVAR;
4764
4765     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4766
4767 #ifdef PERL_OLD_COPY_ON_WRITE
4768     if (SvREADONLY(sv)) {
4769         if (SvFAKE(sv)) {
4770             const char * const pvx = SvPVX_const(sv);
4771             const STRLEN len = SvLEN(sv);
4772             const STRLEN cur = SvCUR(sv);
4773             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4774                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4775                we'll fail an assertion.  */
4776             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4777
4778             if (DEBUG_C_TEST) {
4779                 PerlIO_printf(Perl_debug_log,
4780                               "Copy on write: Force normal %ld\n",
4781                               (long) flags);
4782                 sv_dump(sv);
4783             }
4784             SvFAKE_off(sv);
4785             SvREADONLY_off(sv);
4786             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4787             SvPV_set(sv, NULL);
4788             SvLEN_set(sv, 0);
4789             if (flags & SV_COW_DROP_PV) {
4790                 /* OK, so we don't need to copy our buffer.  */
4791                 SvPOK_off(sv);
4792             } else {
4793                 SvGROW(sv, cur + 1);
4794                 Move(pvx,SvPVX(sv),cur,char);
4795                 SvCUR_set(sv, cur);
4796                 *SvEND(sv) = '\0';
4797             }
4798             if (len) {
4799                 sv_release_COW(sv, pvx, next);
4800             } else {
4801                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4802             }
4803             if (DEBUG_C_TEST) {
4804                 sv_dump(sv);
4805             }
4806         }
4807         else if (IN_PERL_RUNTIME)
4808             Perl_croak_no_modify(aTHX);
4809     }
4810 #else
4811     if (SvREADONLY(sv)) {
4812         if (SvIsCOW(sv)) {
4813             const char * const pvx = SvPVX_const(sv);
4814             const STRLEN len = SvCUR(sv);
4815             SvFAKE_off(sv);
4816             SvREADONLY_off(sv);
4817             SvPV_set(sv, NULL);
4818             SvLEN_set(sv, 0);
4819             if (flags & SV_COW_DROP_PV) {
4820                 /* OK, so we don't need to copy our buffer.  */
4821                 SvPOK_off(sv);
4822             } else {
4823                 SvGROW(sv, len + 1);
4824                 Move(pvx,SvPVX(sv),len,char);
4825                 *SvEND(sv) = '\0';
4826             }
4827             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4828         }
4829         else if (IN_PERL_RUNTIME)
4830             Perl_croak_no_modify(aTHX);
4831     }
4832 #endif
4833     if (SvROK(sv))
4834         sv_unref_flags(sv, flags);
4835     else if (SvFAKE(sv) && isGV_with_GP(sv))
4836         sv_unglob(sv, flags);
4837     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4838         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
4839            to sv_unglob. We only need it here, so inline it.  */
4840         const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4841         SV *const temp = newSV_type(new_type);
4842         void *const temp_p = SvANY(sv);
4843
4844         if (new_type == SVt_PVMG) {
4845             SvMAGIC_set(temp, SvMAGIC(sv));
4846             SvMAGIC_set(sv, NULL);
4847             SvSTASH_set(temp, SvSTASH(sv));
4848             SvSTASH_set(sv, NULL);
4849         }
4850         SvCUR_set(temp, SvCUR(sv));
4851         /* Remember that SvPVX is in the head, not the body. */
4852         if (SvLEN(temp)) {
4853             SvLEN_set(temp, SvLEN(sv));
4854             /* This signals "buffer is owned by someone else" in sv_clear,
4855                which is the least effort way to stop it freeing the buffer.
4856             */
4857             SvLEN_set(sv, SvLEN(sv)+1);
4858         } else {
4859             /* Their buffer is already owned by someone else. */
4860             SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4861             SvLEN_set(temp, SvCUR(sv)+1);
4862         }
4863
4864         /* Now swap the rest of the bodies. */
4865
4866         SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4867         SvFLAGS(sv) |= new_type;
4868         SvANY(sv) = SvANY(temp);
4869
4870         SvFLAGS(temp) &= ~(SVTYPEMASK);
4871         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4872         SvANY(temp) = temp_p;
4873
4874         SvREFCNT_dec(temp);
4875     }
4876 }
4877
4878 /*
4879 =for apidoc sv_chop
4880
4881 Efficient removal of characters from the beginning of the string buffer.
4882 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4883 the string buffer.  The C<ptr> becomes the first character of the adjusted
4884 string.  Uses the "OOK hack".
4885
4886 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4887 refer to the same chunk of data.
4888
4889 The unfortunate similarity of this function's name to that of Perl's C<chop>
4890 operator is strictly coincidental.  This function works from the left;
4891 C<chop> works from the right.
4892
4893 =cut
4894 */
4895
4896 void
4897 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4898 {
4899     STRLEN delta;
4900     STRLEN old_delta;
4901     U8 *p;
4902 #ifdef DEBUGGING
4903     const U8 *evacp;
4904     STRLEN evacn;
4905 #endif
4906     STRLEN max_delta;
4907
4908     PERL_ARGS_ASSERT_SV_CHOP;
4909
4910     if (!ptr || !SvPOKp(sv))
4911         return;
4912     delta = ptr - SvPVX_const(sv);
4913     if (!delta) {
4914         /* Nothing to do.  */
4915         return;
4916     }
4917     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4918     if (delta > max_delta)
4919         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4920                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4921     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
4922     SV_CHECK_THINKFIRST(sv);
4923
4924     if (!SvOOK(sv)) {
4925         if (!SvLEN(sv)) { /* make copy of shared string */
4926             const char *pvx = SvPVX_const(sv);
4927             const STRLEN len = SvCUR(sv);
4928             SvGROW(sv, len + 1);
4929             Move(pvx,SvPVX(sv),len,char);
4930             *SvEND(sv) = '\0';
4931         }
4932         SvOOK_on(sv);
4933         old_delta = 0;
4934     } else {
4935         SvOOK_offset(sv, old_delta);
4936     }
4937     SvLEN_set(sv, SvLEN(sv) - delta);
4938     SvCUR_set(sv, SvCUR(sv) - delta);
4939     SvPV_set(sv, SvPVX(sv) + delta);
4940
4941     p = (U8 *)SvPVX_const(sv);
4942
4943 #ifdef DEBUGGING
4944     /* how many bytes were evacuated?  we will fill them with sentinel
4945        bytes, except for the part holding the new offset of course. */
4946     evacn = delta;
4947     if (old_delta)
4948         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
4949     assert(evacn);
4950     assert(evacn <= delta + old_delta);
4951     evacp = p - evacn;
4952 #endif
4953
4954     delta += old_delta;
4955     assert(delta);
4956     if (delta < 0x100) {
4957         *--p = (U8) delta;
4958     } else {
4959         *--p = 0;
4960         p -= sizeof(STRLEN);
4961         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4962     }
4963
4964 #ifdef DEBUGGING
4965     /* Fill the preceding buffer with sentinals to verify that no-one is
4966        using it.  */
4967     while (p > evacp) {
4968         --p;
4969         *p = (U8)PTR2UV(p);
4970     }
4971 #endif
4972 }
4973
4974 /*
4975 =for apidoc sv_catpvn
4976
4977 Concatenates the string onto the end of the string which is in the SV.  The
4978 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4979 status set, then the bytes appended should be valid UTF-8.
4980 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4981
4982 =for apidoc sv_catpvn_flags
4983
4984 Concatenates the string onto the end of the string which is in the SV.  The
4985 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4986 status set, then the bytes appended should be valid UTF-8.
4987 If C<flags> has the C<SV_SMAGIC> bit set, will
4988 C<mg_set> on C<dsv> afterwards if appropriate.
4989 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4990 in terms of this function.
4991
4992 =cut
4993 */
4994
4995 void
4996 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4997 {
4998     dVAR;
4999     STRLEN dlen;
5000     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5001
5002     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5003     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5004
5005     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5006       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5007          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5008          dlen = SvCUR(dsv);
5009       }
5010       else SvGROW(dsv, dlen + slen + 1);
5011       if (sstr == dstr)
5012         sstr = SvPVX_const(dsv);
5013       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5014       SvCUR_set(dsv, SvCUR(dsv) + slen);
5015     }
5016     else {
5017         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5018         const char * const send = sstr + slen;
5019         U8 *d;
5020
5021         /* Something this code does not account for, which I think is
5022            impossible; it would require the same pv to be treated as
5023            bytes *and* utf8, which would indicate a bug elsewhere. */
5024         assert(sstr != dstr);
5025
5026         SvGROW(dsv, dlen + slen * 2 + 1);
5027         d = (U8 *)SvPVX(dsv) + dlen;
5028
5029         while (sstr < send) {
5030             const UV uv = NATIVE_TO_ASCII((U8)*sstr++);
5031             if (UNI_IS_INVARIANT(uv))
5032                 *d++ = (U8)UTF_TO_NATIVE(uv);
5033             else {
5034                 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
5035                 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
5036             }
5037         }
5038         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5039     }
5040     *SvEND(dsv) = '\0';
5041     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5042     SvTAINT(dsv);
5043     if (flags & SV_SMAGIC)
5044         SvSETMAGIC(dsv);
5045 }
5046
5047 /*
5048 =for apidoc sv_catsv
5049
5050 Concatenates the string from SV C<ssv> onto the end of the string in
5051 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
5052 not 'set' magic.  See C<sv_catsv_mg>.
5053
5054 =for apidoc sv_catsv_flags
5055
5056 Concatenates the string from SV C<ssv> onto the end of the string in
5057 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
5058 bit set, will C<mg_get> on the C<ssv>, if appropriate, before
5059 reading it.  If the C<flags> contain C<SV_SMAGIC>, C<mg_set> will be
5060 called on the modified SV afterward, if appropriate.  C<sv_catsv>
5061 and C<sv_catsv_nomg> are implemented in terms of this function.
5062
5063 =cut */
5064
5065 void
5066 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
5067 {
5068     dVAR;
5069
5070     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5071
5072    if (ssv) {
5073         STRLEN slen;
5074         const char *spv = SvPV_flags_const(ssv, slen, flags);
5075         if (spv) {
5076             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5077                 mg_get(dsv);
5078             sv_catpvn_flags(dsv, spv, slen,
5079                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5080         }
5081     }
5082     if (flags & SV_SMAGIC)
5083         SvSETMAGIC(dsv);
5084 }
5085
5086 /*
5087 =for apidoc sv_catpv
5088
5089 Concatenates the string onto the end of the string which is in the SV.
5090 If the SV has the UTF-8 status set, then the bytes appended should be
5091 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
5092
5093 =cut */
5094
5095 void
5096 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
5097 {
5098     dVAR;
5099     register STRLEN len;
5100     STRLEN tlen;
5101     char *junk;
5102
5103     PERL_ARGS_ASSERT_SV_CATPV;
5104
5105     if (!ptr)
5106         return;
5107     junk = SvPV_force(sv, tlen);
5108     len = strlen(ptr);
5109     SvGROW(sv, tlen + len + 1);
5110     if (ptr == junk)
5111         ptr = SvPVX_const(sv);
5112     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5113     SvCUR_set(sv, SvCUR(sv) + len);
5114     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5115     SvTAINT(sv);
5116 }
5117
5118 /*
5119 =for apidoc sv_catpv_flags
5120
5121 Concatenates the string onto the end of the string which is in the SV.
5122 If the SV has the UTF-8 status set, then the bytes appended should
5123 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5124 on the modified SV if appropriate.
5125
5126 =cut
5127 */
5128
5129 void
5130 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5131 {
5132     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5133     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5134 }
5135
5136 /*
5137 =for apidoc sv_catpv_mg
5138
5139 Like C<sv_catpv>, but also handles 'set' magic.
5140
5141 =cut
5142 */
5143
5144 void
5145 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
5146 {
5147     PERL_ARGS_ASSERT_SV_CATPV_MG;
5148
5149     sv_catpv(sv,ptr);
5150     SvSETMAGIC(sv);
5151 }
5152
5153 /*
5154 =for apidoc newSV
5155
5156 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5157 bytes of preallocated string space the SV should have.  An extra byte for a
5158 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
5159 space is allocated.)  The reference count for the new SV is set to 1.
5160
5161 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5162 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5163 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5164 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5165 modules supporting older perls.
5166
5167 =cut
5168 */
5169
5170 SV *
5171 Perl_newSV(pTHX_ const STRLEN len)
5172 {
5173     dVAR;
5174     register SV *sv;
5175
5176     new_SV(sv);
5177     if (len) {
5178         sv_upgrade(sv, SVt_PV);
5179         SvGROW(sv, len + 1);
5180     }
5181     return sv;
5182 }
5183 /*
5184 =for apidoc sv_magicext
5185
5186 Adds magic to an SV, upgrading it if necessary.  Applies the
5187 supplied vtable and returns a pointer to the magic added.
5188
5189 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5190 In particular, you can add magic to SvREADONLY SVs, and add more than
5191 one instance of the same 'how'.
5192
5193 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5194 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5195 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5196 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5197
5198 (This is now used as a subroutine by C<sv_magic>.)
5199
5200 =cut
5201 */
5202 MAGIC *
5203 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5204                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5205 {
5206     dVAR;
5207     MAGIC* mg;
5208
5209     PERL_ARGS_ASSERT_SV_MAGICEXT;
5210
5211     SvUPGRADE(sv, SVt_PVMG);
5212     Newxz(mg, 1, MAGIC);
5213     mg->mg_moremagic = SvMAGIC(sv);
5214     SvMAGIC_set(sv, mg);
5215
5216     /* Sometimes a magic contains a reference loop, where the sv and
5217        object refer to each other.  To prevent a reference loop that
5218        would prevent such objects being freed, we look for such loops
5219        and if we find one we avoid incrementing the object refcount.
5220
5221        Note we cannot do this to avoid self-tie loops as intervening RV must
5222        have its REFCNT incremented to keep it in existence.
5223
5224     */
5225     if (!obj || obj == sv ||
5226         how == PERL_MAGIC_arylen ||
5227         how == PERL_MAGIC_symtab ||
5228         (SvTYPE(obj) == SVt_PVGV &&
5229             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5230              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5231              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5232     {
5233         mg->mg_obj = obj;
5234     }
5235     else {
5236         mg->mg_obj = SvREFCNT_inc_simple(obj);
5237         mg->mg_flags |= MGf_REFCOUNTED;
5238     }
5239
5240     /* Normal self-ties simply pass a null object, and instead of
5241        using mg_obj directly, use the SvTIED_obj macro to produce a
5242        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5243        with an RV obj pointing to the glob containing the PVIO.  In
5244        this case, to avoid a reference loop, we need to weaken the
5245        reference.
5246     */
5247
5248     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5249         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5250     {
5251       sv_rvweaken(obj);
5252     }
5253
5254     mg->mg_type = how;
5255     mg->mg_len = namlen;
5256     if (name) {
5257         if (namlen > 0)
5258             mg->mg_ptr = savepvn(name, namlen);
5259         else if (namlen == HEf_SVKEY) {
5260             /* Yes, this is casting away const. This is only for the case of
5261                HEf_SVKEY. I think we need to document this aberation of the
5262                constness of the API, rather than making name non-const, as
5263                that change propagating outwards a long way.  */
5264             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5265         } else
5266             mg->mg_ptr = (char *) name;
5267     }
5268     mg->mg_virtual = (MGVTBL *) vtable;
5269
5270     mg_magical(sv);
5271     if (SvGMAGICAL(sv))
5272         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5273     return mg;
5274 }
5275
5276 /*
5277 =for apidoc sv_magic
5278
5279 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5280 necessary, then adds a new magic item of type C<how> to the head of the
5281 magic list.
5282
5283 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5284 handling of the C<name> and C<namlen> arguments.
5285
5286 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5287 to add more than one instance of the same 'how'.
5288
5289 =cut
5290 */
5291
5292 void
5293 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5294              const char *const name, const I32 namlen)
5295 {
5296     dVAR;
5297     const MGVTBL *vtable;
5298     MAGIC* mg;
5299     unsigned int flags;
5300     unsigned int vtable_index;
5301
5302     PERL_ARGS_ASSERT_SV_MAGIC;
5303
5304     if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
5305         || ((flags = PL_magic_data[how]),
5306             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5307             > magic_vtable_max))
5308         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5309
5310     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5311        Useful for attaching extension internal data to perl vars.
5312        Note that multiple extensions may clash if magical scalars
5313        etc holding private data from one are passed to another. */
5314
5315     vtable = (vtable_index == magic_vtable_max)
5316         ? NULL : PL_magic_vtables + vtable_index;
5317
5318 #ifdef PERL_OLD_COPY_ON_WRITE
5319     if (SvIsCOW(sv))
5320         sv_force_normal_flags(sv, 0);
5321 #endif
5322     if (SvREADONLY(sv)) {
5323         if (
5324             /* its okay to attach magic to shared strings */
5325             !SvIsCOW(sv)
5326
5327             && IN_PERL_RUNTIME
5328             && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5329            )
5330         {
5331             Perl_croak_no_modify(aTHX);
5332         }
5333     }
5334     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5335         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5336             /* sv_magic() refuses to add a magic of the same 'how' as an
5337                existing one
5338              */
5339             if (how == PERL_MAGIC_taint) {
5340                 mg->mg_len |= 1;
5341                 /* Any scalar which already had taint magic on which someone
5342                    (erroneously?) did SvIOK_on() or similar will now be
5343                    incorrectly sporting public "OK" flags.  */
5344                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5345             }
5346             return;
5347         }
5348     }
5349
5350     /* Rest of work is done else where */
5351     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5352
5353     switch (how) {
5354     case PERL_MAGIC_taint:
5355         mg->mg_len = 1;
5356         break;
5357     case PERL_MAGIC_ext:
5358     case PERL_MAGIC_dbfile:
5359         SvRMAGICAL_on(sv);
5360         break;
5361     }
5362 }
5363
5364 static int
5365 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5366 {
5367     MAGIC* mg;
5368     MAGIC** mgp;
5369
5370     assert(flags <= 1);
5371
5372     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5373         return 0;
5374     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5375     for (mg = *mgp; mg; mg = *mgp) {
5376         const MGVTBL* const virt = mg->mg_virtual;
5377         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5378             *mgp = mg->mg_moremagic;
5379             if (virt && virt->svt_free)
5380                 virt->svt_free(aTHX_ sv, mg);
5381             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5382                 if (mg->mg_len > 0)
5383                     Safefree(mg->mg_ptr);
5384                 else if (mg->mg_len == HEf_SVKEY)
5385                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5386                 else if (mg->mg_type == PERL_MAGIC_utf8)
5387                     Safefree(mg->mg_ptr);
5388             }
5389             if (mg->mg_flags & MGf_REFCOUNTED)
5390                 SvREFCNT_dec(mg->mg_obj);
5391             Safefree(mg);
5392         }
5393         else
5394             mgp = &mg->mg_moremagic;
5395     }
5396     if (SvMAGIC(sv)) {
5397         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5398             mg_magical(sv);     /*    else fix the flags now */
5399     }
5400     else {
5401         SvMAGICAL_off(sv);
5402         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5403     }
5404     return 0;
5405 }
5406
5407 /*
5408 =for apidoc sv_unmagic
5409
5410 Removes all magic of type C<type> from an SV.
5411
5412 =cut
5413 */
5414
5415 int
5416 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5417 {
5418     PERL_ARGS_ASSERT_SV_UNMAGIC;
5419     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5420 }
5421
5422 /*
5423 =for apidoc sv_unmagicext
5424
5425 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5426
5427 =cut
5428 */
5429
5430 int
5431 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5432 {
5433     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5434     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5435 }
5436
5437 /*
5438 =for apidoc sv_rvweaken
5439
5440 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5441 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5442 push a back-reference to this RV onto the array of backreferences
5443 associated with that magic.  If the RV is magical, set magic will be
5444 called after the RV is cleared.
5445
5446 =cut
5447 */
5448
5449 SV *
5450 Perl_sv_rvweaken(pTHX_ SV *const sv)
5451 {
5452     SV *tsv;
5453
5454     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5455
5456     if (!SvOK(sv))  /* let undefs pass */
5457         return sv;
5458     if (!SvROK(sv))
5459         Perl_croak(aTHX_ "Can't weaken a nonreference");
5460     else if (SvWEAKREF(sv)) {
5461         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5462         return sv;
5463     }
5464     else if (SvREADONLY(sv)) croak_no_modify();
5465     tsv = SvRV(sv);
5466     Perl_sv_add_backref(aTHX_ tsv, sv);
5467     SvWEAKREF_on(sv);
5468     SvREFCNT_dec(tsv);
5469     return sv;
5470 }
5471
5472 /* Give tsv backref magic if it hasn't already got it, then push a
5473  * back-reference to sv onto the array associated with the backref magic.
5474  *
5475  * As an optimisation, if there's only one backref and it's not an AV,
5476  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5477  * allocate an AV. (Whether the slot holds an AV tells us whether this is
5478  * active.)
5479  */
5480
5481 /* A discussion about the backreferences array and its refcount:
5482  *
5483  * The AV holding the backreferences is pointed to either as the mg_obj of
5484  * PERL_MAGIC_backref, or in the specific case of a HV, from the
5485  * xhv_backreferences field. The array is created with a refcount
5486  * of 2. This means that if during global destruction the array gets
5487  * picked on before its parent to have its refcount decremented by the
5488  * random zapper, it won't actually be freed, meaning it's still there for
5489  * when its parent gets freed.
5490  *
5491  * When the parent SV is freed, the extra ref is killed by
5492  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
5493  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5494  *
5495  * When a single backref SV is stored directly, it is not reference
5496  * counted.
5497  */
5498
5499 void
5500 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5501 {
5502     dVAR;
5503     SV **svp;
5504     AV *av = NULL;
5505     MAGIC *mg = NULL;
5506
5507     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5508
5509     /* find slot to store array or singleton backref */
5510
5511     if (SvTYPE(tsv) == SVt_PVHV) {
5512         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5513     } else {
5514         if (! ((mg =
5515             (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5516         {
5517             sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5518             mg = mg_find(tsv, PERL_MAGIC_backref);
5519         }
5520         svp = &(mg->mg_obj);
5521     }
5522
5523     /* create or retrieve the array */
5524
5525     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
5526         || (*svp && SvTYPE(*svp) != SVt_PVAV)
5527     ) {
5528         /* create array */
5529         av = newAV();
5530         AvREAL_off(av);
5531         SvREFCNT_inc_simple_void(av);
5532         /* av now has a refcnt of 2; see discussion above */
5533         if (*svp) {
5534             /* move single existing backref to the array */
5535             av_extend(av, 1);
5536             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5537         }
5538         *svp = (SV*)av;
5539         if (mg)
5540             mg->mg_flags |= MGf_REFCOUNTED;
5541     }
5542     else
5543         av = MUTABLE_AV(*svp);
5544
5545     if (!av) {
5546         /* optimisation: store single backref directly in HvAUX or mg_obj */
5547         *svp = sv;
5548         return;
5549     }
5550     /* push new backref */
5551     assert(SvTYPE(av) == SVt_PVAV);
5552     if (AvFILLp(av) >= AvMAX(av)) {
5553         av_extend(av, AvFILLp(av)+1);
5554     }
5555     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5556 }
5557
5558 /* delete a back-reference to ourselves from the backref magic associated
5559  * with the SV we point to.
5560  */
5561
5562 void
5563 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5564 {
5565     dVAR;
5566     SV **svp = NULL;
5567
5568     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5569
5570     if (SvTYPE(tsv) == SVt_PVHV) {
5571         if (SvOOK(tsv))
5572             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5573     }
5574     else {
5575         MAGIC *const mg
5576             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5577         svp =  mg ? &(mg->mg_obj) : NULL;
5578     }
5579
5580     if (!svp)
5581         Perl_croak(aTHX_ "panic: del_backref, svp=0");
5582     if (!*svp) {
5583         /* It's possible that sv is being freed recursively part way through the
5584            freeing of tsv. If this happens, the backreferences array of tsv has
5585            already been freed, and so svp will be NULL. If this is the case,
5586            we should not panic. Instead, nothing needs doing, so return.  */
5587         if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
5588             return;
5589         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
5590                    *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
5591     }
5592
5593     if (SvTYPE(*svp) == SVt_PVAV) {
5594 #ifdef DEBUGGING
5595         int count = 1;
5596 #endif
5597         AV * const av = (AV*)*svp;
5598         SSize_t fill;
5599         assert(!SvIS_FREED(av));
5600         fill = AvFILLp(av);
5601         assert(fill > -1);
5602         svp = AvARRAY(av);
5603         /* for an SV with N weak references to it, if all those
5604          * weak refs are deleted, then sv_del_backref will be called
5605          * N times and O(N^2) compares will be done within the backref
5606          * array. To ameliorate this potential slowness, we:
5607          * 1) make sure this code is as tight as possible;
5608          * 2) when looking for SV, look for it at both the head and tail of the
5609          *    array first before searching the rest, since some create/destroy
5610          *    patterns will cause the backrefs to be freed in order.
5611          */
5612         if (*svp == sv) {
5613             AvARRAY(av)++;
5614             AvMAX(av)--;
5615         }
5616         else {
5617             SV **p = &svp[fill];
5618             SV *const topsv = *p;
5619             if (topsv != sv) {
5620 #ifdef DEBUGGING
5621                 count = 0;
5622 #endif
5623                 while (--p > svp) {
5624                     if (*p == sv) {
5625                         /* We weren't the last entry.
5626                            An unordered list has this property that you
5627                            can take the last element off the end to fill
5628                            the hole, and it's still an unordered list :-)
5629                         */
5630                         *p = topsv;
5631 #ifdef DEBUGGING
5632                         count++;
5633 #else
5634                         break; /* should only be one */
5635 #endif
5636                     }
5637                 }
5638             }
5639         }
5640         assert(count ==1);
5641         AvFILLp(av) = fill-1;
5642     }
5643     else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
5644         /* freed AV; skip */
5645     }
5646     else {
5647         /* optimisation: only a single backref, stored directly */
5648         if (*svp != sv)
5649             Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
5650         *svp = NULL;
5651     }
5652
5653 }
5654
5655 void
5656 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5657 {
5658     SV **svp;
5659     SV **last;
5660     bool is_array;
5661
5662     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5663
5664     if (!av)
5665         return;
5666
5667     /* after multiple passes through Perl_sv_clean_all() for a thinngy
5668      * that has badly leaked, the backref array may have gotten freed,
5669      * since we only protect it against 1 round of cleanup */
5670     if (SvIS_FREED(av)) {
5671         if (PL_in_clean_all) /* All is fair */
5672             return;
5673         Perl_croak(aTHX_
5674                    "panic: magic_killbackrefs (freed backref AV/SV)");
5675     }
5676
5677
5678     is_array = (SvTYPE(av) == SVt_PVAV);
5679     if (is_array) {
5680         assert(!SvIS_FREED(av));
5681         svp = AvARRAY(av);
5682         if (svp)
5683             last = svp + AvFILLp(av);
5684     }
5685     else {
5686         /* optimisation: only a single backref, stored directly */
5687         svp = (SV**)&av;
5688         last = svp;
5689     }
5690
5691     if (svp) {
5692         while (svp <= last) {
5693             if (*svp) {
5694                 SV *const referrer = *svp;
5695                 if (SvWEAKREF(referrer)) {
5696                     /* XXX Should we check that it hasn't changed? */
5697                     assert(SvROK(referrer));
5698                     SvRV_set(referrer, 0);
5699                     SvOK_off(referrer);
5700                     SvWEAKREF_off(referrer);
5701                     SvSETMAGIC(referrer);
5702                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5703                            SvTYPE(referrer) == SVt_PVLV) {
5704                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5705                     /* You lookin' at me?  */
5706                     assert(GvSTASH(referrer));
5707                     assert(GvSTASH(referrer) == (const HV *)sv);
5708                     GvSTASH(referrer) = 0;
5709                 } else if (SvTYPE(referrer) == SVt_PVCV ||
5710                            SvTYPE(referrer) == SVt_PVFM) {
5711                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5712                         /* You lookin' at me?  */
5713                         assert(CvSTASH(referrer));
5714                         assert(CvSTASH(referrer) == (const HV *)sv);
5715                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5716                     }
5717                     else {
5718                         assert(SvTYPE(sv) == SVt_PVGV);
5719                         /* You lookin' at me?  */
5720                         assert(CvGV(referrer));
5721                         assert(CvGV(referrer) == (const GV *)sv);
5722                         anonymise_cv_maybe(MUTABLE_GV(sv),
5723                                                 MUTABLE_CV(referrer));
5724                     }
5725
5726                 } else {
5727                     Perl_croak(aTHX_
5728                                "panic: magic_killbackrefs (flags=%"UVxf")",
5729                                (UV)SvFLAGS(referrer));
5730                 }
5731
5732                 if (is_array)
5733                     *svp = NULL;
5734             }
5735             svp++;
5736         }
5737     }
5738     if (is_array) {
5739         AvFILLp(av) = -1;
5740         SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5741     }
5742     return;
5743 }
5744
5745 /*
5746 =for apidoc sv_insert
5747
5748 Inserts a string at the specified offset/length within the SV.  Similar to
5749 the Perl substr() function.  Handles get magic.
5750
5751 =for apidoc sv_insert_flags
5752
5753 Same as C<sv_insert>, but the extra C<flags> are passed to the
5754 C<SvPV_force_flags> that applies to C<bigstr>.
5755
5756 =cut
5757 */
5758
5759 void
5760 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5761 {
5762     dVAR;
5763     register char *big;
5764     register char *mid;
5765     register char *midend;
5766     register char *bigend;
5767     register SSize_t i;         /* better be sizeof(STRLEN) or bad things happen */
5768     STRLEN curlen;
5769
5770     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5771
5772     if (!bigstr)
5773         Perl_croak(aTHX_ "Can't modify nonexistent substring");
5774     SvPV_force_flags(bigstr, curlen, flags);
5775     (void)SvPOK_only_UTF8(bigstr);
5776     if (offset + len > curlen) {
5777         SvGROW(bigstr, offset+len+1);
5778         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5779         SvCUR_set(bigstr, offset+len);
5780     }
5781
5782     SvTAINT(bigstr);
5783     i = littlelen - len;
5784     if (i > 0) {                        /* string might grow */
5785         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5786         mid = big + offset + len;
5787         midend = bigend = big + SvCUR(bigstr);
5788         bigend += i;
5789         *bigend = '\0';
5790         while (midend > mid)            /* shove everything down */
5791             *--bigend = *--midend;
5792         Move(little,big+offset,littlelen,char);
5793         SvCUR_set(bigstr, SvCUR(bigstr) + i);
5794         SvSETMAGIC(bigstr);
5795         return;
5796     }
5797     else if (i == 0) {
5798         Move(little,SvPVX(bigstr)+offset,len,char);
5799         SvSETMAGIC(bigstr);
5800         return;
5801     }
5802
5803     big = SvPVX(bigstr);
5804     mid = big + offset;
5805     midend = mid + len;
5806     bigend = big + SvCUR(bigstr);
5807
5808     if (midend > bigend)
5809         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
5810                    midend, bigend);
5811
5812     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5813         if (littlelen) {
5814             Move(little, mid, littlelen,char);
5815             mid += littlelen;
5816         }
5817         i = bigend - midend;
5818         if (i > 0) {
5819             Move(midend, mid, i,char);
5820             mid += i;
5821         }
5822         *mid = '\0';
5823         SvCUR_set(bigstr, mid - big);
5824     }
5825     else if ((i = mid - big)) { /* faster from front */
5826         midend -= littlelen;
5827         mid = midend;
5828         Move(big, midend - i, i, char);
5829         sv_chop(bigstr,midend-i);
5830         if (littlelen)
5831             Move(little, mid, littlelen,char);
5832     }
5833     else if (littlelen) {
5834         midend -= littlelen;
5835         sv_chop(bigstr,midend);
5836         Move(little,midend,littlelen,char);
5837     }
5838     else {
5839         sv_chop(bigstr,midend);
5840     }
5841     SvSETMAGIC(bigstr);
5842 }
5843
5844 /*
5845 =for apidoc sv_replace
5846
5847 Make the first argument a copy of the second, then delete the original.
5848 The target SV physically takes over ownership of the body of the source SV
5849 and inherits its flags; however, the target keeps any magic it owns,
5850 and any magic in the source is discarded.
5851 Note that this is a rather specialist SV copying operation; most of the
5852 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5853
5854 =cut
5855 */
5856
5857 void
5858 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5859 {
5860     dVAR;
5861     const U32 refcnt = SvREFCNT(sv);
5862
5863     PERL_ARGS_ASSERT_SV_REPLACE;
5864
5865     SV_CHECK_THINKFIRST_COW_DROP(sv);
5866     if (SvREFCNT(nsv) != 1) {
5867         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5868                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5869     }
5870     if (SvMAGICAL(sv)) {
5871         if (SvMAGICAL(nsv))
5872             mg_free(nsv);
5873         else
5874             sv_upgrade(nsv, SVt_PVMG);
5875         SvMAGIC_set(nsv, SvMAGIC(sv));
5876         SvFLAGS(nsv) |= SvMAGICAL(sv);
5877         SvMAGICAL_off(sv);
5878         SvMAGIC_set(sv, NULL);
5879     }
5880     SvREFCNT(sv) = 0;
5881     sv_clear(sv);
5882     assert(!SvREFCNT(sv));
5883 #ifdef DEBUG_LEAKING_SCALARS
5884     sv->sv_flags  = nsv->sv_flags;
5885     sv->sv_any    = nsv->sv_any;
5886     sv->sv_refcnt = nsv->sv_refcnt;
5887     sv->sv_u      = nsv->sv_u;
5888 #else
5889     StructCopy(nsv,sv,SV);
5890 #endif
5891     if(SvTYPE(sv) == SVt_IV) {
5892         SvANY(sv)
5893             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5894     }
5895
5896
5897 #ifdef PERL_OLD_COPY_ON_WRITE
5898     if (SvIsCOW_normal(nsv)) {
5899         /* We need to follow the pointers around the loop to make the
5900            previous SV point to sv, rather than nsv.  */
5901         SV *next;
5902         SV *current = nsv;
5903         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5904             assert(next);
5905             current = next;
5906             assert(SvPVX_const(current) == SvPVX_const(nsv));
5907         }
5908         /* Make the SV before us point to the SV after us.  */
5909         if (DEBUG_C_TEST) {
5910             PerlIO_printf(Perl_debug_log, "previous is\n");
5911             sv_dump(current);
5912             PerlIO_printf(Perl_debug_log,
5913                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5914                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5915         }
5916         SV_COW_NEXT_SV_SET(current, sv);
5917     }
5918 #endif
5919     SvREFCNT(sv) = refcnt;
5920     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5921     SvREFCNT(nsv) = 0;
5922     del_SV(nsv);
5923 }
5924
5925 /* We're about to free a GV which has a CV that refers back to us.
5926  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5927  * field) */
5928
5929 STATIC void
5930 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5931 {
5932     SV *gvname;
5933     GV *anongv;
5934
5935     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5936
5937     /* be assertive! */
5938     assert(SvREFCNT(gv) == 0);
5939     assert(isGV(gv) && isGV_with_GP(gv));
5940     assert(GvGP(gv));
5941     assert(!CvANON(cv));
5942     assert(CvGV(cv) == gv);
5943
5944     /* will the CV shortly be freed by gp_free() ? */
5945     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
5946         SvANY(cv)->xcv_gv = NULL;
5947         return;
5948     }
5949
5950     /* if not, anonymise: */
5951     gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
5952                     ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
5953                     : newSVpvn_flags( "__ANON__", 8, 0 );
5954     sv_catpvs(gvname, "::__ANON__");
5955     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
5956     SvREFCNT_dec(gvname);
5957
5958     CvANON_on(cv);
5959     CvCVGV_RC_on(cv);
5960     SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
5961 }
5962
5963
5964 /*
5965 =for apidoc sv_clear
5966
5967 Clear an SV: call any destructors, free up any memory used by the body,
5968 and free the body itself.  The SV's head is I<not> freed, although
5969 its type is set to all 1's so that it won't inadvertently be assumed
5970 to be live during global destruction etc.
5971 This function should only be called when REFCNT is zero.  Most of the time
5972 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5973 instead.
5974
5975 =cut
5976 */
5977
5978 void
5979 Perl_sv_clear(pTHX_ SV *const orig_sv)
5980 {
5981     dVAR;
5982     HV *stash;
5983     U32 type;
5984     const struct body_details *sv_type_details;
5985     SV* iter_sv = NULL;
5986     SV* next_sv = NULL;
5987     register SV *sv = orig_sv;
5988     STRLEN hash_index;
5989
5990     PERL_ARGS_ASSERT_SV_CLEAR;
5991
5992     /* within this loop, sv is the SV currently being freed, and
5993      * iter_sv is the most recent AV or whatever that's being iterated
5994      * over to provide more SVs */
5995
5996     while (sv) {
5997
5998         type = SvTYPE(sv);
5999
6000         assert(SvREFCNT(sv) == 0);
6001         assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6002
6003         if (type <= SVt_IV) {
6004             /* See the comment in sv.h about the collusion between this
6005              * early return and the overloading of the NULL slots in the
6006              * size table.  */
6007             if (SvROK(sv))
6008                 goto free_rv;
6009             SvFLAGS(sv) &= SVf_BREAK;
6010             SvFLAGS(sv) |= SVTYPEMASK;
6011             goto free_head;
6012         }
6013
6014         assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6015
6016         if (type >= SVt_PVMG) {
6017             if (SvOBJECT(sv)) {
6018                 if (!curse(sv, 1)) goto get_next_sv;
6019                 type = SvTYPE(sv); /* destructor may have changed it */
6020             }
6021             /* Free back-references before magic, in case the magic calls
6022              * Perl code that has weak references to sv. */
6023             if (type == SVt_PVHV) {
6024                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6025                 if (SvMAGIC(sv))
6026                     mg_free(sv);
6027             }
6028             else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6029                 SvREFCNT_dec(SvOURSTASH(sv));
6030             } else if (SvMAGIC(sv)) {
6031                 /* Free back-references before other types of magic. */
6032                 sv_unmagic(sv, PERL_MAGIC_backref);
6033                 mg_free(sv);
6034             }
6035             if (type == SVt_PVMG && SvPAD_TYPED(sv))
6036                 SvREFCNT_dec(SvSTASH(sv));
6037         }
6038         switch (type) {
6039             /* case SVt_BIND: */
6040         case SVt_PVIO:
6041             if (IoIFP(sv) &&
6042                 IoIFP(sv) != PerlIO_stdin() &&
6043                 IoIFP(sv) != PerlIO_stdout() &&
6044                 IoIFP(sv) != PerlIO_stderr() &&
6045                 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6046             {
6047                 io_close(MUTABLE_IO(sv), FALSE);
6048             }
6049             if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6050                 PerlDir_close(IoDIRP(sv));
6051             IoDIRP(sv) = (DIR*)NULL;
6052             Safefree(IoTOP_NAME(sv));
6053             Safefree(IoFMT_NAME(sv));
6054             Safefree(IoBOTTOM_NAME(sv));
6055             if ((const GV *)sv == PL_statgv)
6056                 PL_statgv = NULL;
6057             goto freescalar;
6058         case SVt_REGEXP:
6059             /* FIXME for plugins */
6060             pregfree2((REGEXP*) sv);
6061             goto freescalar;
6062         case SVt_PVCV:
6063         case SVt_PVFM:
6064             cv_undef(MUTABLE_CV(sv));
6065             /* If we're in a stash, we don't own a reference to it.
6066              * However it does have a back reference to us, which needs to
6067              * be cleared.  */
6068             if ((stash = CvSTASH(sv)))
6069                 sv_del_backref(MUTABLE_SV(stash), sv);
6070             goto freescalar;
6071         case SVt_PVHV:
6072             if (PL_last_swash_hv == (const HV *)sv) {
6073                 PL_last_swash_hv = NULL;
6074             }
6075             if (HvTOTALKEYS((HV*)sv) > 0) {
6076                 const char *name;
6077                 /* this statement should match the one at the beginning of
6078                  * hv_undef_flags() */
6079                 if (   PL_phase != PERL_PHASE_DESTRUCT
6080                     && (name = HvNAME((HV*)sv)))
6081                 {
6082                     if (PL_stashcache)
6083                         (void)hv_delete(PL_stashcache, name,
6084                             HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD);
6085                     hv_name_set((HV*)sv, NULL, 0, 0);
6086                 }
6087
6088                 /* save old iter_sv in unused SvSTASH field */
6089                 assert(!SvOBJECT(sv));
6090                 SvSTASH(sv) = (HV*)iter_sv;
6091                 iter_sv = sv;
6092
6093                 /* XXX ideally we should save the old value of hash_index
6094                  * too, but I can't think of any place to hide it. The
6095                  * effect of not saving it is that for freeing hashes of
6096                  * hashes, we become quadratic in scanning the HvARRAY of
6097                  * the top hash looking for new entries to free; but
6098                  * hopefully this will be dwarfed by the freeing of all
6099                  * the nested hashes. */
6100                 hash_index = 0;
6101                 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6102                 goto get_next_sv; /* process this new sv */
6103             }
6104             /* free empty hash */
6105             Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6106             assert(!HvARRAY((HV*)sv));
6107             break;
6108         case SVt_PVAV:
6109             {
6110                 AV* av = MUTABLE_AV(sv);
6111                 if (PL_comppad == av) {
6112                     PL_comppad = NULL;
6113                     PL_curpad = NULL;
6114                 }
6115                 if (AvREAL(av) && AvFILLp(av) > -1) {
6116                     next_sv = AvARRAY(av)[AvFILLp(av)--];
6117                     /* save old iter_sv in top-most slot of AV,
6118                      * and pray that it doesn't get wiped in the meantime */
6119                     AvARRAY(av)[AvMAX(av)] = iter_sv;
6120                     iter_sv = sv;
6121                     goto get_next_sv; /* process this new sv */
6122                 }
6123                 Safefree(AvALLOC(av));
6124             }
6125
6126             break;
6127         case SVt_PVLV:
6128             if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6129                 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6130                 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6131                 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6132             }
6133             else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
6134                 SvREFCNT_dec(LvTARG(sv));
6135         case SVt_PVGV:
6136             if (isGV_with_GP(sv)) {
6137                 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6138                    && HvENAME_get(stash))
6139                     mro_method_changed_in(stash);
6140                 gp_free(MUTABLE_GV(sv));
6141                 if (GvNAME_HEK(sv))
6142                     unshare_hek(GvNAME_HEK(sv));
6143                 /* If we're in a stash, we don't own a reference to it.
6144                  * However it does have a back reference to us, which
6145                  * needs to be cleared.  */
6146                 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6147                         sv_del_backref(MUTABLE_SV(stash), sv);
6148             }
6149             /* FIXME. There are probably more unreferenced pointers to SVs
6150              * in the interpreter struct that we should check and tidy in
6151              * a similar fashion to this:  */
6152             /* See also S_sv_unglob, which does the same thing. */
6153             if ((const GV *)sv == PL_last_in_gv)
6154                 PL_last_in_gv = NULL;
6155             else if ((const GV *)sv == PL_statgv)
6156                 PL_statgv = NULL;
6157         case SVt_PVMG:
6158         case SVt_PVNV:
6159         case SVt_PVIV:
6160         case SVt_PV:
6161           freescalar:
6162             /* Don't bother with SvOOK_off(sv); as we're only going to
6163              * free it.  */
6164             if (SvOOK(sv)) {
6165                 STRLEN offset;
6166                 SvOOK_offset(sv, offset);
6167                 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6168                 /* Don't even bother with turning off the OOK flag.  */
6169             }
6170             if (SvROK(sv)) {
6171             free_rv:
6172                 {
6173                     SV * const target = SvRV(sv);
6174                     if (SvWEAKREF(sv))
6175                         sv_del_backref(target, sv);
6176                     else
6177                         next_sv = target;
6178                 }
6179             }
6180 #ifdef PERL_OLD_COPY_ON_WRITE
6181             else if (SvPVX_const(sv)
6182                      && !(SvTYPE(sv) == SVt_PVIO
6183                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6184             {
6185                 if (SvIsCOW(sv)) {
6186                     if (DEBUG_C_TEST) {
6187                         PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6188                         sv_dump(sv);
6189                     }
6190                     if (SvLEN(sv)) {
6191                         sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6192                     } else {
6193                         unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6194                     }
6195
6196                     SvFAKE_off(sv);
6197                 } else if (SvLEN(sv)) {
6198                     Safefree(SvPVX_const(sv));
6199                 }
6200             }
6201 #else
6202             else if (SvPVX_const(sv) && SvLEN(sv)
6203                      && !(SvTYPE(sv) == SVt_PVIO
6204                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6205                 Safefree(SvPVX_mutable(sv));
6206             else if (SvPVX_const(sv) && SvIsCOW(sv)) {
6207                 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6208                 SvFAKE_off(sv);
6209             }
6210 #endif
6211             break;
6212         case SVt_NV:
6213             break;
6214         }
6215
6216       free_body:
6217
6218         SvFLAGS(sv) &= SVf_BREAK;
6219         SvFLAGS(sv) |= SVTYPEMASK;
6220
6221         sv_type_details = bodies_by_type + type;
6222         if (sv_type_details->arena) {
6223             del_body(((char *)SvANY(sv) + sv_type_details->offset),
6224                      &PL_body_roots[type]);
6225         }
6226         else if (sv_type_details->body_size) {
6227             safefree(SvANY(sv));
6228         }
6229
6230       free_head:
6231         /* caller is responsible for freeing the head of the original sv */
6232         if (sv != orig_sv && !SvREFCNT(sv))
6233             del_SV(sv);
6234
6235         /* grab and free next sv, if any */
6236       get_next_sv:
6237         while (1) {
6238             sv = NULL;
6239             if (next_sv) {
6240                 sv = next_sv;
6241                 next_sv = NULL;
6242             }
6243             else if (!iter_sv) {
6244                 break;
6245             } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6246                 AV *const av = (AV*)iter_sv;
6247                 if (AvFILLp(av) > -1) {
6248                     sv = AvARRAY(av)[AvFILLp(av)--];
6249                 }
6250                 else { /* no more elements of current AV to free */
6251                     sv = iter_sv;
6252                     type = SvTYPE(sv);
6253                     /* restore previous value, squirrelled away */
6254                     iter_sv = AvARRAY(av)[AvMAX(av)];
6255                     Safefree(AvALLOC(av));
6256                     goto free_body;
6257                 }
6258             } else if (SvTYPE(iter_sv) == SVt_PVHV) {
6259                 sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
6260                 if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
6261                     /* no more elements of current HV to free */
6262                     sv = iter_sv;
6263                     type = SvTYPE(sv);
6264                     /* Restore previous value of iter_sv, squirrelled away */
6265                     assert(!SvOBJECT(sv));
6266                     iter_sv = (SV*)SvSTASH(sv);
6267
6268                     /* ideally we should restore the old hash_index here,
6269                      * but we don't currently save the old value */
6270                     hash_index = 0;
6271
6272                     /* free any remaining detritus from the hash struct */
6273                     Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6274                     assert(!HvARRAY((HV*)sv));
6275                     goto free_body;
6276                 }
6277             }
6278
6279             /* unrolled SvREFCNT_dec and sv_free2 follows: */
6280
6281             if (!sv)
6282                 continue;
6283             if (!SvREFCNT(sv)) {
6284                 sv_free(sv);
6285                 continue;
6286             }
6287             if (--(SvREFCNT(sv)))
6288                 continue;
6289 #ifdef DEBUGGING
6290             if (SvTEMP(sv)) {
6291                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6292                          "Attempt to free temp prematurely: SV 0x%"UVxf
6293                          pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6294                 continue;
6295             }
6296 #endif
6297             if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6298                 /* make sure SvREFCNT(sv)==0 happens very seldom */
6299                 SvREFCNT(sv) = (~(U32)0)/2;
6300                 continue;
6301             }
6302             break;
6303         } /* while 1 */
6304
6305     } /* while sv */
6306 }
6307
6308 /* This routine curses the sv itself, not the object referenced by sv. So
6309    sv does not have to be ROK. */
6310
6311 static bool
6312 S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
6313     dVAR;
6314
6315     PERL_ARGS_ASSERT_CURSE;
6316     assert(SvOBJECT(sv));
6317
6318     if (PL_defstash &&  /* Still have a symbol table? */
6319         SvDESTROYABLE(sv))
6320     {
6321         dSP;
6322         HV* stash;
6323         do {
6324             CV* destructor;
6325             stash = SvSTASH(sv);
6326             destructor = StashHANDLER(stash,DESTROY);
6327             if (destructor
6328                 /* A constant subroutine can have no side effects, so
6329                    don't bother calling it.  */
6330                 && !CvCONST(destructor)
6331                 /* Don't bother calling an empty destructor or one that
6332                    returns immediately. */
6333                 && (CvISXSUB(destructor)
6334                 || (CvSTART(destructor)
6335                     && (CvSTART(destructor)->op_next->op_type
6336                                         != OP_LEAVESUB)
6337                     && (CvSTART(destructor)->op_next->op_type
6338                                         != OP_PUSHMARK
6339                         || CvSTART(destructor)->op_next->op_next->op_type
6340                                         != OP_RETURN
6341                        )
6342                    ))
6343                )
6344             {
6345                 SV* const tmpref = newRV(sv);
6346                 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
6347                 ENTER;
6348                 PUSHSTACKi(PERLSI_DESTROY);
6349                 EXTEND(SP, 2);
6350                 PUSHMARK(SP);
6351                 PUSHs(tmpref);
6352                 PUTBACK;
6353                 call_sv(MUTABLE_SV(destructor),
6354                             G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6355                 POPSTACK;
6356                 SPAGAIN;
6357                 LEAVE;
6358                 if(SvREFCNT(tmpref) < 2) {
6359                     /* tmpref is not kept alive! */
6360                     SvREFCNT(sv)--;
6361                     SvRV_set(tmpref, NULL);
6362                     SvROK_off(tmpref);
6363                 }
6364                 SvREFCNT_dec(tmpref);
6365             }
6366         } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
6367
6368
6369         if (check_refcnt && SvREFCNT(sv)) {
6370             if (PL_in_clean_objs)
6371                 Perl_croak(aTHX_
6372                   "DESTROY created new reference to dead object '%"HEKf"'",
6373                    HEKfARG(HvNAME_HEK(stash)));
6374             /* DESTROY gave object new lease on life */
6375             return FALSE;
6376         }
6377     }
6378
6379     if (SvOBJECT(sv)) {
6380         SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
6381         SvOBJECT_off(sv);       /* Curse the object. */
6382         if (SvTYPE(sv) != SVt_PVIO)
6383             --PL_sv_objcount;/* XXX Might want something more general */
6384     }
6385     return TRUE;
6386 }
6387
6388 /*
6389 =for apidoc sv_newref
6390
6391 Increment an SV's reference count.  Use the C<SvREFCNT_inc()> wrapper
6392 instead.
6393
6394 =cut
6395 */
6396
6397 SV *
6398 Perl_sv_newref(pTHX_ SV *const sv)
6399 {
6400     PERL_UNUSED_CONTEXT;
6401     if (sv)
6402         (SvREFCNT(sv))++;
6403     return sv;
6404 }
6405
6406 /*
6407 =for apidoc sv_free
6408
6409 Decrement an SV's reference count, and if it drops to zero, call
6410 C<sv_clear> to invoke destructors and free up any memory used by
6411 the body; finally, deallocate the SV's head itself.
6412 Normally called via a wrapper macro C<SvREFCNT_dec>.
6413
6414 =cut
6415 */
6416
6417 void
6418 Perl_sv_free(pTHX_ SV *const sv)
6419 {
6420     dVAR;
6421     if (!sv)
6422         return;
6423     if (SvREFCNT(sv) == 0) {
6424         if (SvFLAGS(sv) & SVf_BREAK)
6425             /* this SV's refcnt has been artificially decremented to
6426              * trigger cleanup */
6427             return;
6428         if (PL_in_clean_all) /* All is fair */
6429             return;
6430         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6431             /* make sure SvREFCNT(sv)==0 happens very seldom */
6432             SvREFCNT(sv) = (~(U32)0)/2;
6433             return;
6434         }
6435         if (ckWARN_d(WARN_INTERNAL)) {
6436 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6437             Perl_dump_sv_child(aTHX_ sv);
6438 #else
6439   #ifdef DEBUG_LEAKING_SCALARS
6440             sv_dump(sv);
6441   #endif
6442 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6443             if (PL_warnhook == PERL_WARNHOOK_FATAL
6444                 || ckDEAD(packWARN(WARN_INTERNAL))) {
6445                 /* Don't let Perl_warner cause us to escape our fate:  */
6446                 abort();
6447             }
6448 #endif
6449             /* This may not return:  */
6450             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6451                         "Attempt to free unreferenced scalar: SV 0x%"UVxf
6452                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6453 #endif
6454         }
6455 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6456         abort();
6457 #endif
6458         return;
6459     }
6460     if (--(SvREFCNT(sv)) > 0)
6461         return;
6462     Perl_sv_free2(aTHX_ sv);
6463 }
6464
6465 void
6466 Perl_sv_free2(pTHX_ SV *const sv)
6467 {
6468     dVAR;
6469
6470     PERL_ARGS_ASSERT_SV_FREE2;
6471
6472 #ifdef DEBUGGING
6473     if (SvTEMP(sv)) {
6474         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6475                          "Attempt to free temp prematurely: SV 0x%"UVxf
6476                          pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6477         return;
6478     }
6479 #endif
6480     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6481         /* make sure SvREFCNT(sv)==0 happens very seldom */
6482         SvREFCNT(sv) = (~(U32)0)/2;
6483         return;
6484     }
6485     sv_clear(sv);
6486     if (! SvREFCNT(sv))
6487         del_SV(sv);
6488 }
6489
6490 /*
6491 =for apidoc sv_len
6492
6493 Returns the length of the string in the SV.  Handles magic and type
6494 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6495
6496 =cut
6497 */
6498
6499 STRLEN
6500 Perl_sv_len(pTHX_ register SV *const sv)
6501 {
6502     STRLEN len;
6503
6504     if (!sv)
6505         return 0;
6506
6507     if (SvGMAGICAL(sv))
6508         len = mg_length(sv);
6509     else
6510         (void)SvPV_const(sv, len);
6511     return len;
6512 }
6513
6514 /*
6515 =for apidoc sv_len_utf8
6516
6517 Returns the number of characters in the string in an SV, counting wide
6518 UTF-8 bytes as a single character.  Handles magic and type coercion.
6519
6520 =cut
6521 */
6522
6523 /*
6524  * The length is cached in PERL_MAGIC_utf8, in the mg_len field.  Also the
6525  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6526  * (Note that the mg_len is not the length of the mg_ptr field.
6527  * This allows the cache to store the character length of the string without
6528  * needing to malloc() extra storage to attach to the mg_ptr.)
6529  *
6530  */
6531
6532 STRLEN
6533 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6534 {
6535     if (!sv)
6536         return 0;
6537
6538     if (SvGMAGICAL(sv))
6539         return mg_length(sv);
6540     else
6541     {
6542         STRLEN len;
6543         const U8 *s = (U8*)SvPV_const(sv, len);
6544
6545         if (PL_utf8cache) {
6546             STRLEN ulen;
6547             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6548
6549             if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6550                 if (mg->mg_len != -1)
6551                     ulen = mg->mg_len;
6552                 else {
6553                     /* We can use the offset cache for a headstart.
6554                        The longer value is stored in the first pair.  */
6555                     STRLEN *cache = (STRLEN *) mg->mg_ptr;
6556
6557                     ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6558                                                        s + len);
6559                 }
6560
6561                 if (PL_utf8cache < 0) {
6562                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6563                     assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6564                 }
6565             }
6566             else {
6567                 ulen = Perl_utf8_length(aTHX_ s, s + len);
6568                 utf8_mg_len_cache_update(sv, &mg, ulen);
6569             }
6570             return ulen;
6571         }
6572         return Perl_utf8_length(aTHX_ s, s + len);
6573     }
6574 }
6575
6576 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6577    offset.  */
6578 static STRLEN
6579 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6580                       STRLEN *const uoffset_p, bool *const at_end)
6581 {
6582     const U8 *s = start;
6583     STRLEN uoffset = *uoffset_p;
6584
6585     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6586
6587     while (s < send && uoffset) {
6588         --uoffset;
6589         s += UTF8SKIP(s);
6590     }
6591     if (s == send) {
6592         *at_end = TRUE;
6593     }
6594     else if (s > send) {
6595         *at_end = TRUE;
6596         /* This is the existing behaviour. Possibly it should be a croak, as
6597            it's actually a bounds error  */
6598         s = send;
6599     }
6600     *uoffset_p -= uoffset;
6601     return s - start;
6602 }
6603
6604 /* Given the length of the string in both bytes and UTF-8 characters, decide
6605    whether to walk forwards or backwards to find the byte corresponding to
6606    the passed in UTF-8 offset.  */
6607 static STRLEN
6608 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6609                     STRLEN uoffset, const STRLEN uend)
6610 {
6611     STRLEN backw = uend - uoffset;
6612
6613     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6614
6615     if (uoffset < 2 * backw) {
6616         /* The assumption is that going forwards is twice the speed of going
6617            forward (that's where the 2 * backw comes from).
6618            (The real figure of course depends on the UTF-8 data.)  */
6619         const U8 *s = start;
6620
6621         while (s < send && uoffset--)
6622             s += UTF8SKIP(s);
6623         assert (s <= send);
6624         if (s > send)
6625             s = send;
6626         return s - start;
6627     }
6628
6629     while (backw--) {
6630         send--;
6631         while (UTF8_IS_CONTINUATION(*send))
6632             send--;
6633     }
6634     return send - start;
6635 }
6636
6637 /* For the string representation of the given scalar, find the byte
6638    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
6639    give another position in the string, *before* the sought offset, which
6640    (which is always true, as 0, 0 is a valid pair of positions), which should
6641    help reduce the amount of linear searching.
6642    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6643    will be used to reduce the amount of linear searching. The cache will be
6644    created if necessary, and the found value offered to it for update.  */
6645 static STRLEN
6646 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6647                     const U8 *const send, STRLEN uoffset,
6648                     STRLEN uoffset0, STRLEN boffset0)
6649 {
6650     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
6651     bool found = FALSE;
6652     bool at_end = FALSE;
6653
6654     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6655
6656     assert (uoffset >= uoffset0);
6657
6658     if (!uoffset)
6659         return 0;
6660
6661     if (!SvREADONLY(sv)
6662         && PL_utf8cache
6663         && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6664                      (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6665         if ((*mgp)->mg_ptr) {
6666             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6667             if (cache[0] == uoffset) {
6668                 /* An exact match. */
6669                 return cache[1];
6670             }
6671             if (cache[2] == uoffset) {
6672                 /* An exact match. */
6673                 return cache[3];
6674             }
6675
6676             if (cache[0] < uoffset) {
6677                 /* The cache already knows part of the way.   */
6678                 if (cache[0] > uoffset0) {
6679                     /* The cache knows more than the passed in pair  */
6680                     uoffset0 = cache[0];
6681                     boffset0 = cache[1];
6682                 }
6683                 if ((*mgp)->mg_len != -1) {
6684                     /* And we know the end too.  */
6685                     boffset = boffset0
6686                         + sv_pos_u2b_midway(start + boffset0, send,
6687                                               uoffset - uoffset0,
6688                                               (*mgp)->mg_len - uoffset0);
6689                 } else {
6690                     uoffset -= uoffset0;
6691                     boffset = boffset0
6692                         + sv_pos_u2b_forwards(start + boffset0,
6693                                               send, &uoffset, &at_end);
6694                     uoffset += uoffset0;
6695                 }
6696             }
6697             else if (cache[2] < uoffset) {
6698                 /* We're between the two cache entries.  */
6699                 if (cache[2] > uoffset0) {
6700                     /* and the cache knows more than the passed in pair  */
6701                     uoffset0 = cache[2];
6702                     boffset0 = cache[3];
6703                 }
6704
6705                 boffset = boffset0
6706                     + sv_pos_u2b_midway(start + boffset0,
6707                                           start + cache[1],
6708                                           uoffset - uoffset0,
6709                                           cache[0] - uoffset0);
6710             } else {
6711                 boffset = boffset0
6712                     + sv_pos_u2b_midway(start + boffset0,
6713                                           start + cache[3],
6714                                           uoffset - uoffset0,
6715                                           cache[2] - uoffset0);
6716             }
6717             found = TRUE;
6718         }
6719         else if ((*mgp)->mg_len != -1) {
6720             /* If we can take advantage of a passed in offset, do so.  */
6721             /* In fact, offset0 is either 0, or less than offset, so don't
6722                need to worry about the other possibility.  */
6723             boffset = boffset0
6724                 + sv_pos_u2b_midway(start + boffset0, send,
6725                                       uoffset - uoffset0,
6726                                       (*mgp)->mg_len - uoffset0);
6727             found = TRUE;
6728         }
6729     }
6730
6731     if (!found || PL_utf8cache < 0) {
6732         STRLEN real_boffset;
6733         uoffset -= uoffset0;
6734         real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6735                                                       send, &uoffset, &at_end);
6736         uoffset += uoffset0;
6737
6738         if (found && PL_utf8cache < 0)
6739             assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6740                                        real_boffset, sv);
6741         boffset = real_boffset;
6742     }
6743
6744     if (PL_utf8cache) {
6745         if (at_end)
6746             utf8_mg_len_cache_update(sv, mgp, uoffset);
6747         else
6748             utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6749     }
6750     return boffset;
6751 }
6752
6753
6754 /*
6755 =for apidoc sv_pos_u2b_flags
6756
6757 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6758 the start of the string, to a count of the equivalent number of bytes; if
6759 lenp is non-zero, it does the same to lenp, but this time starting from
6760 the offset, rather than from the start
6761 of the string.  Handles type coercion.
6762 I<flags> is passed to C<SvPV_flags>, and usually should be
6763 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6764
6765 =cut
6766 */
6767
6768 /*
6769  * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6770  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6771  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6772  *
6773  */
6774
6775 STRLEN
6776 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6777                       U32 flags)
6778 {
6779     const U8 *start;
6780     STRLEN len;
6781     STRLEN boffset;
6782
6783     PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6784
6785     start = (U8*)SvPV_flags(sv, len, flags);
6786     if (len) {
6787         const U8 * const send = start + len;
6788         MAGIC *mg = NULL;
6789         boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6790
6791         if (lenp
6792             && *lenp /* don't bother doing work for 0, as its bytes equivalent
6793                         is 0, and *lenp is already set to that.  */) {
6794             /* Convert the relative offset to absolute.  */
6795             const STRLEN uoffset2 = uoffset + *lenp;
6796             const STRLEN boffset2
6797                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6798                                       uoffset, boffset) - boffset;
6799
6800             *lenp = boffset2;
6801         }
6802     } else {
6803         if (lenp)
6804             *lenp = 0;
6805         boffset = 0;
6806     }
6807
6808     return boffset;
6809 }
6810
6811 /*
6812 =for apidoc sv_pos_u2b
6813
6814 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6815 the start of the string, to a count of the equivalent number of bytes; if
6816 lenp is non-zero, it does the same to lenp, but this time starting from
6817 the offset, rather than from the start of the string.  Handles magic and
6818 type coercion.
6819
6820 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6821 than 2Gb.
6822
6823 =cut
6824 */
6825
6826 /*
6827  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6828  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6829  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6830  *
6831  */
6832
6833 /* This function is subject to size and sign problems */
6834
6835 void
6836 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6837 {
6838     PERL_ARGS_ASSERT_SV_POS_U2B;
6839
6840     if (lenp) {
6841         STRLEN ulen = (STRLEN)*lenp;
6842         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6843                                          SV_GMAGIC|SV_CONST_RETURN);
6844         *lenp = (I32)ulen;
6845     } else {
6846         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6847                                          SV_GMAGIC|SV_CONST_RETURN);
6848     }
6849 }
6850
6851 static void
6852 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6853                            const STRLEN ulen)
6854 {
6855     PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6856     if (SvREADONLY(sv))
6857         return;
6858
6859     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6860                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6861         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6862     }
6863     assert(*mgp);
6864
6865     (*mgp)->mg_len = ulen;
6866     /* For now, treat "overflowed" as "still unknown". See RT #72924.  */
6867     if (ulen != (STRLEN) (*mgp)->mg_len)
6868         (*mgp)->mg_len = -1;
6869 }
6870
6871 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6872    byte length pairing. The (byte) length of the total SV is passed in too,
6873    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6874    may not have updated SvCUR, so we can't rely on reading it directly.
6875
6876    The proffered utf8/byte length pairing isn't used if the cache already has
6877    two pairs, and swapping either for the proffered pair would increase the
6878    RMS of the intervals between known byte offsets.
6879
6880    The cache itself consists of 4 STRLEN values
6881    0: larger UTF-8 offset
6882    1: corresponding byte offset
6883    2: smaller UTF-8 offset
6884    3: corresponding byte offset
6885
6886    Unused cache pairs have the value 0, 0.
6887    Keeping the cache "backwards" means that the invariant of
6888    cache[0] >= cache[2] is maintained even with empty slots, which means that
6889    the code that uses it doesn't need to worry if only 1 entry has actually
6890    been set to non-zero.  It also makes the "position beyond the end of the
6891    cache" logic much simpler, as the first slot is always the one to start
6892    from.
6893 */
6894 static void
6895 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6896                            const STRLEN utf8, const STRLEN blen)
6897 {
6898     STRLEN *cache;
6899
6900     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6901
6902     if (SvREADONLY(sv))
6903         return;
6904
6905     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6906                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6907         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6908                            0);
6909         (*mgp)->mg_len = -1;
6910     }
6911     assert(*mgp);
6912
6913     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6914         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6915         (*mgp)->mg_ptr = (char *) cache;
6916     }
6917     assert(cache);
6918
6919     if (PL_utf8cache < 0 && SvPOKp(sv)) {
6920         /* SvPOKp() because it's possible that sv has string overloading, and
6921            therefore is a reference, hence SvPVX() is actually a pointer.
6922            This cures the (very real) symptoms of RT 69422, but I'm not actually
6923            sure whether we should even be caching the results of UTF-8
6924            operations on overloading, given that nothing stops overloading
6925            returning a different value every time it's called.  */
6926         const U8 *start = (const U8 *) SvPVX_const(sv);
6927         const STRLEN realutf8 = utf8_length(start, start + byte);
6928
6929         assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6930                                    sv);
6931     }
6932
6933     /* Cache is held with the later position first, to simplify the code
6934        that deals with unbounded ends.  */
6935
6936     ASSERT_UTF8_CACHE(cache);
6937     if (cache[1] == 0) {
6938         /* Cache is totally empty  */
6939         cache[0] = utf8;
6940         cache[1] = byte;
6941     } else if (cache[3] == 0) {
6942         if (byte > cache[1]) {
6943             /* New one is larger, so goes first.  */
6944             cache[2] = cache[0];
6945             cache[3] = cache[1];
6946             cache[0] = utf8;
6947             cache[1] = byte;
6948         } else {
6949             cache[2] = utf8;
6950             cache[3] = byte;
6951         }
6952     } else {
6953 #define THREEWAY_SQUARE(a,b,c,d) \
6954             ((float)((d) - (c))) * ((float)((d) - (c))) \
6955             + ((float)((c) - (b))) * ((float)((c) - (b))) \
6956                + ((float)((b) - (a))) * ((float)((b) - (a)))
6957
6958         /* Cache has 2 slots in use, and we know three potential pairs.
6959            Keep the two that give the lowest RMS distance. Do the
6960            calculation in bytes simply because we always know the byte
6961            length.  squareroot has the same ordering as the positive value,
6962            so don't bother with the actual square root.  */
6963         const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6964         if (byte > cache[1]) {
6965             /* New position is after the existing pair of pairs.  */
6966             const float keep_earlier
6967                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6968             const float keep_later
6969                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6970
6971             if (keep_later < keep_earlier) {
6972                 if (keep_later < existing) {
6973                     cache[2] = cache[0];
6974                     cache[3] = cache[1];
6975                     cache[0] = utf8;
6976                     cache[1] = byte;
6977                 }
6978             }
6979             else {
6980                 if (keep_earlier < existing) {
6981                     cache[0] = utf8;
6982                     cache[1] = byte;
6983                 }
6984             }
6985         }
6986         else if (byte > cache[3]) {
6987             /* New position is between the existing pair of pairs.  */
6988             const float keep_earlier
6989                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6990             const float keep_later
6991                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6992
6993             if (keep_later < keep_earlier) {
6994                 if (keep_later < existing) {
6995                     cache[2] = utf8;
6996                     cache[3] = byte;
6997                 }
6998             }
6999             else {
7000                 if (keep_earlier < existing) {
7001                     cache[0] = utf8;
7002                     cache[1] = byte;
7003                 }
7004             }
7005         }
7006         else {
7007             /* New position is before the existing pair of pairs.  */
7008             const float keep_earlier
7009                 = THREEWAY_SQUARE(0, byte, cache[3], blen);
7010             const float keep_later
7011                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7012
7013             if (keep_later < keep_earlier) {
7014                 if (keep_later < existing) {
7015                     cache[2] = utf8;
7016                     cache[3] = byte;
7017                 }
7018             }
7019             else {
7020                 if (keep_earlier < existing) {
7021                     cache[0] = cache[2];
7022                     cache[1] = cache[3];
7023                     cache[2] = utf8;
7024                     cache[3] = byte;
7025                 }
7026             }
7027         }
7028     }
7029     ASSERT_UTF8_CACHE(cache);
7030 }
7031
7032 /* We already know all of the way, now we may be able to walk back.  The same
7033    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
7034    backward is half the speed of walking forward. */
7035 static STRLEN
7036 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
7037                     const U8 *end, STRLEN endu)
7038 {
7039     const STRLEN forw = target - s;
7040     STRLEN backw = end - target;
7041
7042     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
7043
7044     if (forw < 2 * backw) {
7045         return utf8_length(s, target);
7046     }
7047
7048     while (end > target) {
7049         end--;
7050         while (UTF8_IS_CONTINUATION(*end)) {
7051             end--;
7052         }
7053         endu--;
7054     }
7055     return endu;
7056 }
7057
7058 /*
7059 =for apidoc sv_pos_b2u
7060
7061 Converts the value pointed to by offsetp from a count of bytes from the
7062 start of the string, to a count of the equivalent number of UTF-8 chars.
7063 Handles magic and type coercion.
7064
7065 =cut
7066 */
7067
7068 /*
7069  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
7070  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7071  * byte offsets.
7072  *
7073  */
7074 void
7075 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
7076 {
7077     const U8* s;
7078     const STRLEN byte = *offsetp;
7079     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
7080     STRLEN blen;
7081     MAGIC* mg = NULL;
7082     const U8* send;
7083     bool found = FALSE;
7084
7085     PERL_ARGS_ASSERT_SV_POS_B2U;
7086
7087     if (!sv)
7088         return;
7089
7090     s = (const U8*)SvPV_const(sv, blen);
7091
7092     if (blen < byte)
7093         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
7094                    ", byte=%"UVuf, (UV)blen, (UV)byte);
7095
7096     send = s + byte;
7097
7098     if (!SvREADONLY(sv)
7099         && PL_utf8cache
7100         && SvTYPE(sv) >= SVt_PVMG
7101         && (mg = mg_find(sv, PERL_MAGIC_utf8)))
7102     {
7103         if (mg->mg_ptr) {
7104             STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7105             if (cache[1] == byte) {
7106                 /* An exact match. */
7107                 *offsetp = cache[0];
7108                 return;
7109             }
7110             if (cache[3] == byte) {
7111                 /* An exact match. */
7112                 *offsetp = cache[2];
7113                 return;
7114             }
7115
7116             if (cache[1] < byte) {
7117                 /* We already know part of the way. */
7118                 if (mg->mg_len != -1) {
7119                     /* Actually, we know the end too.  */
7120                     len = cache[0]
7121                         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
7122                                               s + blen, mg->mg_len - cache[0]);
7123                 } else {
7124                     len = cache[0] + utf8_length(s + cache[1], send);
7125                 }
7126             }
7127             else if (cache[3] < byte) {
7128                 /* We're between the two cached pairs, so we do the calculation
7129                    offset by the byte/utf-8 positions for the earlier pair,
7130                    then add the utf-8 characters from the string start to
7131                    there.  */
7132                 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7133                                           s + cache[1], cache[0] - cache[2])
7134                     + cache[2];
7135
7136             }
7137             else { /* cache[3] > byte */
7138                 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7139                                           cache[2]);
7140
7141             }
7142             ASSERT_UTF8_CACHE(cache);
7143             found = TRUE;
7144         } else if (mg->mg_len != -1) {
7145             len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7146             found = TRUE;
7147         }
7148     }
7149     if (!found || PL_utf8cache < 0) {
7150         const STRLEN real_len = utf8_length(s, send);
7151
7152         if (found && PL_utf8cache < 0)
7153             assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7154         len = real_len;
7155     }
7156     *offsetp = len;
7157
7158     if (PL_utf8cache) {
7159         if (blen == byte)
7160             utf8_mg_len_cache_update(sv, &mg, len);
7161         else
7162             utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
7163     }
7164 }
7165
7166 static void
7167 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7168                              STRLEN real, SV *const sv)
7169 {
7170     PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7171
7172     /* As this is debugging only code, save space by keeping this test here,
7173        rather than inlining it in all the callers.  */
7174     if (from_cache == real)
7175         return;
7176
7177     /* Need to turn the assertions off otherwise we may recurse infinitely
7178        while printing error messages.  */
7179     SAVEI8(PL_utf8cache);
7180     PL_utf8cache = 0;
7181     Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7182                func, (UV) from_cache, (UV) real, SVfARG(sv));
7183 }
7184
7185 /*
7186 =for apidoc sv_eq
7187
7188 Returns a boolean indicating whether the strings in the two SVs are
7189 identical.  Is UTF-8 and 'use bytes' aware, handles get magic, and will
7190 coerce its args to strings if necessary.
7191
7192 =for apidoc sv_eq_flags
7193
7194 Returns a boolean indicating whether the strings in the two SVs are
7195 identical.  Is UTF-8 and 'use bytes' aware and coerces its args to strings
7196 if necessary.  If the flags include SV_GMAGIC, it handles get-magic, too.
7197
7198 =cut
7199 */
7200
7201 I32
7202 Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
7203 {
7204     dVAR;
7205     const char *pv1;
7206     STRLEN cur1;
7207     const char *pv2;
7208     STRLEN cur2;
7209     I32  eq     = 0;
7210     SV* svrecode = NULL;
7211
7212     if (!sv1) {
7213         pv1 = "";
7214         cur1 = 0;
7215     }
7216     else {
7217         /* if pv1 and pv2 are the same, second SvPV_const call may
7218          * invalidate pv1 (if we are handling magic), so we may need to
7219          * make a copy */
7220         if (sv1 == sv2 && flags & SV_GMAGIC
7221          && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7222             pv1 = SvPV_const(sv1, cur1);
7223             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7224         }
7225         pv1 = SvPV_flags_const(sv1, cur1, flags);
7226     }
7227
7228     if (!sv2){
7229         pv2 = "";
7230         cur2 = 0;
7231     }
7232     else
7233         pv2 = SvPV_flags_const(sv2, cur2, flags);
7234
7235     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7236         /* Differing utf8ness.
7237          * Do not UTF8size the comparands as a side-effect. */
7238          if (PL_encoding) {
7239               if (SvUTF8(sv1)) {
7240                    svrecode = newSVpvn(pv2, cur2);
7241                    sv_recode_to_utf8(svrecode, PL_encoding);
7242                    pv2 = SvPV_const(svrecode, cur2);
7243               }
7244               else {
7245                    svrecode = newSVpvn(pv1, cur1);
7246                    sv_recode_to_utf8(svrecode, PL_encoding);
7247                    pv1 = SvPV_const(svrecode, cur1);
7248               }
7249               /* Now both are in UTF-8. */
7250               if (cur1 != cur2) {
7251                    SvREFCNT_dec(svrecode);
7252                    return FALSE;
7253               }
7254          }
7255          else {
7256               if (SvUTF8(sv1)) {
7257                   /* sv1 is the UTF-8 one  */
7258                   return bytes_cmp_utf8((const U8*)pv2, cur2,
7259                                         (const U8*)pv1, cur1) == 0;
7260               }
7261               else {
7262                   /* sv2 is the UTF-8 one  */
7263                   return bytes_cmp_utf8((const U8*)pv1, cur1,
7264                                         (const U8*)pv2, cur2) == 0;
7265               }
7266          }
7267     }
7268
7269     if (cur1 == cur2)
7270         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7271
7272     SvREFCNT_dec(svrecode);
7273
7274     return eq;
7275 }
7276
7277 /*
7278 =for apidoc sv_cmp
7279
7280 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
7281 string in C<sv1> is less than, equal to, or greater than the string in
7282 C<sv2>.  Is UTF-8 and 'use bytes' aware, handles get magic, and will
7283 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
7284
7285 =for apidoc sv_cmp_flags
7286
7287 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
7288 string in C<sv1> is less than, equal to, or greater than the string in
7289 C<sv2>.  Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7290 if necessary.  If the flags include SV_GMAGIC, it handles get magic.  See
7291 also C<sv_cmp_locale_flags>.
7292
7293 =cut
7294 */
7295
7296 I32
7297 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
7298 {
7299     return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7300 }
7301
7302 I32
7303 Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7304                   const U32 flags)
7305 {
7306     dVAR;
7307     STRLEN cur1, cur2;
7308     const char *pv1, *pv2;
7309     char *tpv = NULL;
7310     I32  cmp;
7311     SV *svrecode = NULL;
7312
7313     if (!sv1) {
7314         pv1 = "";
7315         cur1 = 0;
7316     }
7317     else
7318         pv1 = SvPV_flags_const(sv1, cur1, flags);
7319
7320     if (!sv2) {
7321         pv2 = "";
7322         cur2 = 0;
7323     }
7324     else
7325         pv2 = SvPV_flags_const(sv2, cur2, flags);
7326
7327     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7328         /* Differing utf8ness.
7329          * Do not UTF8size the comparands as a side-effect. */
7330         if (SvUTF8(sv1)) {
7331             if (PL_encoding) {
7332                  svrecode = newSVpvn(pv2, cur2);
7333                  sv_recode_to_utf8(svrecode, PL_encoding);
7334                  pv2 = SvPV_const(svrecode, cur2);
7335             }
7336             else {
7337                 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7338                                                    (const U8*)pv1, cur1);
7339                 return retval ? retval < 0 ? -1 : +1 : 0;
7340             }
7341         }
7342         else {
7343             if (PL_encoding) {
7344                  svrecode = newSVpvn(pv1, cur1);
7345                  sv_recode_to_utf8(svrecode, PL_encoding);
7346                  pv1 = SvPV_const(svrecode, cur1);
7347             }
7348             else {
7349                 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7350                                                   (const U8*)pv2, cur2);
7351                 return retval ? retval < 0 ? -1 : +1 : 0;
7352             }
7353         }
7354     }
7355
7356     if (!cur1) {
7357         cmp = cur2 ? -1 : 0;
7358     } else if (!cur2) {
7359         cmp = 1;
7360     } else {
7361         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7362
7363         if (retval) {
7364             cmp = retval < 0 ? -1 : 1;
7365         } else if (cur1 == cur2) {
7366             cmp = 0;
7367         } else {
7368             cmp = cur1 < cur2 ? -1 : 1;
7369         }
7370     }
7371
7372     SvREFCNT_dec(svrecode);
7373     if (tpv)
7374         Safefree(tpv);
7375
7376     return cmp;
7377 }
7378
7379 /*
7380 =for apidoc sv_cmp_locale
7381
7382 Compares the strings in two SVs in a locale-aware manner.  Is UTF-8 and
7383 'use bytes' aware, handles get magic, and will coerce its args to strings
7384 if necessary.  See also C<sv_cmp>.
7385
7386 =for apidoc sv_cmp_locale_flags
7387
7388 Compares the strings in two SVs in a locale-aware manner.  Is UTF-8 and
7389 'use bytes' aware and will coerce its args to strings if necessary.  If the
7390 flags contain SV_GMAGIC, it handles get magic.  See also C<sv_cmp_flags>.
7391
7392 =cut
7393 */
7394
7395 I32
7396 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
7397 {
7398     return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7399 }
7400
7401 I32
7402 Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7403                          const U32 flags)
7404 {
7405     dVAR;
7406 #ifdef USE_LOCALE_COLLATE
7407
7408     char *pv1, *pv2;
7409     STRLEN len1, len2;
7410     I32 retval;
7411
7412     if (PL_collation_standard)
7413         goto raw_compare;
7414
7415     len1 = 0;
7416     pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7417     len2 = 0;
7418     pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7419
7420     if (!pv1 || !len1) {
7421         if (pv2 && len2)
7422             return -1;
7423         else
7424             goto raw_compare;
7425     }
7426     else {
7427         if (!pv2 || !len2)
7428             return 1;
7429     }
7430
7431     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7432
7433     if (retval)
7434         return retval < 0 ? -1 : 1;
7435
7436     /*
7437      * When the result of collation is equality, that doesn't mean
7438      * that there are no differences -- some locales exclude some
7439      * characters from consideration.  So to avoid false equalities,
7440      * we use the raw string as a tiebreaker.
7441      */
7442
7443   raw_compare:
7444     /*FALLTHROUGH*/
7445
7446 #endif /* USE_LOCALE_COLLATE */
7447
7448     return sv_cmp(sv1, sv2);
7449 }
7450
7451
7452 #ifdef USE_LOCALE_COLLATE
7453
7454 /*
7455 =for apidoc sv_collxfrm
7456
7457 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag.  See
7458 C<sv_collxfrm_flags>.
7459
7460 =for apidoc sv_collxfrm_flags
7461
7462 Add Collate Transform magic to an SV if it doesn't already have it.  If the
7463 flags contain SV_GMAGIC, it handles get-magic.
7464
7465 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7466 scalar data of the variable, but transformed to such a format that a normal
7467 memory comparison can be used to compare the data according to the locale
7468 settings.
7469
7470 =cut
7471 */
7472
7473 char *
7474 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7475 {
7476     dVAR;
7477     MAGIC *mg;
7478
7479     PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7480
7481     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7482     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7483         const char *s;
7484         char *xf;
7485         STRLEN len, xlen;
7486
7487         if (mg)
7488             Safefree(mg->mg_ptr);
7489         s = SvPV_flags_const(sv, len, flags);
7490         if ((xf = mem_collxfrm(s, len, &xlen))) {
7491             if (! mg) {
7492 #ifdef PERL_OLD_COPY_ON_WRITE
7493                 if (SvIsCOW(sv))
7494                     sv_force_normal_flags(sv, 0);
7495 #endif
7496                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7497                                  0, 0);
7498                 assert(mg);
7499             }
7500             mg->mg_ptr = xf;
7501             mg->mg_len = xlen;
7502         }
7503         else {
7504             if (mg) {
7505                 mg->mg_ptr = NULL;
7506                 mg->mg_len = -1;
7507             }
7508         }
7509     }
7510     if (mg && mg->mg_ptr) {
7511         *nxp = mg->mg_len;
7512         return mg->mg_ptr + sizeof(PL_collation_ix);
7513     }
7514     else {
7515         *nxp = 0;
7516         return NULL;
7517     }
7518 }
7519
7520 #endif /* USE_LOCALE_COLLATE */
7521
7522 static char *
7523 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7524 {
7525     SV * const tsv = newSV(0);
7526     ENTER;
7527     SAVEFREESV(tsv);
7528     sv_gets(tsv, fp, 0);
7529     sv_utf8_upgrade_nomg(tsv);
7530     SvCUR_set(sv,append);
7531     sv_catsv(sv,tsv);
7532     LEAVE;
7533     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7534 }
7535
7536 static char *
7537 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7538 {
7539     I32 bytesread;
7540     const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7541       /* Grab the size of the record we're getting */
7542     char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7543 #ifdef VMS
7544     int fd;
7545 #endif
7546
7547     /* Go yank in */
7548 #ifdef VMS
7549     /* VMS wants read instead of fread, because fread doesn't respect */
7550     /* RMS record boundaries. This is not necessarily a good thing to be */
7551     /* doing, but we've got no other real choice - except avoid stdio
7552        as implementation - perhaps write a :vms layer ?
7553     */
7554     fd = PerlIO_fileno(fp);
7555     if (fd != -1) {
7556         bytesread = PerlLIO_read(fd, buffer, recsize);
7557     }
7558     else /* in-memory file from PerlIO::Scalar */
7559 #endif
7560     {
7561         bytesread = PerlIO_read(fp, buffer, recsize);
7562     }
7563
7564     if (bytesread < 0)
7565         bytesread = 0;
7566     SvCUR_set(sv, bytesread + append);
7567     buffer[bytesread] = '\0';
7568     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7569 }
7570
7571 /*
7572 =for apidoc sv_gets
7573
7574 Get a line from the filehandle and store it into the SV, optionally
7575 appending to the currently-stored string.
7576
7577 =cut
7578 */
7579
7580 char *
7581 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7582 {
7583     dVAR;
7584     const char *rsptr;
7585     STRLEN rslen;
7586     register STDCHAR rslast;
7587     register STDCHAR *bp;
7588     register I32 cnt;
7589     I32 i = 0;
7590     I32 rspara = 0;
7591
7592     PERL_ARGS_ASSERT_SV_GETS;
7593
7594     if (SvTHINKFIRST(sv))
7595         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7596     /* XXX. If you make this PVIV, then copy on write can copy scalars read
7597        from <>.
7598        However, perlbench says it's slower, because the existing swipe code
7599        is faster than copy on write.
7600        Swings and roundabouts.  */
7601     SvUPGRADE(sv, SVt_PV);
7602
7603     SvSCREAM_off(sv);
7604
7605     if (append) {
7606         if (PerlIO_isutf8(fp)) {
7607             if (!SvUTF8(sv)) {
7608                 sv_utf8_upgrade_nomg(sv);
7609                 sv_pos_u2b(sv,&append,0);
7610             }
7611         } else if (SvUTF8(sv)) {
7612             return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
7613         }
7614     }
7615
7616     SvPOK_only(sv);
7617     if (!append) {
7618         SvCUR_set(sv,0);
7619     }
7620     if (PerlIO_isutf8(fp))
7621         SvUTF8_on(sv);
7622
7623     if (IN_PERL_COMPILETIME) {
7624         /* we always read code in line mode */
7625         rsptr = "\n";
7626         rslen = 1;
7627     }
7628     else if (RsSNARF(PL_rs)) {
7629         /* If it is a regular disk file use size from stat() as estimate
7630            of amount we are going to read -- may result in mallocing
7631            more memory than we really need if the layers below reduce
7632            the size we read (e.g. CRLF or a gzip layer).
7633          */
7634         Stat_t st;
7635         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
7636             const Off_t offset = PerlIO_tell(fp);
7637             if (offset != (Off_t) -1 && st.st_size + append > offset) {
7638                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7639             }
7640         }
7641         rsptr = NULL;
7642         rslen = 0;
7643     }
7644     else if (RsRECORD(PL_rs)) {
7645         return S_sv_gets_read_record(aTHX_ sv, fp, append);
7646     }
7647     else if (RsPARA(PL_rs)) {
7648         rsptr = "\n\n";
7649         rslen = 2;
7650         rspara = 1;
7651     }
7652     else {
7653         /* Get $/ i.e. PL_rs into same encoding as stream wants */
7654         if (PerlIO_isutf8(fp)) {
7655             rsptr = SvPVutf8(PL_rs, rslen);
7656         }
7657         else {
7658             if (SvUTF8(PL_rs)) {
7659                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7660                     Perl_croak(aTHX_ "Wide character in $/");
7661                 }
7662             }
7663             rsptr = SvPV_const(PL_rs, rslen);
7664         }
7665     }
7666
7667     rslast = rslen ? rsptr[rslen - 1] : '\0';
7668
7669     if (rspara) {               /* have to do this both before and after */
7670         do {                    /* to make sure file boundaries work right */
7671             if (PerlIO_eof(fp))
7672                 return 0;
7673             i = PerlIO_getc(fp);
7674             if (i != '\n') {
7675                 if (i == -1)
7676                     return 0;
7677                 PerlIO_ungetc(fp,i);
7678                 break;
7679             }
7680         } while (i != EOF);
7681     }
7682
7683     /* See if we know enough about I/O mechanism to cheat it ! */
7684
7685     /* This used to be #ifdef test - it is made run-time test for ease
7686        of abstracting out stdio interface. One call should be cheap
7687        enough here - and may even be a macro allowing compile
7688        time optimization.
7689      */
7690
7691     if (PerlIO_fast_gets(fp)) {
7692
7693     /*
7694      * We're going to steal some values from the stdio struct
7695      * and put EVERYTHING in the innermost loop into registers.
7696      */
7697     register STDCHAR *ptr;
7698     STRLEN bpx;
7699     I32 shortbuffered;
7700
7701 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7702     /* An ungetc()d char is handled separately from the regular
7703      * buffer, so we getc() it back out and stuff it in the buffer.
7704      */
7705     i = PerlIO_getc(fp);
7706     if (i == EOF) return 0;
7707     *(--((*fp)->_ptr)) = (unsigned char) i;
7708     (*fp)->_cnt++;
7709 #endif
7710
7711     /* Here is some breathtakingly efficient cheating */
7712
7713     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
7714     /* make sure we have the room */
7715     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7716         /* Not room for all of it
7717            if we are looking for a separator and room for some
7718          */
7719         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7720             /* just process what we have room for */
7721             shortbuffered = cnt - SvLEN(sv) + append + 1;
7722             cnt -= shortbuffered;
7723         }
7724         else {
7725             shortbuffered = 0;
7726             /* remember that cnt can be negative */
7727             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7728         }
7729     }
7730     else
7731         shortbuffered = 0;
7732     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
7733     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7734     DEBUG_P(PerlIO_printf(Perl_debug_log,
7735         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7736     DEBUG_P(PerlIO_printf(Perl_debug_log,
7737         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7738                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7739                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7740     for (;;) {
7741       screamer:
7742         if (cnt > 0) {
7743             if (rslen) {
7744                 while (cnt > 0) {                    /* this     |  eat */
7745                     cnt--;
7746                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
7747                         goto thats_all_folks;        /* screams  |  sed :-) */
7748                 }
7749             }
7750             else {
7751                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
7752                 bp += cnt;                           /* screams  |  dust */
7753                 ptr += cnt;                          /* louder   |  sed :-) */
7754                 cnt = 0;
7755                 assert (!shortbuffered);
7756                 goto cannot_be_shortbuffered;
7757             }
7758         }
7759
7760         if (shortbuffered) {            /* oh well, must extend */
7761             cnt = shortbuffered;
7762             shortbuffered = 0;
7763             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7764             SvCUR_set(sv, bpx);
7765             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7766             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7767             continue;
7768         }
7769
7770     cannot_be_shortbuffered:
7771         DEBUG_P(PerlIO_printf(Perl_debug_log,
7772                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7773                               PTR2UV(ptr),(long)cnt));
7774         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7775
7776         DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7777             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7778             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7779             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7780
7781         /* This used to call 'filbuf' in stdio form, but as that behaves like
7782            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7783            another abstraction.  */
7784         i   = PerlIO_getc(fp);          /* get more characters */
7785
7786         DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7787             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7788             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7789             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7790
7791         cnt = PerlIO_get_cnt(fp);
7792         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
7793         DEBUG_P(PerlIO_printf(Perl_debug_log,
7794             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7795
7796         if (i == EOF)                   /* all done for ever? */
7797             goto thats_really_all_folks;
7798
7799         bpx = bp - (STDCHAR*)SvPVX_const(sv);   /* box up before relocation */
7800         SvCUR_set(sv, bpx);
7801         SvGROW(sv, bpx + cnt + 2);
7802         bp = (STDCHAR*)SvPVX_const(sv) + bpx;   /* unbox after relocation */
7803
7804         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
7805
7806         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
7807             goto thats_all_folks;
7808     }
7809
7810 thats_all_folks:
7811     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7812           memNE((char*)bp - rslen, rsptr, rslen))
7813         goto screamer;                          /* go back to the fray */
7814 thats_really_all_folks:
7815     if (shortbuffered)
7816         cnt += shortbuffered;
7817         DEBUG_P(PerlIO_printf(Perl_debug_log,
7818             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7819     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
7820     DEBUG_P(PerlIO_printf(Perl_debug_log,
7821         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7822         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7823         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7824     *bp = '\0';
7825     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));      /* set length */
7826     DEBUG_P(PerlIO_printf(Perl_debug_log,
7827         "Screamer: done, len=%ld, string=|%.*s|\n",
7828         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7829     }
7830    else
7831     {
7832        /*The big, slow, and stupid way. */
7833 #ifdef USE_HEAP_INSTEAD_OF_STACK        /* Even slower way. */
7834         STDCHAR *buf = NULL;
7835         Newx(buf, 8192, STDCHAR);
7836         assert(buf);
7837 #else
7838         STDCHAR buf[8192];
7839 #endif
7840
7841 screamer2:
7842         if (rslen) {
7843             register const STDCHAR * const bpe = buf + sizeof(buf);
7844             bp = buf;
7845             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7846                 ; /* keep reading */
7847             cnt = bp - buf;
7848         }
7849         else {
7850             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7851             /* Accommodate broken VAXC compiler, which applies U8 cast to
7852              * both args of ?: operator, causing EOF to change into 255
7853              */
7854             if (cnt > 0)
7855                  i = (U8)buf[cnt - 1];
7856             else
7857                  i = EOF;
7858         }
7859
7860         if (cnt < 0)
7861             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
7862         if (append)
7863              sv_catpvn(sv, (char *) buf, cnt);
7864         else
7865              sv_setpvn(sv, (char *) buf, cnt);
7866
7867         if (i != EOF &&                 /* joy */
7868             (!rslen ||
7869              SvCUR(sv) < rslen ||
7870              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7871         {
7872             append = -1;
7873             /*
7874              * If we're reading from a TTY and we get a short read,
7875              * indicating that the user hit his EOF character, we need
7876              * to notice it now, because if we try to read from the TTY
7877              * again, the EOF condition will disappear.
7878              *
7879              * The comparison of cnt to sizeof(buf) is an optimization
7880              * that prevents unnecessary calls to feof().
7881              *
7882              * - jik 9/25/96
7883              */
7884             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7885                 goto screamer2;
7886         }
7887
7888 #ifdef USE_HEAP_INSTEAD_OF_STACK
7889         Safefree(buf);
7890 #endif
7891     }
7892
7893     if (rspara) {               /* have to do this both before and after */
7894         while (i != EOF) {      /* to make sure file boundaries work right */
7895             i = PerlIO_getc(fp);
7896             if (i != '\n') {
7897                 PerlIO_ungetc(fp,i);
7898                 break;
7899             }
7900         }
7901     }
7902
7903     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7904 }
7905
7906 /*
7907 =for apidoc sv_inc
7908
7909 Auto-increment of the value in the SV, doing string to numeric conversion
7910 if necessary.  Handles 'get' magic and operator overloading.
7911
7912 =cut
7913 */
7914
7915 void
7916 Perl_sv_inc(pTHX_ register SV *const sv)
7917 {
7918     if (!sv)
7919         return;
7920     SvGETMAGIC(sv);
7921     sv_inc_nomg(sv);
7922 }
7923
7924 /*
7925 =for apidoc sv_inc_nomg
7926
7927 Auto-increment of the value in the SV, doing string to numeric conversion
7928 if necessary.  Handles operator overloading.  Skips handling 'get' magic.
7929
7930 =cut
7931 */
7932
7933 void
7934 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7935 {
7936     dVAR;
7937     register char *d;
7938     int flags;
7939
7940     if (!sv)
7941         return;
7942     if (SvTHINKFIRST(sv)) {
7943         if (SvIsCOW(sv) || isGV_with_GP(sv))
7944             sv_force_normal_flags(sv, 0);
7945         if (SvREADONLY(sv)) {
7946             if (IN_PERL_RUNTIME)
7947                 Perl_croak_no_modify(aTHX);
7948         }
7949         if (SvROK(sv)) {
7950             IV i;
7951             if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
7952                 return;
7953             i = PTR2IV(SvRV(sv));
7954             sv_unref(sv);
7955             sv_setiv(sv, i);
7956         }
7957     }
7958     flags = SvFLAGS(sv);
7959     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7960         /* It's (privately or publicly) a float, but not tested as an
7961            integer, so test it to see. */
7962         (void) SvIV(sv);
7963         flags = SvFLAGS(sv);
7964     }
7965     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7966         /* It's publicly an integer, or privately an integer-not-float */
7967 #ifdef PERL_PRESERVE_IVUV
7968       oops_its_int:
7969 #endif
7970         if (SvIsUV(sv)) {
7971             if (SvUVX(sv) == UV_MAX)
7972                 sv_setnv(sv, UV_MAX_P1);
7973             else
7974                 (void)SvIOK_only_UV(sv);
7975                 SvUV_set(sv, SvUVX(sv) + 1);
7976         } else {
7977             if (SvIVX(sv) == IV_MAX)
7978                 sv_setuv(sv, (UV)IV_MAX + 1);
7979             else {
7980                 (void)SvIOK_only(sv);
7981                 SvIV_set(sv, SvIVX(sv) + 1);
7982             }
7983         }
7984         return;
7985     }
7986     if (flags & SVp_NOK) {
7987         const NV was = SvNVX(sv);
7988         if (NV_OVERFLOWS_INTEGERS_AT &&
7989             was >= NV_OVERFLOWS_INTEGERS_AT) {
7990             /* diag_listed_as: Lost precision when %s %f by 1 */
7991             Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7992                            "Lost precision when incrementing %" NVff " by 1",
7993                            was);
7994         }
7995         (void)SvNOK_only(sv);
7996         SvNV_set(sv, was + 1.0);
7997         return;
7998     }
7999
8000     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
8001         if ((flags & SVTYPEMASK) < SVt_PVIV)
8002             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
8003         (void)SvIOK_only(sv);
8004         SvIV_set(sv, 1);
8005         return;
8006     }
8007     d = SvPVX(sv);
8008     while (isALPHA(*d)) d++;
8009     while (isDIGIT(*d)) d++;
8010     if (d < SvEND(sv)) {
8011 #ifdef PERL_PRESERVE_IVUV
8012         /* Got to punt this as an integer if needs be, but we don't issue
8013            warnings. Probably ought to make the sv_iv_please() that does
8014            the conversion if possible, and silently.  */
8015         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8016         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8017             /* Need to try really hard to see if it's an integer.
8018                9.22337203685478e+18 is an integer.
8019                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8020                so $a="9.22337203685478e+18"; $a+0; $a++
8021                needs to be the same as $a="9.22337203685478e+18"; $a++
8022                or we go insane. */
8023
8024             (void) sv_2iv(sv);
8025             if (SvIOK(sv))
8026                 goto oops_its_int;
8027
8028             /* sv_2iv *should* have made this an NV */
8029             if (flags & SVp_NOK) {
8030                 (void)SvNOK_only(sv);
8031                 SvNV_set(sv, SvNVX(sv) + 1.0);
8032                 return;
8033             }
8034             /* I don't think we can get here. Maybe I should assert this
8035                And if we do get here I suspect that sv_setnv will croak. NWC
8036                Fall through. */
8037 #if defined(USE_LONG_DOUBLE)
8038             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",
8039                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8040 #else
8041             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8042                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8043 #endif
8044         }
8045 #endif /* PERL_PRESERVE_IVUV */
8046         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
8047         return;
8048     }
8049     d--;
8050     while (d >= SvPVX_const(sv)) {
8051         if (isDIGIT(*d)) {
8052             if (++*d <= '9')
8053                 return;
8054             *(d--) = '0';
8055         }
8056         else {
8057 #ifdef EBCDIC
8058             /* MKS: The original code here died if letters weren't consecutive.
8059              * at least it didn't have to worry about non-C locales.  The
8060              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
8061              * arranged in order (although not consecutively) and that only
8062              * [A-Za-z] are accepted by isALPHA in the C locale.
8063              */
8064             if (*d != 'z' && *d != 'Z') {
8065                 do { ++*d; } while (!isALPHA(*d));
8066                 return;
8067             }
8068             *(d--) -= 'z' - 'a';
8069 #else
8070             ++*d;
8071             if (isALPHA(*d))
8072                 return;
8073             *(d--) -= 'z' - 'a' + 1;
8074 #endif
8075         }
8076     }
8077     /* oh,oh, the number grew */
8078     SvGROW(sv, SvCUR(sv) + 2);
8079     SvCUR_set(sv, SvCUR(sv) + 1);
8080     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
8081         *d = d[-1];
8082     if (isDIGIT(d[1]))
8083         *d = '1';
8084     else
8085         *d = d[1];
8086 }
8087
8088 /*
8089 =for apidoc sv_dec
8090
8091 Auto-decrement of the value in the SV, doing string to numeric conversion
8092 if necessary.  Handles 'get' magic and operator overloading.
8093
8094 =cut
8095 */
8096
8097 void
8098 Perl_sv_dec(pTHX_ register SV *const sv)
8099 {
8100     dVAR;
8101     if (!sv)
8102         return;
8103     SvGETMAGIC(sv);
8104     sv_dec_nomg(sv);
8105 }
8106
8107 /*
8108 =for apidoc sv_dec_nomg
8109
8110 Auto-decrement of the value in the SV, doing string to numeric conversion
8111 if necessary.  Handles operator overloading.  Skips handling 'get' magic.
8112
8113 =cut
8114 */
8115
8116 void
8117 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
8118 {
8119     dVAR;
8120     int flags;
8121
8122     if (!sv)
8123         return;
8124     if (SvTHINKFIRST(sv)) {
8125         if (SvIsCOW(sv) || isGV_with_GP(sv))
8126             sv_force_normal_flags(sv, 0);
8127         if (SvREADONLY(sv)) {
8128             if (IN_PERL_RUNTIME)
8129                 Perl_croak_no_modify(aTHX);
8130         }
8131         if (SvROK(sv)) {
8132             IV i;
8133             if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
8134                 return;
8135             i = PTR2IV(SvRV(sv));
8136             sv_unref(sv);
8137             sv_setiv(sv, i);
8138         }
8139     }
8140     /* Unlike sv_inc we don't have to worry about string-never-numbers
8141        and keeping them magic. But we mustn't warn on punting */
8142     flags = SvFLAGS(sv);
8143     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8144         /* It's publicly an integer, or privately an integer-not-float */
8145 #ifdef PERL_PRESERVE_IVUV
8146       oops_its_int:
8147 #endif
8148         if (SvIsUV(sv)) {
8149             if (SvUVX(sv) == 0) {
8150                 (void)SvIOK_only(sv);
8151                 SvIV_set(sv, -1);
8152             }
8153             else {
8154                 (void)SvIOK_only_UV(sv);
8155                 SvUV_set(sv, SvUVX(sv) - 1);
8156             }
8157         } else {
8158             if (SvIVX(sv) == IV_MIN) {
8159                 sv_setnv(sv, (NV)IV_MIN);
8160                 goto oops_its_num;
8161             }
8162             else {
8163                 (void)SvIOK_only(sv);
8164                 SvIV_set(sv, SvIVX(sv) - 1);
8165             }
8166         }
8167         return;
8168     }
8169     if (flags & SVp_NOK) {
8170     oops_its_num:
8171         {
8172             const NV was = SvNVX(sv);
8173             if (NV_OVERFLOWS_INTEGERS_AT &&
8174                 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8175                 /* diag_listed_as: Lost precision when %s %f by 1 */
8176                 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8177                                "Lost precision when decrementing %" NVff " by 1",
8178                                was);
8179             }
8180             (void)SvNOK_only(sv);
8181             SvNV_set(sv, was - 1.0);
8182             return;
8183         }
8184     }
8185     if (!(flags & SVp_POK)) {
8186         if ((flags & SVTYPEMASK) < SVt_PVIV)
8187             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8188         SvIV_set(sv, -1);
8189         (void)SvIOK_only(sv);
8190         return;
8191     }
8192 #ifdef PERL_PRESERVE_IVUV
8193     {
8194         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8195         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8196             /* Need to try really hard to see if it's an integer.
8197                9.22337203685478e+18 is an integer.
8198                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8199                so $a="9.22337203685478e+18"; $a+0; $a--
8200                needs to be the same as $a="9.22337203685478e+18"; $a--
8201                or we go insane. */
8202
8203             (void) sv_2iv(sv);
8204             if (SvIOK(sv))
8205                 goto oops_its_int;
8206
8207             /* sv_2iv *should* have made this an NV */
8208             if (flags & SVp_NOK) {
8209                 (void)SvNOK_only(sv);
8210                 SvNV_set(sv, SvNVX(sv) - 1.0);
8211                 return;
8212             }
8213             /* I don't think we can get here. Maybe I should assert this
8214                And if we do get here I suspect that sv_setnv will croak. NWC
8215                Fall through. */
8216 #if defined(USE_LONG_DOUBLE)
8217             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",
8218                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8219 #else
8220             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8221                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8222 #endif
8223         }
8224     }
8225 #endif /* PERL_PRESERVE_IVUV */
8226     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);   /* punt */
8227 }
8228
8229 /* this define is used to eliminate a chunk of duplicated but shared logic
8230  * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8231  * used anywhere but here - yves
8232  */
8233 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8234     STMT_START {      \
8235         EXTEND_MORTAL(1); \
8236         PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8237     } STMT_END
8238
8239 /*
8240 =for apidoc sv_mortalcopy
8241
8242 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8243 The new SV is marked as mortal.  It will be destroyed "soon", either by an
8244 explicit call to FREETMPS, or by an implicit call at places such as
8245 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
8246
8247 =cut
8248 */
8249
8250 /* Make a string that will exist for the duration of the expression
8251  * evaluation.  Actually, it may have to last longer than that, but
8252  * hopefully we won't free it until it has been assigned to a
8253  * permanent location. */
8254
8255 SV *
8256 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
8257 {
8258     dVAR;
8259     register SV *sv;
8260
8261     new_SV(sv);
8262     sv_setsv(sv,oldstr);
8263     PUSH_EXTEND_MORTAL__SV_C(sv);
8264     SvTEMP_on(sv);
8265     return sv;
8266 }
8267
8268 /*
8269 =for apidoc sv_newmortal
8270
8271 Creates a new null SV which is mortal.  The reference count of the SV is
8272 set to 1.  It will be destroyed "soon", either by an explicit call to
8273 FREETMPS, or by an implicit call at places such as statement boundaries.
8274 See also C<sv_mortalcopy> and C<sv_2mortal>.
8275
8276 =cut
8277 */
8278
8279 SV *
8280 Perl_sv_newmortal(pTHX)
8281 {
8282     dVAR;
8283     register SV *sv;
8284
8285     new_SV(sv);
8286     SvFLAGS(sv) = SVs_TEMP;
8287     PUSH_EXTEND_MORTAL__SV_C(sv);
8288     return sv;
8289 }
8290
8291
8292 /*
8293 =for apidoc newSVpvn_flags
8294
8295 Creates a new SV and copies a string into it.  The reference count for the
8296 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
8297 string.  You are responsible for ensuring that the source string is at least
8298 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
8299 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8300 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8301 returning.  If C<SVf_UTF8> is set, C<s>
8302 is considered to be in UTF-8 and the
8303 C<SVf_UTF8> flag will be set on the new SV.
8304 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8305
8306     #define newSVpvn_utf8(s, len, u)                    \
8307         newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8308
8309 =cut
8310 */
8311
8312 SV *
8313 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8314 {
8315     dVAR;
8316     register SV *sv;
8317
8318     /* All the flags we don't support must be zero.
8319        And we're new code so I'm going to assert this from the start.  */
8320     assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8321     new_SV(sv);
8322     sv_setpvn(sv,s,len);
8323
8324     /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
8325      * and do what it does ourselves here.
8326      * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
8327      * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8328      * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
8329      * eliminate quite a few steps than it looks - Yves (explaining patch by gfx)
8330      */
8331
8332     SvFLAGS(sv) |= flags;
8333
8334     if(flags & SVs_TEMP){
8335         PUSH_EXTEND_MORTAL__SV_C(sv);
8336     }
8337
8338     return sv;
8339 }
8340
8341 /*
8342 =for apidoc sv_2mortal
8343
8344 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
8345 by an explicit call to FREETMPS, or by an implicit call at places such as
8346 statement boundaries.  SvTEMP() is turned on which means that the SV's
8347 string buffer can be "stolen" if this SV is copied.  See also C<sv_newmortal>
8348 and C<sv_mortalcopy>.
8349
8350 =cut
8351 */
8352
8353 SV *
8354 Perl_sv_2mortal(pTHX_ register SV *const sv)
8355 {
8356     dVAR;
8357     if (!sv)
8358         return NULL;
8359     if (SvREADONLY(sv) && SvIMMORTAL(sv))
8360         return sv;
8361     PUSH_EXTEND_MORTAL__SV_C(sv);
8362     SvTEMP_on(sv);
8363     return sv;
8364 }
8365
8366 /*
8367 =for apidoc newSVpv
8368
8369 Creates a new SV and copies a string into it.  The reference count for the
8370 SV is set to 1.  If C<len> is zero, Perl will compute the length using
8371 strlen().  For efficiency, consider using C<newSVpvn> instead.
8372
8373 =cut
8374 */
8375
8376 SV *
8377 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8378 {
8379     dVAR;
8380     register SV *sv;
8381
8382     new_SV(sv);
8383     sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8384     return sv;
8385 }
8386
8387 /*
8388 =for apidoc newSVpvn
8389
8390 Creates a new SV and copies a string into it.  The reference count for the
8391 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
8392 string.  You are responsible for ensuring that the source string is at least
8393 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
8394
8395 =cut
8396 */
8397
8398 SV *
8399 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
8400 {
8401     dVAR;
8402     register SV *sv;
8403
8404     new_SV(sv);
8405     sv_setpvn(sv,s,len);
8406     return sv;
8407 }
8408
8409 /*
8410 =for apidoc newSVhek
8411
8412 Creates a new SV from the hash key structure.  It will generate scalars that
8413 point to the shared string table where possible.  Returns a new (undefined)
8414 SV if the hek is NULL.
8415
8416 =cut
8417 */
8418
8419 SV *
8420 Perl_newSVhek(pTHX_ const HEK *const hek)
8421 {
8422     dVAR;
8423     if (!hek) {
8424         SV *sv;
8425
8426         new_SV(sv);
8427         return sv;
8428     }
8429
8430     if (HEK_LEN(hek) == HEf_SVKEY) {
8431         return newSVsv(*(SV**)HEK_KEY(hek));
8432     } else {
8433         const int flags = HEK_FLAGS(hek);
8434         if (flags & HVhek_WASUTF8) {
8435             /* Trouble :-)
8436                Andreas would like keys he put in as utf8 to come back as utf8
8437             */
8438             STRLEN utf8_len = HEK_LEN(hek);
8439             SV * const sv = newSV_type(SVt_PV);
8440             char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8441             /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8442             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8443             SvUTF8_on (sv);
8444             return sv;
8445         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
8446             /* We don't have a pointer to the hv, so we have to replicate the
8447                flag into every HEK. This hv is using custom a hasing
8448                algorithm. Hence we can't return a shared string scalar, as
8449                that would contain the (wrong) hash value, and might get passed
8450                into an hv routine with a regular hash.
8451                Similarly, a hash that isn't using shared hash keys has to have
8452                the flag in every key so that we know not to try to call
8453                share_hek_hek on it.  */
8454
8455             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8456             if (HEK_UTF8(hek))
8457                 SvUTF8_on (sv);
8458             return sv;
8459         }
8460         /* This will be overwhelminly the most common case.  */
8461         {
8462             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8463                more efficient than sharepvn().  */
8464             SV *sv;
8465
8466             new_SV(sv);
8467             sv_upgrade(sv, SVt_PV);
8468             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8469             SvCUR_set(sv, HEK_LEN(hek));
8470             SvLEN_set(sv, 0);
8471             SvREADONLY_on(sv);
8472             SvFAKE_on(sv);
8473             SvPOK_on(sv);
8474             if (HEK_UTF8(hek))
8475                 SvUTF8_on(sv);
8476             return sv;
8477         }
8478     }
8479 }
8480
8481 /*
8482 =for apidoc newSVpvn_share
8483
8484 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8485 table.  If the string does not already exist in the table, it is
8486 created first.  Turns on READONLY and FAKE.  If the C<hash> parameter
8487 is non-zero, that value is used; otherwise the hash is computed.
8488 The string's hash can later be retrieved from the SV
8489 with the C<SvSHARED_HASH()> macro.  The idea here is
8490 that as the string table is used for shared hash keys these strings will have
8491 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8492
8493 =cut
8494 */
8495
8496 SV *
8497 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8498 {
8499     dVAR;
8500     register SV *sv;
8501     bool is_utf8 = FALSE;
8502     const char *const orig_src = src;
8503
8504     if (len < 0) {
8505         STRLEN tmplen = -len;
8506         is_utf8 = TRUE;
8507         /* See the note in hv.c:hv_fetch() --jhi */
8508         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8509         len = tmplen;
8510     }
8511     if (!hash)
8512         PERL_HASH(hash, src, len);
8513     new_SV(sv);
8514     /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8515        changes here, update it there too.  */
8516     sv_upgrade(sv, SVt_PV);
8517     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8518     SvCUR_set(sv, len);
8519     SvLEN_set(sv, 0);
8520     SvREADONLY_on(sv);
8521     SvFAKE_on(sv);
8522     SvPOK_on(sv);
8523     if (is_utf8)
8524         SvUTF8_on(sv);
8525     if (src != orig_src)
8526         Safefree(src);
8527     return sv;
8528 }
8529
8530 /*
8531 =for apidoc newSVpv_share
8532
8533 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8534 string/length pair.
8535
8536 =cut
8537 */
8538
8539 SV *
8540 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8541 {
8542     return newSVpvn_share(src, strlen(src), hash);
8543 }
8544
8545 #if defined(PERL_IMPLICIT_CONTEXT)
8546
8547 /* pTHX_ magic can't cope with varargs, so this is a no-context
8548  * version of the main function, (which may itself be aliased to us).
8549  * Don't access this version directly.
8550  */
8551
8552 SV *
8553 Perl_newSVpvf_nocontext(const char *const pat, ...)
8554 {
8555     dTHX;
8556     register SV *sv;
8557     va_list args;
8558
8559     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8560
8561     va_start(args, pat);
8562     sv = vnewSVpvf(pat, &args);
8563     va_end(args);
8564     return sv;
8565 }
8566 #endif
8567
8568 /*
8569 =for apidoc newSVpvf
8570
8571 Creates a new SV and initializes it with the string formatted like
8572 C<sprintf>.
8573
8574 =cut
8575 */
8576
8577 SV *
8578 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8579 {
8580     register SV *sv;
8581     va_list args;
8582
8583     PERL_ARGS_ASSERT_NEWSVPVF;
8584
8585     va_start(args, pat);
8586     sv = vnewSVpvf(pat, &args);
8587     va_end(args);
8588     return sv;
8589 }
8590
8591 /* backend for newSVpvf() and newSVpvf_nocontext() */
8592
8593 SV *
8594 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8595 {
8596     dVAR;
8597     register SV *sv;
8598
8599     PERL_ARGS_ASSERT_VNEWSVPVF;
8600
8601     new_SV(sv);
8602     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8603     return sv;
8604 }
8605
8606 /*
8607 =for apidoc newSVnv
8608
8609 Creates a new SV and copies a floating point value into it.
8610 The reference count for the SV is set to 1.
8611
8612 =cut
8613 */
8614
8615 SV *
8616 Perl_newSVnv(pTHX_ const NV n)
8617 {
8618     dVAR;
8619     register SV *sv;
8620
8621     new_SV(sv);
8622     sv_setnv(sv,n);
8623     return sv;
8624 }
8625
8626 /*
8627 =for apidoc newSViv
8628
8629 Creates a new SV and copies an integer into it.  The reference count for the
8630 SV is set to 1.
8631
8632 =cut
8633 */
8634
8635 SV *
8636 Perl_newSViv(pTHX_ const IV i)
8637 {
8638     dVAR;
8639     register SV *sv;
8640
8641     new_SV(sv);
8642     sv_setiv(sv,i);
8643     return sv;
8644 }
8645
8646 /*
8647 =for apidoc newSVuv
8648
8649 Creates a new SV and copies an unsigned integer into it.
8650 The reference count for the SV is set to 1.
8651
8652 =cut
8653 */
8654
8655 SV *
8656 Perl_newSVuv(pTHX_ const UV u)
8657 {
8658     dVAR;
8659     register SV *sv;
8660
8661     new_SV(sv);
8662     sv_setuv(sv,u);
8663     return sv;
8664 }
8665
8666 /*
8667 =for apidoc newSV_type
8668
8669 Creates a new SV, of the type specified.  The reference count for the new SV
8670 is set to 1.
8671
8672 =cut
8673 */
8674
8675 SV *
8676 Perl_newSV_type(pTHX_ const svtype type)
8677 {
8678     register SV *sv;
8679
8680     new_SV(sv);
8681     sv_upgrade(sv, type);
8682     return sv;
8683 }
8684
8685 /*
8686 =for apidoc newRV_noinc
8687
8688 Creates an RV wrapper for an SV.  The reference count for the original
8689 SV is B<not> incremented.
8690
8691 =cut
8692 */
8693
8694 SV *
8695 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8696 {
8697     dVAR;
8698     register SV *sv = newSV_type(SVt_IV);
8699
8700     PERL_ARGS_ASSERT_NEWRV_NOINC;
8701
8702     SvTEMP_off(tmpRef);
8703     SvRV_set(sv, tmpRef);
8704     SvROK_on(sv);
8705     return sv;
8706 }
8707
8708 /* newRV_inc is the official function name to use now.
8709  * newRV_inc is in fact #defined to newRV in sv.h
8710  */
8711
8712 SV *
8713 Perl_newRV(pTHX_ SV *const sv)
8714 {
8715     dVAR;
8716
8717     PERL_ARGS_ASSERT_NEWRV;
8718
8719     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8720 }
8721
8722 /*
8723 =for apidoc newSVsv
8724
8725 Creates a new SV which is an exact duplicate of the original SV.
8726 (Uses C<sv_setsv>.)
8727
8728 =cut
8729 */
8730
8731 SV *
8732 Perl_newSVsv(pTHX_ register SV *const old)
8733 {
8734     dVAR;
8735     register SV *sv;
8736
8737     if (!old)
8738         return NULL;
8739     if (SvTYPE(old) == (svtype)SVTYPEMASK) {
8740         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8741         return NULL;
8742     }
8743     new_SV(sv);
8744     /* SV_GMAGIC is the default for sv_setv()
8745        SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8746        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
8747     sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8748     return sv;
8749 }
8750
8751 /*
8752 =for apidoc sv_reset
8753
8754 Underlying implementation for the C<reset> Perl function.
8755 Note that the perl-level function is vaguely deprecated.
8756
8757 =cut
8758 */
8759
8760 void
8761 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8762 {
8763     dVAR;
8764     char todo[PERL_UCHAR_MAX+1];
8765
8766     PERL_ARGS_ASSERT_SV_RESET;
8767
8768     if (!stash)
8769         return;
8770
8771     if (!*s) {          /* reset ?? searches */
8772         MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8773         if (mg) {
8774             const U32 count = mg->mg_len / sizeof(PMOP**);
8775             PMOP **pmp = (PMOP**) mg->mg_ptr;
8776             PMOP *const *const end = pmp + count;
8777
8778             while (pmp < end) {
8779 #ifdef USE_ITHREADS
8780                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8781 #else
8782                 (*pmp)->op_pmflags &= ~PMf_USED;
8783 #endif
8784                 ++pmp;
8785             }
8786         }
8787         return;
8788     }
8789
8790     /* reset variables */
8791
8792     if (!HvARRAY(stash))
8793         return;
8794
8795     Zero(todo, 256, char);
8796     while (*s) {
8797         I32 max;
8798         I32 i = (unsigned char)*s;
8799         if (s[1] == '-') {
8800             s += 2;
8801         }
8802         max = (unsigned char)*s++;
8803         for ( ; i <= max; i++) {
8804             todo[i] = 1;
8805         }
8806         for (i = 0; i <= (I32) HvMAX(stash); i++) {
8807             HE *entry;
8808             for (entry = HvARRAY(stash)[i];
8809                  entry;
8810                  entry = HeNEXT(entry))
8811             {
8812                 register GV *gv;
8813                 register SV *sv;
8814
8815                 if (!todo[(U8)*HeKEY(entry)])
8816                     continue;
8817                 gv = MUTABLE_GV(HeVAL(entry));
8818                 sv = GvSV(gv);
8819                 if (sv) {
8820                     if (SvTHINKFIRST(sv)) {
8821                         if (!SvREADONLY(sv) && SvROK(sv))
8822                             sv_unref(sv);
8823                         /* XXX Is this continue a bug? Why should THINKFIRST
8824                            exempt us from resetting arrays and hashes?  */
8825                         continue;
8826                     }
8827                     SvOK_off(sv);
8828                     if (SvTYPE(sv) >= SVt_PV) {
8829                         SvCUR_set(sv, 0);
8830                         if (SvPVX_const(sv) != NULL)
8831                             *SvPVX(sv) = '\0';
8832                         SvTAINT(sv);
8833                     }
8834                 }
8835                 if (GvAV(gv)) {
8836                     av_clear(GvAV(gv));
8837                 }
8838                 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8839 #if defined(VMS)
8840                     Perl_die(aTHX_ "Can't reset %%ENV on this system");
8841 #else /* ! VMS */
8842                     hv_clear(GvHV(gv));
8843 #  if defined(USE_ENVIRON_ARRAY)
8844                     if (gv == PL_envgv)
8845                         my_clearenv();
8846 #  endif /* USE_ENVIRON_ARRAY */
8847 #endif /* VMS */
8848                 }
8849             }
8850         }
8851     }
8852 }
8853
8854 /*
8855 =for apidoc sv_2io
8856
8857 Using various gambits, try to get an IO from an SV: the IO slot if its a
8858 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8859 named after the PV if we're a string.
8860
8861 'Get' magic is ignored on the sv passed in, but will be called on
8862 C<SvRV(sv)> if sv is an RV.
8863
8864 =cut
8865 */
8866
8867 IO*
8868 Perl_sv_2io(pTHX_ SV *const sv)
8869 {
8870     IO* io;
8871     GV* gv;
8872
8873     PERL_ARGS_ASSERT_SV_2IO;
8874
8875     switch (SvTYPE(sv)) {
8876     case SVt_PVIO:
8877         io = MUTABLE_IO(sv);
8878         break;
8879     case SVt_PVGV:
8880     case SVt_PVLV:
8881         if (isGV_with_GP(sv)) {
8882             gv = MUTABLE_GV(sv);
8883             io = GvIO(gv);
8884             if (!io)
8885                 Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
8886                                     HEKfARG(GvNAME_HEK(gv)));
8887             break;
8888         }
8889         /* FALL THROUGH */
8890     default:
8891         if (!SvOK(sv))
8892             Perl_croak(aTHX_ PL_no_usym, "filehandle");
8893         if (SvROK(sv)) {
8894             SvGETMAGIC(SvRV(sv));
8895             return sv_2io(SvRV(sv));
8896         }
8897         gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
8898         if (gv)
8899             io = GvIO(gv);
8900         else
8901             io = 0;
8902         if (!io) {
8903             SV *newsv = sv;
8904             if (SvGMAGICAL(sv)) {
8905                 newsv = sv_newmortal();
8906                 sv_setsv_nomg(newsv, sv);
8907             }
8908             Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv));
8909         }
8910         break;
8911     }
8912     return io;
8913 }
8914
8915 /*
8916 =for apidoc sv_2cv
8917
8918 Using various gambits, try to get a CV from an SV; in addition, try if
8919 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8920 The flags in C<lref> are passed to gv_fetchsv.
8921
8922 =cut
8923 */
8924
8925 CV *
8926 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8927 {
8928     dVAR;
8929     GV *gv = NULL;
8930     CV *cv = NULL;
8931
8932     PERL_ARGS_ASSERT_SV_2CV;
8933
8934     if (!sv) {
8935         *st = NULL;
8936         *gvp = NULL;
8937         return NULL;
8938     }
8939     switch (SvTYPE(sv)) {
8940     case SVt_PVCV:
8941         *st = CvSTASH(sv);
8942         *gvp = NULL;
8943         return MUTABLE_CV(sv);
8944     case SVt_PVHV:
8945     case SVt_PVAV:
8946         *st = NULL;
8947         *gvp = NULL;
8948         return NULL;
8949     default:
8950         SvGETMAGIC(sv);
8951         if (SvROK(sv)) {
8952             if (SvAMAGIC(sv))
8953                 sv = amagic_deref_call(sv, to_cv_amg);
8954
8955             sv = SvRV(sv);
8956             if (SvTYPE(sv) == SVt_PVCV) {
8957                 cv = MUTABLE_CV(sv);
8958                 *gvp = NULL;
8959                 *st = CvSTASH(cv);
8960                 return cv;
8961             }
8962             else if(SvGETMAGIC(sv), isGV_with_GP(sv))
8963                 gv = MUTABLE_GV(sv);
8964             else
8965                 Perl_croak(aTHX_ "Not a subroutine reference");
8966         }
8967         else if (isGV_with_GP(sv)) {
8968             gv = MUTABLE_GV(sv);
8969         }
8970         else {
8971             gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
8972         }
8973         *gvp = gv;
8974         if (!gv) {
8975             *st = NULL;
8976             return NULL;
8977         }
8978         /* Some flags to gv_fetchsv mean don't really create the GV  */
8979         if (!isGV_with_GP(gv)) {
8980             *st = NULL;
8981             return NULL;
8982         }
8983         *st = GvESTASH(gv);
8984         if (lref & ~GV_ADDMG && !GvCVu(gv)) {
8985             SV *tmpsv;
8986             ENTER;
8987             tmpsv = newSV(0);
8988             gv_efullname3(tmpsv, gv, NULL);
8989             /* XXX this is probably not what they think they're getting.
8990              * It has the same effect as "sub name;", i.e. just a forward
8991              * declaration! */
8992             newSUB(start_subparse(FALSE, 0),
8993                    newSVOP(OP_CONST, 0, tmpsv),
8994                    NULL, NULL);
8995             LEAVE;
8996             if (!GvCVu(gv))
8997                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8998                            SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8999         }
9000         return GvCVu(gv);
9001     }
9002 }
9003
9004 /*
9005 =for apidoc sv_true
9006
9007 Returns true if the SV has a true value by Perl's rules.
9008 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
9009 instead use an in-line version.
9010
9011 =cut
9012 */
9013
9014 I32
9015 Perl_sv_true(pTHX_ register SV *const sv)
9016 {
9017     if (!sv)
9018         return 0;
9019     if (SvPOK(sv)) {
9020         register const XPV* const tXpv = (XPV*)SvANY(sv);
9021         if (tXpv &&
9022                 (tXpv->xpv_cur > 1 ||
9023                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
9024             return 1;
9025         else
9026             return 0;
9027     }
9028     else {
9029         if (SvIOK(sv))
9030             return SvIVX(sv) != 0;
9031         else {
9032             if (SvNOK(sv))
9033                 return SvNVX(sv) != 0.0;
9034             else
9035                 return sv_2bool(sv);
9036         }
9037     }
9038 }
9039
9040 /*
9041 =for apidoc sv_pvn_force
9042
9043 Get a sensible string out of the SV somehow.
9044 A private implementation of the C<SvPV_force> macro for compilers which
9045 can't cope with complex macro expressions.  Always use the macro instead.
9046
9047 =for apidoc sv_pvn_force_flags
9048
9049 Get a sensible string out of the SV somehow.
9050 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
9051 appropriate, else not.  C<sv_pvn_force> and C<sv_pvn_force_nomg> are
9052 implemented in terms of this function.
9053 You normally want to use the various wrapper macros instead: see
9054 C<SvPV_force> and C<SvPV_force_nomg>
9055
9056 =cut
9057 */
9058
9059 char *
9060 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
9061 {
9062     dVAR;
9063
9064     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
9065
9066     if (flags & SV_GMAGIC) SvGETMAGIC(sv);
9067     if (SvTHINKFIRST(sv) && !SvROK(sv))
9068         sv_force_normal_flags(sv, 0);
9069
9070     if (SvPOK(sv)) {
9071         if (lp)
9072             *lp = SvCUR(sv);
9073     }
9074     else {
9075         char *s;
9076         STRLEN len;
9077
9078         if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
9079             const char * const ref = sv_reftype(sv,0);
9080             if (PL_op)
9081                 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
9082                            ref, OP_DESC(PL_op));
9083             else
9084                 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
9085         }
9086         if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
9087             || isGV_with_GP(sv))
9088             /* diag_listed_as: Can't coerce %s to %s in %s */
9089             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
9090                 OP_DESC(PL_op));
9091         s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
9092         if (lp)
9093             *lp = len;
9094
9095         if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
9096             if (SvROK(sv))
9097                 sv_unref(sv);
9098             SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
9099             SvGROW(sv, len + 1);
9100             Move(s,SvPVX(sv),len,char);
9101             SvCUR_set(sv, len);
9102             SvPVX(sv)[len] = '\0';
9103         }
9104         if (!SvPOK(sv)) {
9105             SvPOK_on(sv);               /* validate pointer */
9106             SvTAINT(sv);
9107             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
9108                                   PTR2UV(sv),SvPVX_const(sv)));
9109         }
9110     }
9111     return SvPVX_mutable(sv);
9112 }
9113
9114 /*
9115 =for apidoc sv_pvbyten_force
9116
9117 The backend for the C<SvPVbytex_force> macro.  Always use the macro
9118 instead.
9119
9120 =cut
9121 */
9122
9123 char *
9124 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
9125 {
9126     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
9127
9128     sv_pvn_force(sv,lp);
9129     sv_utf8_downgrade(sv,0);
9130     *lp = SvCUR(sv);
9131     return SvPVX(sv);
9132 }
9133
9134 /*
9135 =for apidoc sv_pvutf8n_force
9136
9137 The backend for the C<SvPVutf8x_force> macro.  Always use the macro
9138 instead.
9139
9140 =cut
9141 */
9142
9143 char *
9144 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9145 {
9146     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9147
9148     sv_pvn_force(sv,lp);
9149     sv_utf8_upgrade(sv);
9150     *lp = SvCUR(sv);
9151     return SvPVX(sv);
9152 }
9153
9154 /*
9155 =for apidoc sv_reftype
9156
9157 Returns a string describing what the SV is a reference to.
9158
9159 =cut
9160 */
9161
9162 const char *
9163 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9164 {
9165     PERL_ARGS_ASSERT_SV_REFTYPE;
9166     if (ob && SvOBJECT(sv)) {
9167         return SvPV_nolen_const(sv_ref(NULL, sv, ob));
9168     }
9169     else {
9170         switch (SvTYPE(sv)) {
9171         case SVt_NULL:
9172         case SVt_IV:
9173         case SVt_NV:
9174         case SVt_PV:
9175         case SVt_PVIV:
9176         case SVt_PVNV:
9177         case SVt_PVMG:
9178                                 if (SvVOK(sv))
9179                                     return "VSTRING";
9180                                 if (SvROK(sv))
9181                                     return "REF";
9182                                 else
9183                                     return "SCALAR";
9184
9185         case SVt_PVLV:          return (char *)  (SvROK(sv) ? "REF"
9186                                 /* tied lvalues should appear to be
9187                                  * scalars for backwards compatibility */
9188                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9189                                     ? "SCALAR" : "LVALUE");
9190         case SVt_PVAV:          return "ARRAY";
9191         case SVt_PVHV:          return "HASH";
9192         case SVt_PVCV:          return "CODE";
9193         case SVt_PVGV:          return (char *) (isGV_with_GP(sv)
9194                                     ? "GLOB" : "SCALAR");
9195         case SVt_PVFM:          return "FORMAT";
9196         case SVt_PVIO:          return "IO";
9197         case SVt_BIND:          return "BIND";
9198         case SVt_REGEXP:        return "REGEXP";
9199         default:                return "UNKNOWN";
9200         }
9201     }
9202 }
9203
9204 /*
9205 =for apidoc sv_ref
9206
9207 Returns a SV describing what the SV passed in is a reference to.
9208
9209 =cut
9210 */
9211
9212 SV *
9213 Perl_sv_ref(pTHX_ register SV *dst, const SV *const sv, const int ob)
9214 {
9215     PERL_ARGS_ASSERT_SV_REF;
9216
9217     if (!dst)
9218         dst = sv_newmortal();
9219
9220     if (ob && SvOBJECT(sv)) {
9221         HvNAME_get(SvSTASH(sv))
9222                     ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
9223                     : sv_setpvn(dst, "__ANON__", 8);
9224     }
9225     else {
9226         const char * reftype = sv_reftype(sv, 0);
9227         sv_setpv(dst, reftype);
9228     }
9229     return dst;
9230 }
9231
9232 /*
9233 =for apidoc sv_isobject
9234
9235 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9236 object.  If the SV is not an RV, or if the object is not blessed, then this
9237 will return false.
9238
9239 =cut
9240 */
9241
9242 int
9243 Perl_sv_isobject(pTHX_ SV *sv)
9244 {
9245     if (!sv)
9246         return 0;
9247     SvGETMAGIC(sv);
9248     if (!SvROK(sv))
9249         return 0;
9250     sv = SvRV(sv);
9251     if (!SvOBJECT(sv))
9252         return 0;
9253     return 1;
9254 }
9255
9256 /*
9257 =for apidoc sv_isa
9258
9259 Returns a boolean indicating whether the SV is blessed into the specified
9260 class.  This does not check for subtypes; use C<sv_derived_from> to verify
9261 an inheritance relationship.
9262
9263 =cut
9264 */
9265
9266 int
9267 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9268 {
9269     const char *hvname;
9270
9271     PERL_ARGS_ASSERT_SV_ISA;
9272
9273     if (!sv)
9274         return 0;
9275     SvGETMAGIC(sv);
9276     if (!SvROK(sv))
9277         return 0;
9278     sv = SvRV(sv);
9279     if (!SvOBJECT(sv))
9280         return 0;
9281     hvname = HvNAME_get(SvSTASH(sv));
9282     if (!hvname)
9283         return 0;
9284
9285     return strEQ(hvname, name);
9286 }
9287
9288 /*
9289 =for apidoc newSVrv
9290
9291 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
9292 it will be upgraded to one.  If C<classname> is non-null then the new SV will
9293 be blessed in the specified package.  The new SV is returned and its
9294 reference count is 1.
9295
9296 =cut
9297 */
9298
9299 SV*
9300 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9301 {
9302     dVAR;
9303     SV *sv;
9304
9305     PERL_ARGS_ASSERT_NEWSVRV;
9306
9307     new_SV(sv);
9308
9309     SV_CHECK_THINKFIRST_COW_DROP(rv);
9310     (void)SvAMAGIC_off(rv);
9311
9312     if (SvTYPE(rv) >= SVt_PVMG) {
9313         const U32 refcnt = SvREFCNT(rv);
9314         SvREFCNT(rv) = 0;
9315         sv_clear(rv);
9316         SvFLAGS(rv) = 0;
9317         SvREFCNT(rv) = refcnt;
9318
9319         sv_upgrade(rv, SVt_IV);
9320     } else if (SvROK(rv)) {
9321         SvREFCNT_dec(SvRV(rv));
9322     } else {
9323         prepare_SV_for_RV(rv);
9324     }
9325
9326     SvOK_off(rv);
9327     SvRV_set(rv, sv);
9328     SvROK_on(rv);
9329
9330     if (classname) {
9331         HV* const stash = gv_stashpv(classname, GV_ADD);
9332         (void)sv_bless(rv, stash);
9333     }
9334     return sv;
9335 }
9336
9337 /*
9338 =for apidoc sv_setref_pv
9339
9340 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
9341 argument will be upgraded to an RV.  That RV will be modified to point to
9342 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9343 into the SV.  The C<classname> argument indicates the package for the
9344 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9345 will have a reference count of 1, and the RV will be returned.
9346
9347 Do not use with other Perl types such as HV, AV, SV, CV, because those
9348 objects will become corrupted by the pointer copy process.
9349
9350 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9351
9352 =cut
9353 */
9354
9355 SV*
9356 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9357 {
9358     dVAR;
9359
9360     PERL_ARGS_ASSERT_SV_SETREF_PV;
9361
9362     if (!pv) {
9363         sv_setsv(rv, &PL_sv_undef);
9364         SvSETMAGIC(rv);
9365     }
9366     else
9367         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9368     return rv;
9369 }
9370
9371 /*
9372 =for apidoc sv_setref_iv
9373
9374 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
9375 argument will be upgraded to an RV.  That RV will be modified to point to
9376 the new SV.  The C<classname> argument indicates the package for the
9377 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9378 will have a reference count of 1, and the RV will be returned.
9379
9380 =cut
9381 */
9382
9383 SV*
9384 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9385 {
9386     PERL_ARGS_ASSERT_SV_SETREF_IV;
9387
9388     sv_setiv(newSVrv(rv,classname), iv);
9389     return rv;
9390 }
9391
9392 /*
9393 =for apidoc sv_setref_uv
9394
9395 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
9396 argument will be upgraded to an RV.  That RV will be modified to point to
9397 the new SV.  The C<classname> argument indicates the package for the
9398 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9399 will have a reference count of 1, and the RV will be returned.
9400
9401 =cut
9402 */
9403
9404 SV*
9405 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9406 {
9407     PERL_ARGS_ASSERT_SV_SETREF_UV;
9408
9409     sv_setuv(newSVrv(rv,classname), uv);
9410     return rv;
9411 }
9412
9413 /*
9414 =for apidoc sv_setref_nv
9415
9416 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
9417 argument will be upgraded to an RV.  That RV will be modified to point to
9418 the new SV.  The C<classname> argument indicates the package for the
9419 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
9420 will have a reference count of 1, and the RV will be returned.
9421
9422 =cut
9423 */
9424
9425 SV*
9426 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9427 {
9428     PERL_ARGS_ASSERT_SV_SETREF_NV;
9429
9430     sv_setnv(newSVrv(rv,classname), nv);
9431     return rv;
9432 }
9433
9434 /*
9435 =for apidoc sv_setref_pvn
9436
9437 Copies a string into a new SV, optionally blessing the SV.  The length of the
9438 string must be specified with C<n>.  The C<rv> argument will be upgraded to
9439 an RV.  That RV will be modified to point to the new SV.  The C<classname>
9440 argument indicates the package for the blessing.  Set C<classname> to
9441 C<NULL> to avoid the blessing.  The new SV will have a reference count
9442 of 1, and the RV will be returned.
9443
9444 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9445
9446 =cut
9447 */
9448
9449 SV*
9450 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9451                    const char *const pv, const STRLEN n)
9452 {
9453     PERL_ARGS_ASSERT_SV_SETREF_PVN;
9454
9455     sv_setpvn(newSVrv(rv,classname), pv, n);
9456     return rv;
9457 }
9458
9459 /*
9460 =for apidoc sv_bless
9461
9462 Blesses an SV into a specified package.  The SV must be an RV.  The package
9463 must be designated by its stash (see C<gv_stashpv()>).  The reference count
9464 of the SV is unaffected.
9465
9466 =cut
9467 */
9468
9469 SV*
9470 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9471 {
9472     dVAR;
9473     SV *tmpRef;
9474
9475     PERL_ARGS_ASSERT_SV_BLESS;
9476
9477     if (!SvROK(sv))
9478         Perl_croak(aTHX_ "Can't bless non-reference value");
9479     tmpRef = SvRV(sv);
9480     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9481         if (SvIsCOW(tmpRef))
9482             sv_force_normal_flags(tmpRef, 0);
9483         if (SvREADONLY(tmpRef))
9484             Perl_croak_no_modify(aTHX);
9485         if (SvOBJECT(tmpRef)) {
9486             if (SvTYPE(tmpRef) != SVt_PVIO)
9487                 --PL_sv_objcount;
9488             SvREFCNT_dec(SvSTASH(tmpRef));
9489         }
9490     }
9491     SvOBJECT_on(tmpRef);
9492     if (SvTYPE(tmpRef) != SVt_PVIO)
9493         ++PL_sv_objcount;
9494     SvUPGRADE(tmpRef, SVt_PVMG);
9495     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9496
9497     if (Gv_AMG(stash))
9498         SvAMAGIC_on(sv);
9499     else
9500         (void)SvAMAGIC_off(sv);
9501
9502     if(SvSMAGICAL(tmpRef))
9503         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9504             mg_set(tmpRef);
9505
9506
9507
9508     return sv;
9509 }
9510
9511 /* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
9512  * as it is after unglobbing it.
9513  */
9514
9515 PERL_STATIC_INLINE void
9516 S_sv_unglob(pTHX_ SV *const sv, U32 flags)
9517 {
9518     dVAR;
9519     void *xpvmg;
9520     HV *stash;
9521     SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
9522
9523     PERL_ARGS_ASSERT_SV_UNGLOB;
9524
9525     assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9526     SvFAKE_off(sv);
9527     if (!(flags & SV_COW_DROP_PV))
9528         gv_efullname3(temp, MUTABLE_GV(sv), "*");
9529
9530     if (GvGP(sv)) {
9531         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9532            && HvNAME_get(stash))
9533             mro_method_changed_in(stash);
9534         gp_free(MUTABLE_GV(sv));
9535     }
9536     if (GvSTASH(sv)) {
9537         sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9538         GvSTASH(sv) = NULL;
9539     }
9540     GvMULTI_off(sv);
9541     if (GvNAME_HEK(sv)) {
9542         unshare_hek(GvNAME_HEK(sv));
9543     }
9544     isGV_with_GP_off(sv);
9545
9546     if(SvTYPE(sv) == SVt_PVGV) {
9547         /* need to keep SvANY(sv) in the right arena */
9548         xpvmg = new_XPVMG();
9549         StructCopy(SvANY(sv), xpvmg, XPVMG);
9550         del_XPVGV(SvANY(sv));
9551         SvANY(sv) = xpvmg;
9552
9553         SvFLAGS(sv) &= ~SVTYPEMASK;
9554         SvFLAGS(sv) |= SVt_PVMG;
9555     }
9556
9557     /* Intentionally not calling any local SET magic, as this isn't so much a
9558        set operation as merely an internal storage change.  */
9559     if (flags & SV_COW_DROP_PV) SvOK_off(sv);
9560     else sv_setsv_flags(sv, temp, 0);
9561
9562     if ((const GV *)sv == PL_last_in_gv)
9563         PL_last_in_gv = NULL;
9564     else if ((const GV *)sv == PL_statgv)
9565         PL_statgv = NULL;
9566 }
9567
9568 /*
9569 =for apidoc sv_unref_flags
9570
9571 Unsets the RV status of the SV, and decrements the reference count of
9572 whatever was being referenced by the RV.  This can almost be thought of
9573 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
9574 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9575 (otherwise the decrementing is conditional on the reference count being
9576 different from one or the reference being a readonly SV).
9577 See C<SvROK_off>.
9578
9579 =cut
9580 */
9581
9582 void
9583 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9584 {
9585     SV* const target = SvRV(ref);
9586
9587     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9588
9589     if (SvWEAKREF(ref)) {
9590         sv_del_backref(target, ref);
9591         SvWEAKREF_off(ref);
9592         SvRV_set(ref, NULL);
9593         return;
9594     }
9595     SvRV_set(ref, NULL);
9596     SvROK_off(ref);
9597     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9598        assigned to as BEGIN {$a = \"Foo"} will fail.  */
9599     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9600         SvREFCNT_dec(target);
9601     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9602         sv_2mortal(target);     /* Schedule for freeing later */
9603 }
9604
9605 /*
9606 =for apidoc sv_untaint
9607
9608 Untaint an SV.  Use C<SvTAINTED_off> instead.
9609
9610 =cut
9611 */
9612
9613 void
9614 Perl_sv_untaint(pTHX_ SV *const sv)
9615 {
9616     PERL_ARGS_ASSERT_SV_UNTAINT;
9617
9618     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9619         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9620         if (mg)
9621             mg->mg_len &= ~1;
9622     }
9623 }
9624
9625 /*
9626 =for apidoc sv_tainted
9627
9628 Test an SV for taintedness.  Use C<SvTAINTED> instead.
9629
9630 =cut
9631 */
9632
9633 bool
9634 Perl_sv_tainted(pTHX_ SV *const sv)
9635 {
9636     PERL_ARGS_ASSERT_SV_TAINTED;
9637
9638     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9639         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9640         if (mg && (mg->mg_len & 1) )
9641             return TRUE;
9642     }
9643     return FALSE;
9644 }
9645
9646 /*
9647 =for apidoc sv_setpviv
9648
9649 Copies an integer into the given SV, also updating its string value.
9650 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
9651
9652 =cut
9653 */
9654
9655 void
9656 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9657 {
9658     char buf[TYPE_CHARS(UV)];
9659     char *ebuf;
9660     char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9661
9662     PERL_ARGS_ASSERT_SV_SETPVIV;
9663
9664     sv_setpvn(sv, ptr, ebuf - ptr);
9665 }
9666
9667 /*
9668 =for apidoc sv_setpviv_mg
9669
9670 Like C<sv_setpviv>, but also handles 'set' magic.
9671
9672 =cut
9673 */
9674
9675 void
9676 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9677 {
9678     PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9679
9680     sv_setpviv(sv, iv);
9681     SvSETMAGIC(sv);
9682 }
9683
9684 #if defined(PERL_IMPLICIT_CONTEXT)
9685
9686 /* pTHX_ magic can't cope with varargs, so this is a no-context
9687  * version of the main function, (which may itself be aliased to us).
9688  * Don't access this version directly.
9689  */
9690
9691 void
9692 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9693 {
9694     dTHX;
9695     va_list args;
9696
9697     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9698
9699     va_start(args, pat);
9700     sv_vsetpvf(sv, pat, &args);
9701     va_end(args);
9702 }
9703
9704 /* pTHX_ magic can't cope with varargs, so this is a no-context
9705  * version of the main function, (which may itself be aliased to us).
9706  * Don't access this version directly.
9707  */
9708
9709 void
9710 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9711 {
9712     dTHX;
9713     va_list args;
9714
9715     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9716
9717     va_start(args, pat);
9718     sv_vsetpvf_mg(sv, pat, &args);
9719     va_end(args);
9720 }
9721 #endif
9722
9723 /*
9724 =for apidoc sv_setpvf
9725
9726 Works like C<sv_catpvf> but copies the text into the SV instead of
9727 appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
9728
9729 =cut
9730 */
9731
9732 void
9733 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9734 {
9735     va_list args;
9736
9737     PERL_ARGS_ASSERT_SV_SETPVF;
9738
9739     va_start(args, pat);
9740     sv_vsetpvf(sv, pat, &args);
9741     va_end(args);
9742 }
9743
9744 /*
9745 =for apidoc sv_vsetpvf
9746
9747 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9748 appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
9749
9750 Usually used via its frontend C<sv_setpvf>.
9751
9752 =cut
9753 */
9754
9755 void
9756 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9757 {
9758     PERL_ARGS_ASSERT_SV_VSETPVF;
9759
9760     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9761 }
9762
9763 /*
9764 =for apidoc sv_setpvf_mg
9765
9766 Like C<sv_setpvf>, but also handles 'set' magic.
9767
9768 =cut
9769 */
9770
9771 void
9772 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9773 {
9774     va_list args;
9775
9776     PERL_ARGS_ASSERT_SV_SETPVF_MG;
9777
9778     va_start(args, pat);
9779     sv_vsetpvf_mg(sv, pat, &args);
9780     va_end(args);
9781 }
9782
9783 /*
9784 =for apidoc sv_vsetpvf_mg
9785
9786 Like C<sv_vsetpvf>, but also handles 'set' magic.
9787
9788 Usually used via its frontend C<sv_setpvf_mg>.
9789
9790 =cut
9791 */
9792
9793 void
9794 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9795 {
9796     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9797
9798     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9799     SvSETMAGIC(sv);
9800 }
9801
9802 #if defined(PERL_IMPLICIT_CONTEXT)
9803
9804 /* pTHX_ magic can't cope with varargs, so this is a no-context
9805  * version of the main function, (which may itself be aliased to us).
9806  * Don't access this version directly.
9807  */
9808
9809 void
9810 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9811 {
9812     dTHX;
9813     va_list args;
9814
9815     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9816
9817     va_start(args, pat);
9818     sv_vcatpvf(sv, pat, &args);
9819     va_end(args);
9820 }
9821
9822 /* pTHX_ magic can't cope with varargs, so this is a no-context
9823  * version of the main function, (which may itself be aliased to us).
9824  * Don't access this version directly.
9825  */
9826
9827 void
9828 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9829 {
9830     dTHX;
9831     va_list args;
9832
9833     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9834
9835     va_start(args, pat);
9836     sv_vcatpvf_mg(sv, pat, &args);
9837     va_end(args);
9838 }
9839 #endif
9840
9841 /*
9842 =for apidoc sv_catpvf
9843
9844 Processes its arguments like C<sprintf> and appends the formatted
9845 output to an SV.  If the appended data contains "wide" characters
9846 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9847 and characters >255 formatted with %c), the original SV might get
9848 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
9849 C<sv_catpvf_mg>.  If the original SV was UTF-8, the pattern should be
9850 valid UTF-8; if the original SV was bytes, the pattern should be too.
9851
9852 =cut */
9853
9854 void
9855 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9856 {
9857     va_list args;
9858
9859     PERL_ARGS_ASSERT_SV_CATPVF;
9860
9861     va_start(args, pat);
9862     sv_vcatpvf(sv, pat, &args);
9863     va_end(args);
9864 }
9865
9866 /*
9867 =for apidoc sv_vcatpvf
9868
9869 Processes its arguments like C<vsprintf> and appends the formatted output
9870 to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
9871
9872 Usually used via its frontend C<sv_catpvf>.
9873
9874 =cut
9875 */
9876
9877 void
9878 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9879 {
9880     PERL_ARGS_ASSERT_SV_VCATPVF;
9881
9882     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9883 }
9884
9885 /*
9886 =for apidoc sv_catpvf_mg
9887
9888 Like C<sv_catpvf>, but also handles 'set' magic.
9889
9890 =cut
9891 */
9892
9893 void
9894 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9895 {
9896     va_list args;
9897
9898     PERL_ARGS_ASSERT_SV_CATPVF_MG;
9899
9900     va_start(args, pat);
9901     sv_vcatpvf_mg(sv, pat, &args);
9902     va_end(args);
9903 }
9904
9905 /*
9906 =for apidoc sv_vcatpvf_mg
9907
9908 Like C<sv_vcatpvf>, but also handles 'set' magic.
9909
9910 Usually used via its frontend C<sv_catpvf_mg>.
9911
9912 =cut
9913 */
9914
9915 void
9916 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9917 {
9918     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9919
9920     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9921     SvSETMAGIC(sv);
9922 }
9923
9924 /*
9925 =for apidoc sv_vsetpvfn
9926
9927 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9928 appending it.
9929
9930 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9931
9932 =cut
9933 */
9934
9935 void
9936 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9937                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9938 {
9939     PERL_ARGS_ASSERT_SV_VSETPVFN;
9940
9941     sv_setpvs(sv, "");
9942     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9943 }
9944
9945
9946 /*
9947  * Warn of missing argument to sprintf, and then return a defined value
9948  * to avoid inappropriate "use of uninit" warnings [perl #71000].
9949  */
9950 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9951 STATIC SV*
9952 S_vcatpvfn_missing_argument(pTHX) {
9953     if (ckWARN(WARN_MISSING)) {
9954         Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9955                 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9956     }
9957     return &PL_sv_no;
9958 }
9959
9960
9961 STATIC I32
9962 S_expect_number(pTHX_ char **const pattern)
9963 {
9964     dVAR;
9965     I32 var = 0;
9966
9967     PERL_ARGS_ASSERT_EXPECT_NUMBER;
9968
9969     switch (**pattern) {
9970     case '1': case '2': case '3':
9971     case '4': case '5': case '6':
9972     case '7': case '8': case '9':
9973         var = *(*pattern)++ - '0';
9974         while (isDIGIT(**pattern)) {
9975             const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9976             if (tmp < var)
9977                 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9978             var = tmp;
9979         }
9980     }
9981     return var;
9982 }
9983
9984 STATIC char *
9985 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9986 {
9987     const int neg = nv < 0;
9988     UV uv;
9989
9990     PERL_ARGS_ASSERT_F0CONVERT;
9991
9992     if (neg)
9993         nv = -nv;
9994     if (nv < UV_MAX) {
9995         char *p = endbuf;
9996         nv += 0.5;
9997         uv = (UV)nv;
9998         if (uv & 1 && uv == nv)
9999             uv--;                       /* Round to even */
10000         do {
10001             const unsigned dig = uv % 10;
10002             *--p = '0' + dig;
10003         } while (uv /= 10);
10004         if (neg)
10005             *--p = '-';
10006         *len = endbuf - p;
10007         return p;
10008     }
10009     return NULL;
10010 }
10011
10012
10013 /*
10014 =for apidoc sv_vcatpvfn
10015
10016 Processes its arguments like C<vsprintf> and appends the formatted output
10017 to an SV.  Uses an array of SVs if the C style variable argument list is
10018 missing (NULL).  When running with taint checks enabled, indicates via
10019 C<maybe_tainted> if results are untrustworthy (often due to the use of
10020 locales).
10021
10022 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
10023
10024 =cut
10025 */
10026
10027
10028 #define VECTORIZE_ARGS  vecsv = va_arg(*args, SV*);\
10029                         vecstr = (U8*)SvPV_const(vecsv,veclen);\
10030                         vec_utf8 = DO_UTF8(vecsv);
10031
10032 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
10033
10034 void
10035 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10036                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10037 {
10038     dVAR;
10039     char *p;
10040     char *q;
10041     const char *patend;
10042     STRLEN origlen;
10043     I32 svix = 0;
10044     static const char nullstr[] = "(null)";
10045     SV *argsv = NULL;
10046     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
10047     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
10048     SV *nsv = NULL;
10049     /* Times 4: a decimal digit takes more than 3 binary digits.
10050      * NV_DIG: mantissa takes than many decimal digits.
10051      * Plus 32: Playing safe. */
10052     char ebuf[IV_DIG * 4 + NV_DIG + 32];
10053     /* large enough for "%#.#f" --chip */
10054     /* what about long double NVs? --jhi */
10055
10056     PERL_ARGS_ASSERT_SV_VCATPVFN;
10057     PERL_UNUSED_ARG(maybe_tainted);
10058
10059     /* no matter what, this is a string now */
10060     (void)SvPV_force(sv, origlen);
10061
10062     /* special-case "", "%s", and "%-p" (SVf - see below) */
10063     if (patlen == 0)
10064         return;
10065     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
10066         if (args) {
10067             const char * const s = va_arg(*args, char*);
10068             sv_catpv(sv, s ? s : nullstr);
10069         }
10070         else if (svix < svmax) {
10071             sv_catsv(sv, *svargs);
10072         }
10073         else
10074             S_vcatpvfn_missing_argument(aTHX);
10075         return;
10076     }
10077     if (args && patlen == 3 && pat[0] == '%' &&
10078                 pat[1] == '-' && pat[2] == 'p') {
10079         argsv = MUTABLE_SV(va_arg(*args, void*));
10080         sv_catsv(sv, argsv);
10081         return;
10082     }
10083
10084 #ifndef USE_LONG_DOUBLE
10085     /* special-case "%.<number>[gf]" */
10086     if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
10087          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
10088         unsigned digits = 0;
10089         const char *pp;
10090
10091         pp = pat + 2;
10092         while (*pp >= '0' && *pp <= '9')
10093             digits = 10 * digits + (*pp++ - '0');
10094         if (pp - pat == (int)patlen - 1 && svix < svmax) {
10095             const NV nv = SvNV(*svargs);
10096             if (*pp == 'g') {
10097                 /* Add check for digits != 0 because it seems that some
10098                    gconverts are buggy in this case, and we don't yet have
10099                    a Configure test for this.  */
10100                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
10101                      /* 0, point, slack */
10102                     Gconvert(nv, (int)digits, 0, ebuf);
10103                     sv_catpv(sv, ebuf);
10104                     if (*ebuf)  /* May return an empty string for digits==0 */
10105                         return;
10106                 }
10107             } else if (!digits) {
10108                 STRLEN l;
10109
10110                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
10111                     sv_catpvn(sv, p, l);
10112                     return;
10113                 }
10114             }
10115         }
10116     }
10117 #endif /* !USE_LONG_DOUBLE */
10118
10119     if (!args && svix < svmax && DO_UTF8(*svargs))
10120         has_utf8 = TRUE;
10121
10122     patend = (char*)pat + patlen;
10123     for (p = (char*)pat; p < patend; p = q) {
10124         bool alt = FALSE;
10125         bool left = FALSE;
10126         bool vectorize = FALSE;
10127         bool vectorarg = FALSE;
10128         bool vec_utf8 = FALSE;
10129         char fill = ' ';
10130         char plus = 0;
10131         char intsize = 0;
10132         STRLEN width = 0;
10133         STRLEN zeros = 0;
10134         bool has_precis = FALSE;
10135         STRLEN precis = 0;
10136         const I32 osvix = svix;
10137         bool is_utf8 = FALSE;  /* is this item utf8?   */
10138 #ifdef HAS_LDBL_SPRINTF_BUG
10139         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10140            with sfio - Allen <allens@cpan.org> */
10141         bool fix_ldbl_sprintf_bug = FALSE;
10142 #endif
10143
10144         char esignbuf[4];
10145         U8 utf8buf[UTF8_MAXBYTES+1];
10146         STRLEN esignlen = 0;
10147
10148         const char *eptr = NULL;
10149         const char *fmtstart;
10150         STRLEN elen = 0;
10151         SV *vecsv = NULL;
10152         const U8 *vecstr = NULL;
10153         STRLEN veclen = 0;
10154         char c = 0;
10155         int i;
10156         unsigned base = 0;
10157         IV iv = 0;
10158         UV uv = 0;
10159         /* we need a long double target in case HAS_LONG_DOUBLE but
10160            not USE_LONG_DOUBLE
10161         */
10162 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
10163         long double nv;
10164 #else
10165         NV nv;
10166 #endif
10167         STRLEN have;
10168         STRLEN need;
10169         STRLEN gap;
10170         const char *dotstr = ".";
10171         STRLEN dotstrlen = 1;
10172         I32 efix = 0; /* explicit format parameter index */
10173         I32 ewix = 0; /* explicit width index */
10174         I32 epix = 0; /* explicit precision index */
10175         I32 evix = 0; /* explicit vector index */
10176         bool asterisk = FALSE;
10177
10178         /* echo everything up to the next format specification */
10179         for (q = p; q < patend && *q != '%'; ++q) ;
10180         if (q > p) {
10181             if (has_utf8 && !pat_utf8)
10182                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
10183             else
10184                 sv_catpvn(sv, p, q - p);
10185             p = q;
10186         }
10187         if (q++ >= patend)
10188             break;
10189
10190         fmtstart = q;
10191
10192 /*
10193     We allow format specification elements in this order:
10194         \d+\$              explicit format parameter index
10195         [-+ 0#]+           flags
10196         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
10197         0                  flag (as above): repeated to allow "v02"
10198         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
10199         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10200         [hlqLV]            size
10201     [%bcdefginopsuxDFOUX] format (mandatory)
10202 */
10203
10204         if (args) {
10205 /*
10206         As of perl5.9.3, printf format checking is on by default.
10207         Internally, perl uses %p formats to provide an escape to
10208         some extended formatting.  This block deals with those
10209         extensions: if it does not match, (char*)q is reset and
10210         the normal format processing code is used.
10211
10212         Currently defined extensions are:
10213                 %p              include pointer address (standard)
10214                 %-p     (SVf)   include an SV (previously %_)
10215                 %-<num>p        include an SV with precision <num>
10216                 %2p             include a HEK
10217                 %3p             include a HEK with precision of 256
10218                 %<num>p         (where num != 2 or 3) reserved for future
10219                                 extensions
10220
10221         Robin Barker 2005-07-14 (but modified since)
10222
10223                 %1p     (VDf)   removed.  RMB 2007-10-19
10224 */
10225             char* r = q;
10226             bool sv = FALSE;
10227             STRLEN n = 0;
10228             if (*q == '-')
10229                 sv = *q++;
10230             n = expect_number(&q);
10231             if (*q++ == 'p') {
10232                 if (sv) {                       /* SVf */
10233                     if (n) {
10234                         precis = n;
10235                         has_precis = TRUE;
10236                     }
10237                     argsv = MUTABLE_SV(va_arg(*args, void*));
10238                     eptr = SvPV_const(argsv, elen);
10239                     if (DO_UTF8(argsv))
10240                         is_utf8 = TRUE;
10241                     goto string;
10242                 }
10243                 else if (n==2 || n==3) {        /* HEKf */
10244                     HEK * const hek = va_arg(*args, HEK *);
10245                     eptr = HEK_KEY(hek);
10246                     elen = HEK_LEN(hek);
10247                     if (HEK_UTF8(hek)) is_utf8 = TRUE;
10248                     if (n==3) precis = 256, has_precis = TRUE;
10249                     goto string;
10250                 }
10251                 else if (n) {
10252                     Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10253                                      "internal %%<num>p might conflict with future printf extensions");
10254                 }
10255             }
10256             q = r;
10257         }
10258
10259         if ( (width = expect_number(&q)) ) {
10260             if (*q == '$') {
10261                 ++q;
10262                 efix = width;
10263             } else {
10264                 goto gotwidth;
10265             }
10266         }
10267
10268         /* FLAGS */
10269
10270         while (*q) {
10271             switch (*q) {
10272             case ' ':
10273             case '+':
10274                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10275                     q++;
10276                 else
10277                     plus = *q++;
10278                 continue;
10279
10280             case '-':
10281                 left = TRUE;
10282                 q++;
10283                 continue;
10284
10285             case '0':
10286                 fill = *q++;
10287                 continue;
10288
10289             case '#':
10290                 alt = TRUE;
10291                 q++;
10292                 continue;
10293
10294             default:
10295                 break;
10296             }
10297             break;
10298         }
10299
10300       tryasterisk:
10301         if (*q == '*') {
10302             q++;
10303             if ( (ewix = expect_number(&q)) )
10304                 if (*q++ != '$')
10305                     goto unknown;
10306             asterisk = TRUE;
10307         }
10308         if (*q == 'v') {
10309             q++;
10310             if (vectorize)
10311                 goto unknown;
10312             if ((vectorarg = asterisk)) {
10313                 evix = ewix;
10314                 ewix = 0;
10315                 asterisk = FALSE;
10316             }
10317             vectorize = TRUE;
10318             goto tryasterisk;
10319         }
10320
10321         if (!asterisk)
10322         {
10323             if( *q == '0' )
10324                 fill = *q++;
10325             width = expect_number(&q);
10326         }
10327
10328         if (vectorize && vectorarg) {
10329             /* vectorizing, but not with the default "." */
10330             if (args)
10331                 vecsv = va_arg(*args, SV*);
10332             else if (evix) {
10333                 vecsv = (evix > 0 && evix <= svmax)
10334                     ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10335             } else {
10336                 vecsv = svix < svmax
10337                     ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10338             }
10339             dotstr = SvPV_const(vecsv, dotstrlen);
10340             /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10341                bad with tied or overloaded values that return UTF8.  */
10342             if (DO_UTF8(vecsv))
10343                 is_utf8 = TRUE;
10344             else if (has_utf8) {
10345                 vecsv = sv_mortalcopy(vecsv);
10346                 sv_utf8_upgrade(vecsv);
10347                 dotstr = SvPV_const(vecsv, dotstrlen);
10348                 is_utf8 = TRUE;
10349             }
10350         }
10351
10352         if (asterisk) {
10353             if (args)
10354                 i = va_arg(*args, int);
10355             else
10356                 i = (ewix ? ewix <= svmax : svix < svmax) ?
10357                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10358             left |= (i < 0);
10359             width = (i < 0) ? -i : i;
10360         }
10361       gotwidth:
10362
10363         /* PRECISION */
10364
10365         if (*q == '.') {
10366             q++;
10367             if (*q == '*') {
10368                 q++;
10369                 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10370                     goto unknown;
10371                 /* XXX: todo, support specified precision parameter */
10372                 if (epix)
10373                     goto unknown;
10374                 if (args)
10375                     i = va_arg(*args, int);
10376                 else
10377                     i = (ewix ? ewix <= svmax : svix < svmax)
10378                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10379                 precis = i;
10380                 has_precis = !(i < 0);
10381             }
10382             else {
10383                 precis = 0;
10384                 while (isDIGIT(*q))
10385                     precis = precis * 10 + (*q++ - '0');
10386                 has_precis = TRUE;
10387             }
10388         }
10389
10390         if (vectorize) {
10391             if (args) {
10392                 VECTORIZE_ARGS
10393             }
10394             else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10395                 vecsv = svargs[efix ? efix-1 : svix++];
10396                 vecstr = (U8*)SvPV_const(vecsv,veclen);
10397                 vec_utf8 = DO_UTF8(vecsv);
10398
10399                 /* if this is a version object, we need to convert
10400                  * back into v-string notation and then let the
10401                  * vectorize happen normally
10402                  */
10403                 if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
10404                     char *version = savesvpv(vecsv);
10405                     if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10406                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
10407                         "vector argument not supported with alpha versions");
10408                         goto unknown;
10409                     }
10410                     vecsv = sv_newmortal();
10411                     scan_vstring(version, version + veclen, vecsv);
10412                     vecstr = (U8*)SvPV_const(vecsv, veclen);
10413                     vec_utf8 = DO_UTF8(vecsv);
10414                     Safefree(version);
10415                 }
10416             }
10417             else {
10418                 vecstr = (U8*)"";
10419                 veclen = 0;
10420             }
10421         }
10422
10423         /* SIZE */
10424
10425         switch (*q) {
10426 #ifdef WIN32
10427         case 'I':                       /* Ix, I32x, and I64x */
10428 #  ifdef WIN64
10429             if (q[1] == '6' && q[2] == '4') {
10430                 q += 3;
10431                 intsize = 'q';
10432                 break;
10433             }
10434 #  endif
10435             if (q[1] == '3' && q[2] == '2') {
10436                 q += 3;
10437                 break;
10438             }
10439 #  ifdef WIN64
10440             intsize = 'q';
10441 #  endif
10442             q++;
10443             break;
10444 #endif
10445 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10446         case 'L':                       /* Ld */
10447             /*FALLTHROUGH*/
10448 #ifdef HAS_QUAD
10449         case 'q':                       /* qd */
10450 #endif
10451             intsize = 'q';
10452             q++;
10453             break;
10454 #endif
10455         case 'l':
10456             ++q;
10457 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10458             if (*q == 'l') {    /* lld, llf */
10459                 intsize = 'q';
10460                 ++q;
10461             }
10462             else
10463 #endif
10464                 intsize = 'l';
10465             break;
10466         case 'h':
10467             if (*++q == 'h') {  /* hhd, hhu */
10468                 intsize = 'c';
10469                 ++q;
10470             }
10471             else
10472                 intsize = 'h';
10473             break;
10474         case 'V':
10475         case 'z':
10476         case 't':
10477 #if HAS_C99
10478         case 'j':
10479 #endif
10480             intsize = *q++;
10481             break;
10482         }
10483
10484         /* CONVERSION */
10485
10486         if (*q == '%') {
10487             eptr = q++;
10488             elen = 1;
10489             if (vectorize) {
10490                 c = '%';
10491                 goto unknown;
10492             }
10493             goto string;
10494         }
10495
10496         if (!vectorize && !args) {
10497             if (efix) {
10498                 const I32 i = efix-1;
10499                 argsv = (i >= 0 && i < svmax)
10500                     ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10501             } else {
10502                 argsv = (svix >= 0 && svix < svmax)
10503                     ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10504             }
10505         }
10506
10507         switch (c = *q++) {
10508
10509             /* STRINGS */
10510
10511         case 'c':
10512             if (vectorize)
10513                 goto unknown;
10514             uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10515             if ((uv > 255 ||
10516                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
10517                 && !IN_BYTES) {
10518                 eptr = (char*)utf8buf;
10519                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10520                 is_utf8 = TRUE;
10521             }
10522             else {
10523                 c = (char)uv;
10524                 eptr = &c;
10525                 elen = 1;
10526             }
10527             goto string;
10528
10529         case 's':
10530             if (vectorize)
10531                 goto unknown;
10532             if (args) {
10533                 eptr = va_arg(*args, char*);
10534                 if (eptr)
10535                     elen = strlen(eptr);
10536                 else {
10537                     eptr = (char *)nullstr;
10538                     elen = sizeof nullstr - 1;
10539                 }
10540             }
10541             else {
10542                 eptr = SvPV_const(argsv, elen);
10543                 if (DO_UTF8(argsv)) {
10544                     STRLEN old_precis = precis;
10545                     if (has_precis && precis < elen) {
10546                         STRLEN ulen = sv_len_utf8(argsv);
10547                         I32 p = precis > ulen ? ulen : precis;
10548                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10549                         precis = p;
10550                     }
10551                     if (width) { /* fudge width (can't fudge elen) */
10552                         if (has_precis && precis < elen)
10553                             width += precis - old_precis;
10554                         else
10555                             width += elen - sv_len_utf8(argsv);
10556                     }
10557                     is_utf8 = TRUE;
10558                 }
10559             }
10560
10561         string:
10562             if (has_precis && precis < elen)
10563                 elen = precis;
10564             break;
10565
10566             /* INTEGERS */
10567
10568         case 'p':
10569             if (alt || vectorize)
10570                 goto unknown;
10571             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10572             base = 16;
10573             goto integer;
10574
10575         case 'D':
10576 #ifdef IV_IS_QUAD
10577             intsize = 'q';
10578 #else
10579             intsize = 'l';
10580 #endif
10581             /*FALLTHROUGH*/
10582         case 'd':
10583         case 'i':
10584 #if vdNUMBER
10585         format_vd:
10586 #endif
10587             if (vectorize) {
10588                 STRLEN ulen;
10589                 if (!veclen)
10590                     continue;
10591                 if (vec_utf8)
10592                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10593                                         UTF8_ALLOW_ANYUV);
10594                 else {
10595                     uv = *vecstr;
10596                     ulen = 1;
10597                 }
10598                 vecstr += ulen;
10599                 veclen -= ulen;
10600                 if (plus)
10601                      esignbuf[esignlen++] = plus;
10602             }
10603             else if (args) {
10604                 switch (intsize) {
10605                 case 'c':       iv = (char)va_arg(*args, int); break;
10606                 case 'h':       iv = (short)va_arg(*args, int); break;
10607                 case 'l':       iv = va_arg(*args, long); break;
10608                 case 'V':       iv = va_arg(*args, IV); break;
10609                 case 'z':       iv = va_arg(*args, SSize_t); break;
10610                 case 't':       iv = va_arg(*args, ptrdiff_t); break;
10611                 default:        iv = va_arg(*args, int); break;
10612 #if HAS_C99
10613                 case 'j':       iv = va_arg(*args, intmax_t); break;
10614 #endif
10615                 case 'q':
10616 #ifdef HAS_QUAD
10617                                 iv = va_arg(*args, Quad_t); break;
10618 #else
10619                                 goto unknown;
10620 #endif
10621                 }
10622             }
10623             else {
10624                 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10625                 switch (intsize) {
10626                 case 'c':       iv = (char)tiv; break;
10627                 case 'h':       iv = (short)tiv; break;
10628                 case 'l':       iv = (long)tiv; break;
10629                 case 'V':
10630                 default:        iv = tiv; break;
10631                 case 'q':
10632 #ifdef HAS_QUAD
10633                                 iv = (Quad_t)tiv; break;
10634 #else
10635                                 goto unknown;
10636 #endif
10637                 }
10638             }
10639             if ( !vectorize )   /* we already set uv above */
10640             {
10641                 if (iv >= 0) {
10642                     uv = iv;
10643                     if (plus)
10644                         esignbuf[esignlen++] = plus;
10645                 }
10646                 else {
10647                     uv = -iv;
10648                     esignbuf[esignlen++] = '-';
10649                 }
10650             }
10651             base = 10;
10652             goto integer;
10653
10654         case 'U':
10655 #ifdef IV_IS_QUAD
10656             intsize = 'q';
10657 #else
10658             intsize = 'l';
10659 #endif
10660             /*FALLTHROUGH*/
10661         case 'u':
10662             base = 10;
10663             goto uns_integer;
10664
10665         case 'B':
10666         case 'b':
10667             base = 2;
10668             goto uns_integer;
10669
10670         case 'O':
10671 #ifdef IV_IS_QUAD
10672             intsize = 'q';
10673 #else
10674             intsize = 'l';
10675 #endif
10676             /*FALLTHROUGH*/
10677         case 'o':
10678             base = 8;
10679             goto uns_integer;
10680
10681         case 'X':
10682         case 'x':
10683             base = 16;
10684
10685         uns_integer:
10686             if (vectorize) {
10687                 STRLEN ulen;
10688         vector:
10689                 if (!veclen)
10690                     continue;
10691                 if (vec_utf8)
10692                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10693                                         UTF8_ALLOW_ANYUV);
10694                 else {
10695                     uv = *vecstr;
10696                     ulen = 1;
10697                 }
10698                 vecstr += ulen;
10699                 veclen -= ulen;
10700             }
10701             else if (args) {
10702                 switch (intsize) {
10703                 case 'c':  uv = (unsigned char)va_arg(*args, unsigned); break;
10704                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
10705                 case 'l':  uv = va_arg(*args, unsigned long); break;
10706                 case 'V':  uv = va_arg(*args, UV); break;
10707                 case 'z':  uv = va_arg(*args, Size_t); break;
10708                 case 't':  uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
10709 #if HAS_C99
10710                 case 'j':  uv = va_arg(*args, uintmax_t); break;
10711 #endif
10712                 default:   uv = va_arg(*args, unsigned); break;
10713                 case 'q':
10714 #ifdef HAS_QUAD
10715                            uv = va_arg(*args, Uquad_t); break;
10716 #else
10717                            goto unknown;
10718 #endif
10719                 }
10720             }
10721             else {
10722                 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10723                 switch (intsize) {
10724                 case 'c':       uv = (unsigned char)tuv; break;
10725                 case 'h':       uv = (unsigned short)tuv; break;
10726                 case 'l':       uv = (unsigned long)tuv; break;
10727                 case 'V':
10728                 default:        uv = tuv; break;
10729                 case 'q':
10730 #ifdef HAS_QUAD
10731                                 uv = (Uquad_t)tuv; break;
10732 #else
10733                                 goto unknown;
10734 #endif
10735                 }
10736             }
10737
10738         integer:
10739             {
10740                 char *ptr = ebuf + sizeof ebuf;
10741                 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10742                 zeros = 0;
10743
10744                 switch (base) {
10745                     unsigned dig;
10746                 case 16:
10747                     p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10748                     do {
10749                         dig = uv & 15;
10750                         *--ptr = p[dig];
10751                     } while (uv >>= 4);
10752                     if (tempalt) {
10753                         esignbuf[esignlen++] = '0';
10754                         esignbuf[esignlen++] = c;  /* 'x' or 'X' */
10755                     }
10756                     break;
10757                 case 8:
10758                     do {
10759                         dig = uv & 7;
10760                         *--ptr = '0' + dig;
10761                     } while (uv >>= 3);
10762                     if (alt && *ptr != '0')
10763                         *--ptr = '0';
10764                     break;
10765                 case 2:
10766                     do {
10767                         dig = uv & 1;
10768                         *--ptr = '0' + dig;
10769                     } while (uv >>= 1);
10770                     if (tempalt) {
10771                         esignbuf[esignlen++] = '0';
10772                         esignbuf[esignlen++] = c;
10773                     }
10774                     break;
10775                 default:                /* it had better be ten or less */
10776                     do {
10777                         dig = uv % base;
10778                         *--ptr = '0' + dig;
10779                     } while (uv /= base);
10780                     break;
10781                 }
10782                 elen = (ebuf + sizeof ebuf) - ptr;
10783                 eptr = ptr;
10784                 if (has_precis) {
10785                     if (precis > elen)
10786                         zeros = precis - elen;
10787                     else if (precis == 0 && elen == 1 && *eptr == '0'
10788                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10789                         elen = 0;
10790
10791                 /* a precision nullifies the 0 flag. */
10792                     if (fill == '0')
10793                         fill = ' ';
10794                 }
10795             }
10796             break;
10797
10798             /* FLOATING POINT */
10799
10800         case 'F':
10801             c = 'f';            /* maybe %F isn't supported here */
10802             /*FALLTHROUGH*/
10803         case 'e': case 'E':
10804         case 'f':
10805         case 'g': case 'G':
10806             if (vectorize)
10807                 goto unknown;
10808
10809             /* This is evil, but floating point is even more evil */
10810
10811             /* for SV-style calling, we can only get NV
10812                for C-style calling, we assume %f is double;
10813                for simplicity we allow any of %Lf, %llf, %qf for long double
10814             */
10815             switch (intsize) {
10816             case 'V':
10817 #if defined(USE_LONG_DOUBLE)
10818                 intsize = 'q';
10819 #endif
10820                 break;
10821 /* [perl #20339] - we should accept and ignore %lf rather than die */
10822             case 'l':
10823                 /*FALLTHROUGH*/
10824             default:
10825 #if defined(USE_LONG_DOUBLE)
10826                 intsize = args ? 0 : 'q';
10827 #endif
10828                 break;
10829             case 'q':
10830 #if defined(HAS_LONG_DOUBLE)
10831                 break;
10832 #else
10833                 /*FALLTHROUGH*/
10834 #endif
10835             case 'c':
10836             case 'h':
10837             case 'z':
10838             case 't':
10839             case 'j':
10840                 goto unknown;
10841             }
10842
10843             /* now we need (long double) if intsize == 'q', else (double) */
10844             nv = (args) ?
10845 #if LONG_DOUBLESIZE > DOUBLESIZE
10846                 intsize == 'q' ?
10847                     va_arg(*args, long double) :
10848                     va_arg(*args, double)
10849 #else
10850                     va_arg(*args, double)
10851 #endif
10852                 : SvNV(argsv);
10853
10854             need = 0;
10855             /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10856                else. frexp() has some unspecified behaviour for those three */
10857             if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10858                 i = PERL_INT_MIN;
10859                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10860                    will cast our (long double) to (double) */
10861                 (void)Perl_frexp(nv, &i);
10862                 if (i == PERL_INT_MIN)
10863                     Perl_die(aTHX_ "panic: frexp");
10864                 if (i > 0)
10865                     need = BIT_DIGITS(i);
10866             }
10867             need += has_precis ? precis : 6; /* known default */
10868
10869             if (need < width)
10870                 need = width;
10871
10872 #ifdef HAS_LDBL_SPRINTF_BUG
10873             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10874                with sfio - Allen <allens@cpan.org> */
10875
10876 #  ifdef DBL_MAX
10877 #    define MY_DBL_MAX DBL_MAX
10878 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10879 #    if DOUBLESIZE >= 8
10880 #      define MY_DBL_MAX 1.7976931348623157E+308L
10881 #    else
10882 #      define MY_DBL_MAX 3.40282347E+38L
10883 #    endif
10884 #  endif
10885
10886 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10887 #    define MY_DBL_MAX_BUG 1L
10888 #  else
10889 #    define MY_DBL_MAX_BUG MY_DBL_MAX
10890 #  endif
10891
10892 #  ifdef DBL_MIN
10893 #    define MY_DBL_MIN DBL_MIN
10894 #  else  /* XXX guessing! -Allen */
10895 #    if DOUBLESIZE >= 8
10896 #      define MY_DBL_MIN 2.2250738585072014E-308L
10897 #    else
10898 #      define MY_DBL_MIN 1.17549435E-38L
10899 #    endif
10900 #  endif
10901
10902             if ((intsize == 'q') && (c == 'f') &&
10903                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10904                 (need < DBL_DIG)) {
10905                 /* it's going to be short enough that
10906                  * long double precision is not needed */
10907
10908                 if ((nv <= 0L) && (nv >= -0L))
10909                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10910                 else {
10911                     /* would use Perl_fp_class as a double-check but not
10912                      * functional on IRIX - see perl.h comments */
10913
10914                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10915                         /* It's within the range that a double can represent */
10916 #if defined(DBL_MAX) && !defined(DBL_MIN)
10917                         if ((nv >= ((long double)1/DBL_MAX)) ||
10918                             (nv <= (-(long double)1/DBL_MAX)))
10919 #endif
10920                         fix_ldbl_sprintf_bug = TRUE;
10921                     }
10922                 }
10923                 if (fix_ldbl_sprintf_bug == TRUE) {
10924                     double temp;
10925
10926                     intsize = 0;
10927                     temp = (double)nv;
10928                     nv = (NV)temp;
10929                 }
10930             }
10931
10932 #  undef MY_DBL_MAX
10933 #  undef MY_DBL_MAX_BUG
10934 #  undef MY_DBL_MIN
10935
10936 #endif /* HAS_LDBL_SPRINTF_BUG */
10937
10938             need += 20; /* fudge factor */
10939             if (PL_efloatsize < need) {
10940                 Safefree(PL_efloatbuf);
10941                 PL_efloatsize = need + 20; /* more fudge */
10942                 Newx(PL_efloatbuf, PL_efloatsize, char);
10943                 PL_efloatbuf[0] = '\0';
10944             }
10945
10946             if ( !(width || left || plus || alt) && fill != '0'
10947                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
10948                 /* See earlier comment about buggy Gconvert when digits,
10949                    aka precis is 0  */
10950                 if ( c == 'g' && precis) {
10951                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10952                     /* May return an empty string for digits==0 */
10953                     if (*PL_efloatbuf) {
10954                         elen = strlen(PL_efloatbuf);
10955                         goto float_converted;
10956                     }
10957                 } else if ( c == 'f' && !precis) {
10958                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10959                         break;
10960                 }
10961             }
10962             {
10963                 char *ptr = ebuf + sizeof ebuf;
10964                 *--ptr = '\0';
10965                 *--ptr = c;
10966                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10967 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10968                 if (intsize == 'q') {
10969                     /* Copy the one or more characters in a long double
10970                      * format before the 'base' ([efgEFG]) character to
10971                      * the format string. */
10972                     static char const prifldbl[] = PERL_PRIfldbl;
10973                     char const *p = prifldbl + sizeof(prifldbl) - 3;
10974                     while (p >= prifldbl) { *--ptr = *p--; }
10975                 }
10976 #endif
10977                 if (has_precis) {
10978                     base = precis;
10979                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10980                     *--ptr = '.';
10981                 }
10982                 if (width) {
10983                     base = width;
10984                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10985                 }
10986                 if (fill == '0')
10987                     *--ptr = fill;
10988                 if (left)
10989                     *--ptr = '-';
10990                 if (plus)
10991                     *--ptr = plus;
10992                 if (alt)
10993                     *--ptr = '#';
10994                 *--ptr = '%';
10995
10996                 /* No taint.  Otherwise we are in the strange situation
10997                  * where printf() taints but print($float) doesn't.
10998                  * --jhi */
10999 #if defined(HAS_LONG_DOUBLE)
11000                 elen = ((intsize == 'q')
11001                         ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
11002                         : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
11003 #else
11004                 elen = my_sprintf(PL_efloatbuf, ptr, nv);
11005 #endif
11006             }
11007         float_converted:
11008             eptr = PL_efloatbuf;
11009             break;
11010
11011             /* SPECIAL */
11012
11013         case 'n':
11014             if (vectorize)
11015                 goto unknown;
11016             i = SvCUR(sv) - origlen;
11017             if (args) {
11018                 switch (intsize) {
11019                 case 'c':       *(va_arg(*args, char*)) = i; break;
11020                 case 'h':       *(va_arg(*args, short*)) = i; break;
11021                 default:        *(va_arg(*args, int*)) = i; break;
11022                 case 'l':       *(va_arg(*args, long*)) = i; break;
11023                 case 'V':       *(va_arg(*args, IV*)) = i; break;
11024                 case 'z':       *(va_arg(*args, SSize_t*)) = i; break;
11025                 case 't':       *(va_arg(*args, ptrdiff_t*)) = i; break;
11026 #if HAS_C99
11027                 case 'j':       *(va_arg(*args, intmax_t*)) = i; break;
11028 #endif
11029                 case 'q':
11030 #ifdef HAS_QUAD
11031                                 *(va_arg(*args, Quad_t*)) = i; break;
11032 #else
11033                                 goto unknown;
11034 #endif
11035                 }
11036             }
11037             else
11038                 sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
11039             continue;   /* not "break" */
11040
11041             /* UNKNOWN */
11042
11043         default:
11044       unknown:
11045             if (!args
11046                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
11047                 && ckWARN(WARN_PRINTF))
11048             {
11049                 SV * const msg = sv_newmortal();
11050                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
11051                           (PL_op->op_type == OP_PRTF) ? "" : "s");
11052                 if (fmtstart < patend) {
11053                     const char * const fmtend = q < patend ? q : patend;
11054                     const char * f;
11055                     sv_catpvs(msg, "\"%");
11056                     for (f = fmtstart; f < fmtend; f++) {
11057                         if (isPRINT(*f)) {
11058                             sv_catpvn(msg, f, 1);
11059                         } else {
11060                             Perl_sv_catpvf(aTHX_ msg,
11061                                            "\\%03"UVof, (UV)*f & 0xFF);
11062                         }
11063                     }
11064                     sv_catpvs(msg, "\"");
11065                 } else {
11066                     sv_catpvs(msg, "end of string");
11067                 }
11068                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
11069             }
11070
11071             /* output mangled stuff ... */
11072             if (c == '\0')
11073                 --q;
11074             eptr = p;
11075             elen = q - p;
11076
11077             /* ... right here, because formatting flags should not apply */
11078             SvGROW(sv, SvCUR(sv) + elen + 1);
11079             p = SvEND(sv);
11080             Copy(eptr, p, elen, char);
11081             p += elen;
11082             *p = '\0';
11083             SvCUR_set(sv, p - SvPVX_const(sv));
11084             svix = osvix;
11085             continue;   /* not "break" */
11086         }
11087
11088         if (is_utf8 != has_utf8) {
11089             if (is_utf8) {
11090                 if (SvCUR(sv))
11091                     sv_utf8_upgrade(sv);
11092             }
11093             else {
11094                 const STRLEN old_elen = elen;
11095                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
11096                 sv_utf8_upgrade(nsv);
11097                 eptr = SvPVX_const(nsv);
11098                 elen = SvCUR(nsv);
11099
11100                 if (width) { /* fudge width (can't fudge elen) */
11101                     width += elen - old_elen;
11102                 }
11103                 is_utf8 = TRUE;
11104             }
11105         }
11106
11107         have = esignlen + zeros + elen;
11108         if (have < zeros)
11109             Perl_croak_nocontext("%s", PL_memory_wrap);
11110
11111         need = (have > width ? have : width);
11112         gap = need - have;
11113
11114         if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
11115             Perl_croak_nocontext("%s", PL_memory_wrap);
11116         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
11117         p = SvEND(sv);
11118         if (esignlen && fill == '0') {
11119             int i;
11120             for (i = 0; i < (int)esignlen; i++)
11121                 *p++ = esignbuf[i];
11122         }
11123         if (gap && !left) {
11124             memset(p, fill, gap);
11125             p += gap;
11126         }
11127         if (esignlen && fill != '0') {
11128             int i;
11129             for (i = 0; i < (int)esignlen; i++)
11130                 *p++ = esignbuf[i];
11131         }
11132         if (zeros) {
11133             int i;
11134             for (i = zeros; i; i--)
11135                 *p++ = '0';
11136         }
11137         if (elen) {
11138             Copy(eptr, p, elen, char);
11139             p += elen;
11140         }
11141         if (gap && left) {
11142             memset(p, ' ', gap);
11143             p += gap;
11144         }
11145         if (vectorize) {
11146             if (veclen) {
11147                 Copy(dotstr, p, dotstrlen, char);
11148                 p += dotstrlen;
11149             }
11150             else
11151                 vectorize = FALSE;              /* done iterating over vecstr */
11152         }
11153         if (is_utf8)
11154             has_utf8 = TRUE;
11155         if (has_utf8)
11156             SvUTF8_on(sv);
11157         *p = '\0';
11158         SvCUR_set(sv, p - SvPVX_const(sv));
11159         if (vectorize) {
11160             esignlen = 0;
11161             goto vector;
11162         }
11163     }
11164     SvTAINT(sv);
11165 }
11166
11167 /* =========================================================================
11168
11169 =head1 Cloning an interpreter
11170
11171 All the macros and functions in this section are for the private use of
11172 the main function, perl_clone().
11173
11174 The foo_dup() functions make an exact copy of an existing foo thingy.
11175 During the course of a cloning, a hash table is used to map old addresses
11176 to new addresses.  The table is created and manipulated with the
11177 ptr_table_* functions.
11178
11179 =cut
11180
11181  * =========================================================================*/
11182
11183
11184 #if defined(USE_ITHREADS)
11185
11186 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
11187 #ifndef GpREFCNT_inc
11188 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
11189 #endif
11190
11191
11192 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
11193    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
11194    If this changes, please unmerge ss_dup.
11195    Likewise, sv_dup_inc_multiple() relies on this fact.  */
11196 #define sv_dup_inc_NN(s,t)      SvREFCNT_inc_NN(sv_dup_inc(s,t))
11197 #define av_dup(s,t)     MUTABLE_AV(sv_dup((const SV *)s,t))
11198 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11199 #define hv_dup(s,t)     MUTABLE_HV(sv_dup((const SV *)s,t))
11200 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11201 #define cv_dup(s,t)     MUTABLE_CV(sv_dup((const SV *)s,t))
11202 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
11203 #define io_dup(s,t)     MUTABLE_IO(sv_dup((const SV *)s,t))
11204 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
11205 #define gv_dup(s,t)     MUTABLE_GV(sv_dup((const SV *)s,t))
11206 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
11207 #define SAVEPV(p)       ((p) ? savepv(p) : NULL)
11208 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
11209
11210 /* clone a parser */
11211
11212 yy_parser *
11213 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
11214 {
11215     yy_parser *parser;
11216
11217     PERL_ARGS_ASSERT_PARSER_DUP;
11218
11219     if (!proto)
11220         return NULL;
11221
11222     /* look for it in the table first */
11223     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11224     if (parser)
11225         return parser;
11226
11227     /* create anew and remember what it is */
11228     Newxz(parser, 1, yy_parser);
11229     ptr_table_store(PL_ptr_table, proto, parser);
11230
11231     /* XXX these not yet duped */
11232     parser->old_parser = NULL;
11233     parser->stack = NULL;
11234     parser->ps = NULL;
11235     parser->stack_size = 0;
11236     /* XXX parser->stack->state = 0; */
11237
11238     /* XXX eventually, just Copy() most of the parser struct ? */
11239
11240     parser->lex_brackets = proto->lex_brackets;
11241     parser->lex_casemods = proto->lex_casemods;
11242     parser->lex_brackstack = savepvn(proto->lex_brackstack,
11243                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11244     parser->lex_casestack = savepvn(proto->lex_casestack,
11245                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11246     parser->lex_defer   = proto->lex_defer;
11247     parser->lex_dojoin  = proto->lex_dojoin;
11248     parser->lex_expect  = proto->lex_expect;
11249     parser->lex_formbrack = proto->lex_formbrack;
11250     parser->lex_inpat   = proto->lex_inpat;
11251     parser->lex_inwhat  = proto->lex_inwhat;
11252     parser->lex_op      = proto->lex_op;
11253     parser->lex_repl    = sv_dup_inc(proto->lex_repl, param);
11254     parser->lex_starts  = proto->lex_starts;
11255     parser->lex_stuff   = sv_dup_inc(proto->lex_stuff, param);
11256     parser->multi_close = proto->multi_close;
11257     parser->multi_open  = proto->multi_open;
11258     parser->multi_start = proto->multi_start;
11259     parser->multi_end   = proto->multi_end;
11260     parser->pending_ident = proto->pending_ident;
11261     parser->preambled   = proto->preambled;
11262     parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11263     parser->linestr     = sv_dup_inc(proto->linestr, param);
11264     parser->expect      = proto->expect;
11265     parser->copline     = proto->copline;
11266     parser->last_lop_op = proto->last_lop_op;
11267     parser->lex_state   = proto->lex_state;
11268     parser->rsfp        = fp_dup(proto->rsfp, '<', param);
11269     /* rsfp_filters entries have fake IoDIRP() */
11270     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11271     parser->in_my       = proto->in_my;
11272     parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11273     parser->error_count = proto->error_count;
11274
11275
11276     parser->linestr     = sv_dup_inc(proto->linestr, param);
11277
11278     {
11279         char * const ols = SvPVX(proto->linestr);
11280         char * const ls  = SvPVX(parser->linestr);
11281
11282         parser->bufptr      = ls + (proto->bufptr >= ols ?
11283                                     proto->bufptr -  ols : 0);
11284         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
11285                                     proto->oldbufptr -  ols : 0);
11286         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11287                                     proto->oldoldbufptr -  ols : 0);
11288         parser->linestart   = ls + (proto->linestart >= ols ?
11289                                     proto->linestart -  ols : 0);
11290         parser->last_uni    = ls + (proto->last_uni >= ols ?
11291                                     proto->last_uni -  ols : 0);
11292         parser->last_lop    = ls + (proto->last_lop >= ols ?
11293                                     proto->last_lop -  ols : 0);
11294
11295         parser->bufend      = ls + SvCUR(parser->linestr);
11296     }
11297
11298     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11299
11300
11301 #ifdef PERL_MAD
11302     parser->endwhite    = proto->endwhite;
11303     parser->faketokens  = proto->faketokens;
11304     parser->lasttoke    = proto->lasttoke;
11305     parser->nextwhite   = proto->nextwhite;
11306     parser->realtokenstart = proto->realtokenstart;
11307     parser->skipwhite   = proto->skipwhite;
11308     parser->thisclose   = proto->thisclose;
11309     parser->thismad     = proto->thismad;
11310     parser->thisopen    = proto->thisopen;
11311     parser->thisstuff   = proto->thisstuff;
11312     parser->thistoken   = proto->thistoken;
11313     parser->thiswhite   = proto->thiswhite;
11314
11315     Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11316     parser->curforce    = proto->curforce;
11317 #else
11318     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11319     Copy(proto->nexttype, parser->nexttype, 5,  I32);
11320     parser->nexttoke    = proto->nexttoke;
11321 #endif
11322
11323     /* XXX should clone saved_curcop here, but we aren't passed
11324      * proto_perl; so do it in perl_clone_using instead */
11325
11326     return parser;
11327 }
11328
11329
11330 /* duplicate a file handle */
11331
11332 PerlIO *
11333 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11334 {
11335     PerlIO *ret;
11336
11337     PERL_ARGS_ASSERT_FP_DUP;
11338     PERL_UNUSED_ARG(type);
11339
11340     if (!fp)
11341         return (PerlIO*)NULL;
11342
11343     /* look for it in the table first */
11344     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11345     if (ret)
11346         return ret;
11347
11348     /* create anew and remember what it is */
11349     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11350     ptr_table_store(PL_ptr_table, fp, ret);
11351     return ret;
11352 }
11353
11354 /* duplicate a directory handle */
11355
11356 DIR *
11357 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11358 {
11359     DIR *ret;
11360
11361 #ifdef HAS_FCHDIR
11362     DIR *pwd;
11363     register const Direntry_t *dirent;
11364     char smallbuf[256];
11365     char *name = NULL;
11366     STRLEN len = 0;
11367     long pos;
11368 #endif
11369
11370     PERL_UNUSED_CONTEXT;
11371     PERL_ARGS_ASSERT_DIRP_DUP;
11372
11373     if (!dp)
11374         return (DIR*)NULL;
11375
11376     /* look for it in the table first */
11377     ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11378     if (ret)
11379         return ret;
11380
11381 #ifdef HAS_FCHDIR
11382
11383     PERL_UNUSED_ARG(param);
11384
11385     /* create anew */
11386
11387     /* open the current directory (so we can switch back) */
11388     if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11389
11390     /* chdir to our dir handle and open the present working directory */
11391     if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11392         PerlDir_close(pwd);
11393         return (DIR *)NULL;
11394     }
11395     /* Now we should have two dir handles pointing to the same dir. */
11396
11397     /* Be nice to the calling code and chdir back to where we were. */
11398     fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11399
11400     /* We have no need of the pwd handle any more. */
11401     PerlDir_close(pwd);
11402
11403 #ifdef DIRNAMLEN
11404 # define d_namlen(d) (d)->d_namlen
11405 #else
11406 # define d_namlen(d) strlen((d)->d_name)
11407 #endif
11408     /* Iterate once through dp, to get the file name at the current posi-
11409        tion. Then step back. */
11410     pos = PerlDir_tell(dp);
11411     if ((dirent = PerlDir_read(dp))) {
11412         len = d_namlen(dirent);
11413         if (len <= sizeof smallbuf) name = smallbuf;
11414         else Newx(name, len, char);
11415         Move(dirent->d_name, name, len, char);
11416     }
11417     PerlDir_seek(dp, pos);
11418
11419     /* Iterate through the new dir handle, till we find a file with the
11420        right name. */
11421     if (!dirent) /* just before the end */
11422         for(;;) {
11423             pos = PerlDir_tell(ret);
11424             if (PerlDir_read(ret)) continue; /* not there yet */
11425             PerlDir_seek(ret, pos); /* step back */
11426             break;
11427         }
11428     else {
11429         const long pos0 = PerlDir_tell(ret);
11430         for(;;) {
11431             pos = PerlDir_tell(ret);
11432             if ((dirent = PerlDir_read(ret))) {
11433                 if (len == d_namlen(dirent)
11434                  && memEQ(name, dirent->d_name, len)) {
11435                     /* found it */
11436                     PerlDir_seek(ret, pos); /* step back */
11437                     break;
11438                 }
11439                 /* else we are not there yet; keep iterating */
11440             }
11441             else { /* This is not meant to happen. The best we can do is
11442                       reset the iterator to the beginning. */
11443                 PerlDir_seek(ret, pos0);
11444                 break;
11445             }
11446         }
11447     }
11448 #undef d_namlen
11449
11450     if (name && name != smallbuf)
11451         Safefree(name);
11452 #endif
11453
11454 #ifdef WIN32
11455     ret = win32_dirp_dup(dp, param);
11456 #endif
11457
11458     /* pop it in the pointer table */
11459     if (ret)
11460         ptr_table_store(PL_ptr_table, dp, ret);
11461
11462     return ret;
11463 }
11464
11465 /* duplicate a typeglob */
11466
11467 GP *
11468 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11469 {
11470     GP *ret;
11471
11472     PERL_ARGS_ASSERT_GP_DUP;
11473
11474     if (!gp)
11475         return (GP*)NULL;
11476     /* look for it in the table first */
11477     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11478     if (ret)
11479         return ret;
11480
11481     /* create anew and remember what it is */
11482     Newxz(ret, 1, GP);
11483     ptr_table_store(PL_ptr_table, gp, ret);
11484
11485     /* clone */
11486     /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11487        on Newxz() to do this for us.  */
11488     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
11489     ret->gp_io          = io_dup_inc(gp->gp_io, param);
11490     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
11491     ret->gp_av          = av_dup_inc(gp->gp_av, param);
11492     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
11493     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11494     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
11495     ret->gp_cvgen       = gp->gp_cvgen;
11496     ret->gp_line        = gp->gp_line;
11497     ret->gp_file_hek    = hek_dup(gp->gp_file_hek, param);
11498     return ret;
11499 }
11500
11501 /* duplicate a chain of magic */
11502
11503 MAGIC *
11504 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11505 {
11506     MAGIC *mgret = NULL;
11507     MAGIC **mgprev_p = &mgret;
11508
11509     PERL_ARGS_ASSERT_MG_DUP;
11510
11511     for (; mg; mg = mg->mg_moremagic) {
11512         MAGIC *nmg;
11513
11514         if ((param->flags & CLONEf_JOIN_IN)
11515                 && mg->mg_type == PERL_MAGIC_backref)
11516             /* when joining, we let the individual SVs add themselves to
11517              * backref as needed. */
11518             continue;
11519
11520         Newx(nmg, 1, MAGIC);
11521         *mgprev_p = nmg;
11522         mgprev_p = &(nmg->mg_moremagic);
11523
11524         /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11525            dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11526            from the original commit adding Perl_mg_dup() - revision 4538.
11527            Similarly there is the annotation "XXX random ptr?" next to the
11528            assignment to nmg->mg_ptr.  */
11529         *nmg = *mg;
11530
11531         /* FIXME for plugins
11532         if (nmg->mg_type == PERL_MAGIC_qr) {
11533             nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11534         }
11535         else
11536         */
11537         nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11538                           ? nmg->mg_type == PERL_MAGIC_backref
11539                                 /* The backref AV has its reference
11540                                  * count deliberately bumped by 1 */
11541                                 ? SvREFCNT_inc(av_dup_inc((const AV *)
11542                                                     nmg->mg_obj, param))
11543                                 : sv_dup_inc(nmg->mg_obj, param)
11544                           : sv_dup(nmg->mg_obj, param);
11545
11546         if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11547             if (nmg->mg_len > 0) {
11548                 nmg->mg_ptr     = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11549                 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11550                         AMT_AMAGIC((AMT*)nmg->mg_ptr))
11551                 {
11552                     AMT * const namtp = (AMT*)nmg->mg_ptr;
11553                     sv_dup_inc_multiple((SV**)(namtp->table),
11554                                         (SV**)(namtp->table), NofAMmeth, param);
11555                 }
11556             }
11557             else if (nmg->mg_len == HEf_SVKEY)
11558                 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11559         }
11560         if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11561             nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11562         }
11563     }
11564     return mgret;
11565 }
11566
11567 #endif /* USE_ITHREADS */
11568
11569 struct ptr_tbl_arena {
11570     struct ptr_tbl_arena *next;
11571     struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers.  */
11572 };
11573
11574 /* create a new pointer-mapping table */
11575
11576 PTR_TBL_t *
11577 Perl_ptr_table_new(pTHX)
11578 {
11579     PTR_TBL_t *tbl;
11580     PERL_UNUSED_CONTEXT;
11581
11582     Newx(tbl, 1, PTR_TBL_t);
11583     tbl->tbl_max        = 511;
11584     tbl->tbl_items      = 0;
11585     tbl->tbl_arena      = NULL;
11586     tbl->tbl_arena_next = NULL;
11587     tbl->tbl_arena_end  = NULL;
11588     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11589     return tbl;
11590 }
11591
11592 #define PTR_TABLE_HASH(ptr) \
11593   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11594
11595 /* map an existing pointer using a table */
11596
11597 STATIC PTR_TBL_ENT_t *
11598 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11599 {
11600     PTR_TBL_ENT_t *tblent;
11601     const UV hash = PTR_TABLE_HASH(sv);
11602
11603     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11604
11605     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11606     for (; tblent; tblent = tblent->next) {
11607         if (tblent->oldval == sv)
11608             return tblent;
11609     }
11610     return NULL;
11611 }
11612
11613 void *
11614 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11615 {
11616     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11617
11618     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11619     PERL_UNUSED_CONTEXT;
11620
11621     return tblent ? tblent->newval : NULL;
11622 }
11623
11624 /* add a new entry to a pointer-mapping table */
11625
11626 void
11627 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
11628 {
11629     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
11630
11631     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
11632     PERL_UNUSED_CONTEXT;
11633
11634     if (tblent) {
11635         tblent->newval = newsv;
11636     } else {
11637         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
11638
11639         if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
11640             struct ptr_tbl_arena *new_arena;
11641
11642             Newx(new_arena, 1, struct ptr_tbl_arena);
11643             new_arena->next = tbl->tbl_arena;
11644             tbl->tbl_arena = new_arena;
11645             tbl->tbl_arena_next = new_arena->array;
11646             tbl->tbl_arena_end = new_arena->array
11647                 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
11648         }
11649
11650         tblent = tbl->tbl_arena_next++;
11651
11652         tblent->oldval = oldsv;
11653         tblent->newval = newsv;
11654         tblent->next = tbl->tbl_ary[entry];
11655         tbl->tbl_ary[entry] = tblent;
11656         tbl->tbl_items++;
11657         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
11658             ptr_table_split(tbl);
11659     }
11660 }
11661
11662 /* double the hash bucket size of an existing ptr table */
11663
11664 void
11665 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
11666 {
11667     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
11668     const UV oldsize = tbl->tbl_max + 1;
11669     UV newsize = oldsize * 2;
11670     UV i;
11671
11672     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11673     PERL_UNUSED_CONTEXT;
11674
11675     Renew(ary, newsize, PTR_TBL_ENT_t*);
11676     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11677     tbl->tbl_max = --newsize;
11678     tbl->tbl_ary = ary;
11679     for (i=0; i < oldsize; i++, ary++) {
11680         PTR_TBL_ENT_t **entp = ary;
11681         PTR_TBL_ENT_t *ent = *ary;
11682         PTR_TBL_ENT_t **curentp;
11683         if (!ent)
11684             continue;
11685         curentp = ary + oldsize;
11686         do {
11687             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11688                 *entp = ent->next;
11689                 ent->next = *curentp;
11690                 *curentp = ent;
11691             }
11692             else
11693                 entp = &ent->next;
11694             ent = *entp;
11695         } while (ent);
11696     }
11697 }
11698
11699 /* remove all the entries from a ptr table */
11700 /* Deprecated - will be removed post 5.14 */
11701
11702 void
11703 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11704 {
11705     if (tbl && tbl->tbl_items) {
11706         struct ptr_tbl_arena *arena = tbl->tbl_arena;
11707
11708         Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11709
11710         while (arena) {
11711             struct ptr_tbl_arena *next = arena->next;
11712
11713             Safefree(arena);
11714             arena = next;
11715         };
11716
11717         tbl->tbl_items = 0;
11718         tbl->tbl_arena = NULL;
11719         tbl->tbl_arena_next = NULL;
11720         tbl->tbl_arena_end = NULL;
11721     }
11722 }
11723
11724 /* clear and free a ptr table */
11725
11726 void
11727 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11728 {
11729     struct ptr_tbl_arena *arena;
11730
11731     if (!tbl) {
11732         return;
11733     }
11734
11735     arena = tbl->tbl_arena;
11736
11737     while (arena) {
11738         struct ptr_tbl_arena *next = arena->next;
11739
11740         Safefree(arena);
11741         arena = next;
11742     }
11743
11744     Safefree(tbl->tbl_ary);
11745     Safefree(tbl);
11746 }
11747
11748 #if defined(USE_ITHREADS)
11749
11750 void
11751 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11752 {
11753     PERL_ARGS_ASSERT_RVPV_DUP;
11754
11755     if (SvROK(sstr)) {
11756         if (SvWEAKREF(sstr)) {
11757             SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11758             if (param->flags & CLONEf_JOIN_IN) {
11759                 /* if joining, we add any back references individually rather
11760                  * than copying the whole backref array */
11761                 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11762             }
11763         }
11764         else
11765             SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11766     }
11767     else if (SvPVX_const(sstr)) {
11768         /* Has something there */
11769         if (SvLEN(sstr)) {
11770             /* Normal PV - clone whole allocated space */
11771             SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11772             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11773                 /* Not that normal - actually sstr is copy on write.
11774                    But we are a true, independent SV, so:  */
11775                 SvREADONLY_off(dstr);
11776                 SvFAKE_off(dstr);
11777             }
11778         }
11779         else {
11780             /* Special case - not normally malloced for some reason */
11781             if (isGV_with_GP(sstr)) {
11782                 /* Don't need to do anything here.  */
11783             }
11784             else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11785                 /* A "shared" PV - clone it as "shared" PV */
11786                 SvPV_set(dstr,
11787                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11788                                          param)));
11789             }
11790             else {
11791                 /* Some other special case - random pointer */
11792                 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11793             }
11794         }
11795     }
11796     else {
11797         /* Copy the NULL */
11798         SvPV_set(dstr, NULL);
11799     }
11800 }
11801
11802 /* duplicate a list of SVs. source and dest may point to the same memory.  */
11803 static SV **
11804 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11805                       SSize_t items, CLONE_PARAMS *const param)
11806 {
11807     PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11808
11809     while (items-- > 0) {
11810         *dest++ = sv_dup_inc(*source++, param);
11811     }
11812
11813     return dest;
11814 }
11815
11816 /* duplicate an SV of any type (including AV, HV etc) */
11817
11818 static SV *
11819 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11820 {
11821     dVAR;
11822     SV *dstr;
11823
11824     PERL_ARGS_ASSERT_SV_DUP_COMMON;
11825
11826     if (SvTYPE(sstr) == (svtype)SVTYPEMASK) {
11827 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11828         abort();
11829 #endif
11830         return NULL;
11831     }
11832     /* look for it in the table first */
11833     dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11834     if (dstr)
11835         return dstr;
11836
11837     if(param->flags & CLONEf_JOIN_IN) {
11838         /** We are joining here so we don't want do clone
11839             something that is bad **/
11840         if (SvTYPE(sstr) == SVt_PVHV) {
11841             const HEK * const hvname = HvNAME_HEK(sstr);
11842             if (hvname) {
11843                 /** don't clone stashes if they already exist **/
11844                 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
11845                                                 HEK_UTF8(hvname) ? SVf_UTF8 : 0));
11846                 ptr_table_store(PL_ptr_table, sstr, dstr);
11847                 return dstr;
11848             }
11849         }
11850         else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
11851             HV *stash = GvSTASH(sstr);
11852             const HEK * hvname;
11853             if (stash && (hvname = HvNAME_HEK(stash))) {
11854                 /** don't clone GVs if they already exist **/
11855                 SV **svp;
11856                 stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
11857                                     HEK_UTF8(hvname) ? SVf_UTF8 : 0);
11858                 svp = hv_fetch(
11859                         stash, GvNAME(sstr),
11860                         GvNAMEUTF8(sstr)
11861                             ? -GvNAMELEN(sstr)
11862                             :  GvNAMELEN(sstr),
11863                         0
11864                       );
11865                 if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
11866                     ptr_table_store(PL_ptr_table, sstr, *svp);
11867                     return *svp;
11868                 }
11869             }
11870         }
11871     }
11872
11873     /* create anew and remember what it is */
11874     new_SV(dstr);
11875
11876 #ifdef DEBUG_LEAKING_SCALARS
11877     dstr->sv_debug_optype = sstr->sv_debug_optype;
11878     dstr->sv_debug_line = sstr->sv_debug_line;
11879     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11880     dstr->sv_debug_parent = (SV*)sstr;
11881     FREE_SV_DEBUG_FILE(dstr);
11882     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11883 #endif
11884
11885     ptr_table_store(PL_ptr_table, sstr, dstr);
11886
11887     /* clone */
11888     SvFLAGS(dstr)       = SvFLAGS(sstr);
11889     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
11890     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
11891
11892 #ifdef DEBUGGING
11893     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11894         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11895                       (void*)PL_watch_pvx, SvPVX_const(sstr));
11896 #endif
11897
11898     /* don't clone objects whose class has asked us not to */
11899     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11900         SvFLAGS(dstr) = 0;
11901         return dstr;
11902     }
11903
11904     switch (SvTYPE(sstr)) {
11905     case SVt_NULL:
11906         SvANY(dstr)     = NULL;
11907         break;
11908     case SVt_IV:
11909         SvANY(dstr)     = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11910         if(SvROK(sstr)) {
11911             Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11912         } else {
11913             SvIV_set(dstr, SvIVX(sstr));
11914         }
11915         break;
11916     case SVt_NV:
11917         SvANY(dstr)     = new_XNV();
11918         SvNV_set(dstr, SvNVX(sstr));
11919         break;
11920         /* case SVt_BIND: */
11921     default:
11922         {
11923             /* These are all the types that need complex bodies allocating.  */
11924             void *new_body;
11925             const svtype sv_type = SvTYPE(sstr);
11926             const struct body_details *const sv_type_details
11927                 = bodies_by_type + sv_type;
11928
11929             switch (sv_type) {
11930             default:
11931                 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11932                 break;
11933
11934             case SVt_PVGV:
11935             case SVt_PVIO:
11936             case SVt_PVFM:
11937             case SVt_PVHV:
11938             case SVt_PVAV:
11939             case SVt_PVCV:
11940             case SVt_PVLV:
11941             case SVt_REGEXP:
11942             case SVt_PVMG:
11943             case SVt_PVNV:
11944             case SVt_PVIV:
11945             case SVt_PV:
11946                 assert(sv_type_details->body_size);
11947                 if (sv_type_details->arena) {
11948                     new_body_inline(new_body, sv_type);
11949                     new_body
11950                         = (void*)((char*)new_body - sv_type_details->offset);
11951                 } else {
11952                     new_body = new_NOARENA(sv_type_details);
11953                 }
11954             }
11955             assert(new_body);
11956             SvANY(dstr) = new_body;
11957
11958 #ifndef PURIFY
11959             Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11960                  ((char*)SvANY(dstr)) + sv_type_details->offset,
11961                  sv_type_details->copy, char);
11962 #else
11963             Copy(((char*)SvANY(sstr)),
11964                  ((char*)SvANY(dstr)),
11965                  sv_type_details->body_size + sv_type_details->offset, char);
11966 #endif
11967
11968             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11969                 && !isGV_with_GP(dstr)
11970                 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11971                 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11972
11973             /* The Copy above means that all the source (unduplicated) pointers
11974                are now in the destination.  We can check the flags and the
11975                pointers in either, but it's possible that there's less cache
11976                missing by always going for the destination.
11977                FIXME - instrument and check that assumption  */
11978             if (sv_type >= SVt_PVMG) {
11979                 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11980                     SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11981                 } else if (SvMAGIC(dstr))
11982                     SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11983                 if (SvSTASH(dstr))
11984                     SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11985             }
11986
11987             /* The cast silences a GCC warning about unhandled types.  */
11988             switch ((int)sv_type) {
11989             case SVt_PV:
11990                 break;
11991             case SVt_PVIV:
11992                 break;
11993             case SVt_PVNV:
11994                 break;
11995             case SVt_PVMG:
11996                 break;
11997             case SVt_REGEXP:
11998                 /* FIXME for plugins */
11999                 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
12000                 break;
12001             case SVt_PVLV:
12002                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
12003                 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
12004                     LvTARG(dstr) = dstr;
12005                 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
12006                     LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
12007                 else
12008                     LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
12009             case SVt_PVGV:
12010                 /* non-GP case already handled above */
12011                 if(isGV_with_GP(sstr)) {
12012                     GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
12013                     /* Don't call sv_add_backref here as it's going to be
12014                        created as part of the magic cloning of the symbol
12015                        table--unless this is during a join and the stash
12016                        is not actually being cloned.  */
12017                     /* Danger Will Robinson - GvGP(dstr) isn't initialised
12018                        at the point of this comment.  */
12019                     GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
12020                     if (param->flags & CLONEf_JOIN_IN)
12021                         Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
12022                     GvGP_set(dstr, gp_dup(GvGP(sstr), param));
12023                     (void)GpREFCNT_inc(GvGP(dstr));
12024                 }
12025                 break;
12026             case SVt_PVIO:
12027                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
12028                 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
12029                     /* I have no idea why fake dirp (rsfps)
12030                        should be treated differently but otherwise
12031                        we end up with leaks -- sky*/
12032                     IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
12033                     IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
12034                     IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
12035                 } else {
12036                     IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
12037                     IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
12038                     IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
12039                     if (IoDIRP(dstr)) {
12040                         IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr), param);
12041                     } else {
12042                         NOOP;
12043                         /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
12044                     }
12045                     IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
12046                 }
12047                 if (IoOFP(dstr) == IoIFP(sstr))
12048                     IoOFP(dstr) = IoIFP(dstr);
12049                 else
12050                     IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
12051                 IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
12052                 IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
12053                 IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
12054                 break;
12055             case SVt_PVAV:
12056                 /* avoid cloning an empty array */
12057                 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
12058                     SV **dst_ary, **src_ary;
12059                     SSize_t items = AvFILLp((const AV *)sstr) + 1;
12060
12061                     src_ary = AvARRAY((const AV *)sstr);
12062                     Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
12063                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
12064                     AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
12065                     AvALLOC((const AV *)dstr) = dst_ary;
12066                     if (AvREAL((const AV *)sstr)) {
12067                         dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
12068                                                       param);
12069                     }
12070                     else {
12071                         while (items-- > 0)
12072                             *dst_ary++ = sv_dup(*src_ary++, param);
12073                     }
12074                     items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
12075                     while (items-- > 0) {
12076                         *dst_ary++ = &PL_sv_undef;
12077                     }
12078                 }
12079                 else {
12080                     AvARRAY(MUTABLE_AV(dstr))   = NULL;
12081                     AvALLOC((const AV *)dstr)   = (SV**)NULL;
12082                     AvMAX(  (const AV *)dstr)   = -1;
12083                     AvFILLp((const AV *)dstr)   = -1;
12084                 }
12085                 break;
12086             case SVt_PVHV:
12087                 if (HvARRAY((const HV *)sstr)) {
12088                     STRLEN i = 0;
12089                     const bool sharekeys = !!HvSHAREKEYS(sstr);
12090                     XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
12091                     XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
12092                     char *darray;
12093                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
12094                         + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
12095                         char);
12096                     HvARRAY(dstr) = (HE**)darray;
12097                     while (i <= sxhv->xhv_max) {
12098                         const HE * const source = HvARRAY(sstr)[i];
12099                         HvARRAY(dstr)[i] = source
12100                             ? he_dup(source, sharekeys, param) : 0;
12101                         ++i;
12102                     }
12103                     if (SvOOK(sstr)) {
12104                         const struct xpvhv_aux * const saux = HvAUX(sstr);
12105                         struct xpvhv_aux * const daux = HvAUX(dstr);
12106                         /* This flag isn't copied.  */
12107                         SvOOK_on(dstr);
12108
12109                         if (saux->xhv_name_count) {
12110                             HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
12111                             const I32 count
12112                              = saux->xhv_name_count < 0
12113                                 ? -saux->xhv_name_count
12114                                 :  saux->xhv_name_count;
12115                             HEK **shekp = sname + count;
12116                             HEK **dhekp;
12117                             Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
12118                             dhekp = daux->xhv_name_u.xhvnameu_names + count;
12119                             while (shekp-- > sname) {
12120                                 dhekp--;
12121                                 *dhekp = hek_dup(*shekp, param);
12122                             }
12123                         }
12124                         else {
12125                             daux->xhv_name_u.xhvnameu_name
12126                                 = hek_dup(saux->xhv_name_u.xhvnameu_name,
12127                                           param);
12128                         }
12129                         daux->xhv_name_count = saux->xhv_name_count;
12130
12131                         daux->xhv_riter = saux->xhv_riter;
12132                         daux->xhv_eiter = saux->xhv_eiter
12133                             ? he_dup(saux->xhv_eiter,
12134                                         cBOOL(HvSHAREKEYS(sstr)), param) : 0;
12135                         /* backref array needs refcnt=2; see sv_add_backref */
12136                         daux->xhv_backreferences =
12137                             (param->flags & CLONEf_JOIN_IN)
12138                                 /* when joining, we let the individual GVs and
12139                                  * CVs add themselves to backref as
12140                                  * needed. This avoids pulling in stuff
12141                                  * that isn't required, and simplifies the
12142                                  * case where stashes aren't cloned back
12143                                  * if they already exist in the parent
12144                                  * thread */
12145                             ? NULL
12146                             : saux->xhv_backreferences
12147                                 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
12148                                     ? MUTABLE_AV(SvREFCNT_inc(
12149                                           sv_dup_inc((const SV *)
12150                                             saux->xhv_backreferences, param)))
12151                                     : MUTABLE_AV(sv_dup((const SV *)
12152                                             saux->xhv_backreferences, param))
12153                                 : 0;
12154
12155                         daux->xhv_mro_meta = saux->xhv_mro_meta
12156                             ? mro_meta_dup(saux->xhv_mro_meta, param)
12157                             : 0;
12158
12159                         /* Record stashes for possible cloning in Perl_clone(). */
12160                         if (HvNAME(sstr))
12161                             av_push(param->stashes, dstr);
12162                     }
12163                 }
12164                 else
12165                     HvARRAY(MUTABLE_HV(dstr)) = NULL;
12166                 break;
12167             case SVt_PVCV:
12168                 if (!(param->flags & CLONEf_COPY_STACKS)) {
12169                     CvDEPTH(dstr) = 0;
12170                 }
12171                 /*FALLTHROUGH*/
12172             case SVt_PVFM:
12173                 /* NOTE: not refcounted */
12174                 SvANY(MUTABLE_CV(dstr))->xcv_stash =
12175                     hv_dup(CvSTASH(dstr), param);
12176                 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
12177                     Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
12178                 if (!CvISXSUB(dstr)) {
12179                     OP_REFCNT_LOCK;
12180                     CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
12181                     OP_REFCNT_UNLOCK;
12182                 } else if (CvCONST(dstr)) {
12183                     CvXSUBANY(dstr).any_ptr =
12184                         sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
12185                 }
12186                 if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
12187                 /* don't dup if copying back - CvGV isn't refcounted, so the
12188                  * duped GV may never be freed. A bit of a hack! DAPM */
12189                 SvANY(MUTABLE_CV(dstr))->xcv_gv =
12190                     CvCVGV_RC(dstr)
12191                     ? gv_dup_inc(CvGV(sstr), param)
12192                     : (param->flags & CLONEf_JOIN_IN)
12193                         ? NULL
12194                         : gv_dup(CvGV(sstr), param);
12195
12196                 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
12197                 CvOUTSIDE(dstr) =
12198                     CvWEAKOUTSIDE(sstr)
12199                     ? cv_dup(    CvOUTSIDE(dstr), param)
12200                     : cv_dup_inc(CvOUTSIDE(dstr), param);
12201                 break;
12202             }
12203         }
12204     }
12205
12206     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
12207         ++PL_sv_objcount;
12208
12209     return dstr;
12210  }
12211
12212 SV *
12213 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12214 {
12215     PERL_ARGS_ASSERT_SV_DUP_INC;
12216     return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
12217 }
12218
12219 SV *
12220 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12221 {
12222     SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
12223     PERL_ARGS_ASSERT_SV_DUP;
12224
12225     /* Track every SV that (at least initially) had a reference count of 0.
12226        We need to do this by holding an actual reference to it in this array.
12227        If we attempt to cheat, turn AvREAL_off(), and store only pointers
12228        (akin to the stashes hash, and the perl stack), we come unstuck if
12229        a weak reference (or other SV legitimately SvREFCNT() == 0 for this
12230        thread) is manipulated in a CLONE method, because CLONE runs before the
12231        unreferenced array is walked to find SVs still with SvREFCNT() == 0
12232        (and fix things up by giving each a reference via the temps stack).
12233        Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
12234        then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
12235        before the walk of unreferenced happens and a reference to that is SV
12236        added to the temps stack. At which point we have the same SV considered
12237        to be in use, and free to be re-used. Not good.
12238     */
12239     if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
12240         assert(param->unreferenced);
12241         av_push(param->unreferenced, SvREFCNT_inc(dstr));
12242     }
12243
12244     return dstr;
12245 }
12246
12247 /* duplicate a context */
12248
12249 PERL_CONTEXT *
12250 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12251 {
12252     PERL_CONTEXT *ncxs;
12253
12254     PERL_ARGS_ASSERT_CX_DUP;
12255
12256     if (!cxs)
12257         return (PERL_CONTEXT*)NULL;
12258
12259     /* look for it in the table first */
12260     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12261     if (ncxs)
12262         return ncxs;
12263
12264     /* create anew and remember what it is */
12265     Newx(ncxs, max + 1, PERL_CONTEXT);
12266     ptr_table_store(PL_ptr_table, cxs, ncxs);
12267     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12268
12269     while (ix >= 0) {
12270         PERL_CONTEXT * const ncx = &ncxs[ix];
12271         if (CxTYPE(ncx) == CXt_SUBST) {
12272             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12273         }
12274         else {
12275             switch (CxTYPE(ncx)) {
12276             case CXt_SUB:
12277                 ncx->blk_sub.cv         = (ncx->blk_sub.olddepth == 0
12278                                            ? cv_dup_inc(ncx->blk_sub.cv, param)
12279                                            : cv_dup(ncx->blk_sub.cv,param));
12280                 ncx->blk_sub.argarray   = (CxHASARGS(ncx)
12281                                            ? av_dup_inc(ncx->blk_sub.argarray,
12282                                                         param)
12283                                            : NULL);
12284                 ncx->blk_sub.savearray  = av_dup_inc(ncx->blk_sub.savearray,
12285                                                      param);
12286                 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12287                                            ncx->blk_sub.oldcomppad);
12288                 break;
12289             case CXt_EVAL:
12290                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12291                                                       param);
12292                 ncx->blk_eval.cur_text  = sv_dup(ncx->blk_eval.cur_text, param);
12293                 break;
12294             case CXt_LOOP_LAZYSV:
12295                 ncx->blk_loop.state_u.lazysv.end
12296                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12297                 /* We are taking advantage of av_dup_inc and sv_dup_inc
12298                    actually being the same function, and order equivalence of
12299                    the two unions.
12300                    We can assert the later [but only at run time :-(]  */
12301                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12302                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
12303             case CXt_LOOP_FOR:
12304                 ncx->blk_loop.state_u.ary.ary
12305                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12306             case CXt_LOOP_LAZYIV:
12307             case CXt_LOOP_PLAIN:
12308                 if (CxPADLOOP(ncx)) {
12309                     ncx->blk_loop.itervar_u.oldcomppad
12310                         = (PAD*)ptr_table_fetch(PL_ptr_table,
12311                                         ncx->blk_loop.itervar_u.oldcomppad);
12312                 } else {
12313                     ncx->blk_loop.itervar_u.gv
12314                         = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12315                                     param);
12316                 }
12317                 break;
12318             case CXt_FORMAT:
12319                 ncx->blk_format.cv      = cv_dup(ncx->blk_format.cv, param);
12320                 ncx->blk_format.gv      = gv_dup(ncx->blk_format.gv, param);
12321                 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12322                                                      param);
12323                 break;
12324             case CXt_BLOCK:
12325             case CXt_NULL:
12326                 break;
12327             }
12328         }
12329         --ix;
12330     }
12331     return ncxs;
12332 }
12333
12334 /* duplicate a stack info structure */
12335
12336 PERL_SI *
12337 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12338 {
12339     PERL_SI *nsi;
12340
12341     PERL_ARGS_ASSERT_SI_DUP;
12342
12343     if (!si)
12344         return (PERL_SI*)NULL;
12345
12346     /* look for it in the table first */
12347     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12348     if (nsi)
12349         return nsi;
12350
12351     /* create anew and remember what it is */
12352     Newxz(nsi, 1, PERL_SI);
12353     ptr_table_store(PL_ptr_table, si, nsi);
12354
12355     nsi->si_stack       = av_dup_inc(si->si_stack, param);
12356     nsi->si_cxix        = si->si_cxix;
12357     nsi->si_cxmax       = si->si_cxmax;
12358     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12359     nsi->si_type        = si->si_type;
12360     nsi->si_prev        = si_dup(si->si_prev, param);
12361     nsi->si_next        = si_dup(si->si_next, param);
12362     nsi->si_markoff     = si->si_markoff;
12363
12364     return nsi;
12365 }
12366
12367 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
12368 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
12369 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
12370 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
12371 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
12372 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
12373 #define POPUV(ss,ix)    ((ss)[--(ix)].any_uv)
12374 #define TOPUV(ss,ix)    ((ss)[ix].any_uv)
12375 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
12376 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
12377 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
12378 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
12379 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
12380 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
12381 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12382 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12383
12384 /* XXXXX todo */
12385 #define pv_dup_inc(p)   SAVEPV(p)
12386 #define pv_dup(p)       SAVEPV(p)
12387 #define svp_dup_inc(p,pp)       any_dup(p,pp)
12388
12389 /* map any object to the new equivent - either something in the
12390  * ptr table, or something in the interpreter structure
12391  */
12392
12393 void *
12394 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12395 {
12396     void *ret;
12397
12398     PERL_ARGS_ASSERT_ANY_DUP;
12399
12400     if (!v)
12401         return (void*)NULL;
12402
12403     /* look for it in the table first */
12404     ret = ptr_table_fetch(PL_ptr_table, v);
12405     if (ret)
12406         return ret;
12407
12408     /* see if it is part of the interpreter structure */
12409     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12410         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12411     else {
12412         ret = v;
12413     }
12414
12415     return ret;
12416 }
12417
12418 /* duplicate the save stack */
12419
12420 ANY *
12421 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12422 {
12423     dVAR;
12424     ANY * const ss      = proto_perl->Isavestack;
12425     const I32 max       = proto_perl->Isavestack_max;
12426     I32 ix              = proto_perl->Isavestack_ix;
12427     ANY *nss;
12428     const SV *sv;
12429     const GV *gv;
12430     const AV *av;
12431     const HV *hv;
12432     void* ptr;
12433     int intval;
12434     long longval;
12435     GP *gp;
12436     IV iv;
12437     I32 i;
12438     char *c = NULL;
12439     void (*dptr) (void*);
12440     void (*dxptr) (pTHX_ void*);
12441
12442     PERL_ARGS_ASSERT_SS_DUP;
12443
12444     Newxz(nss, max, ANY);
12445
12446     while (ix > 0) {
12447         const UV uv = POPUV(ss,ix);
12448         const U8 type = (U8)uv & SAVE_MASK;
12449
12450         TOPUV(nss,ix) = uv;
12451         switch (type) {
12452         case SAVEt_CLEARSV:
12453             break;
12454         case SAVEt_HELEM:               /* hash element */
12455             sv = (const SV *)POPPTR(ss,ix);
12456             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12457             /* fall through */
12458         case SAVEt_ITEM:                        /* normal string */
12459         case SAVEt_GVSV:                        /* scalar slot in GV */
12460         case SAVEt_SV:                          /* scalar reference */
12461             sv = (const SV *)POPPTR(ss,ix);
12462             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12463             /* fall through */
12464         case SAVEt_FREESV:
12465         case SAVEt_MORTALIZESV:
12466             sv = (const SV *)POPPTR(ss,ix);
12467             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12468             break;
12469         case SAVEt_SHARED_PVREF:                /* char* in shared space */
12470             c = (char*)POPPTR(ss,ix);
12471             TOPPTR(nss,ix) = savesharedpv(c);
12472             ptr = POPPTR(ss,ix);
12473             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12474             break;
12475         case SAVEt_GENERIC_SVREF:               /* generic sv */
12476         case SAVEt_SVREF:                       /* scalar reference */
12477             sv = (const SV *)POPPTR(ss,ix);
12478             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12479             ptr = POPPTR(ss,ix);
12480             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12481             break;
12482         case SAVEt_HV:                          /* hash reference */
12483         case SAVEt_AV:                          /* array reference */
12484             sv = (const SV *) POPPTR(ss,ix);
12485             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12486             /* fall through */
12487         case SAVEt_COMPPAD:
12488         case SAVEt_NSTAB:
12489             sv = (const SV *) POPPTR(ss,ix);
12490             TOPPTR(nss,ix) = sv_dup(sv, param);
12491             break;
12492         case SAVEt_INT:                         /* int reference */
12493             ptr = POPPTR(ss,ix);
12494             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12495             intval = (int)POPINT(ss,ix);
12496             TOPINT(nss,ix) = intval;
12497             break;
12498         case SAVEt_LONG:                        /* long reference */
12499             ptr = POPPTR(ss,ix);
12500             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12501             longval = (long)POPLONG(ss,ix);
12502             TOPLONG(nss,ix) = longval;
12503             break;
12504         case SAVEt_I32:                         /* I32 reference */
12505             ptr = POPPTR(ss,ix);
12506             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12507             i = POPINT(ss,ix);
12508             TOPINT(nss,ix) = i;
12509             break;
12510         case SAVEt_IV:                          /* IV reference */
12511             ptr = POPPTR(ss,ix);
12512             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12513             iv = POPIV(ss,ix);
12514             TOPIV(nss,ix) = iv;
12515             break;
12516         case SAVEt_HPTR:                        /* HV* reference */
12517         case SAVEt_APTR:                        /* AV* reference */
12518         case SAVEt_SPTR:                        /* SV* reference */
12519             ptr = POPPTR(ss,ix);
12520             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12521             sv = (const SV *)POPPTR(ss,ix);
12522             TOPPTR(nss,ix) = sv_dup(sv, param);
12523             break;
12524         case SAVEt_VPTR:                        /* random* reference */
12525             ptr = POPPTR(ss,ix);
12526             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12527             /* Fall through */
12528         case SAVEt_INT_SMALL:
12529         case SAVEt_I32_SMALL:
12530         case SAVEt_I16:                         /* I16 reference */
12531         case SAVEt_I8:                          /* I8 reference */
12532         case SAVEt_BOOL:
12533             ptr = POPPTR(ss,ix);
12534             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12535             break;
12536         case SAVEt_GENERIC_PVREF:               /* generic char* */
12537         case SAVEt_PPTR:                        /* char* reference */
12538             ptr = POPPTR(ss,ix);
12539             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12540             c = (char*)POPPTR(ss,ix);
12541             TOPPTR(nss,ix) = pv_dup(c);
12542             break;
12543         case SAVEt_GP:                          /* scalar reference */
12544             gp = (GP*)POPPTR(ss,ix);
12545             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12546             (void)GpREFCNT_inc(gp);
12547             gv = (const GV *)POPPTR(ss,ix);
12548             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12549             break;
12550         case SAVEt_FREEOP:
12551             ptr = POPPTR(ss,ix);
12552             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12553                 /* these are assumed to be refcounted properly */
12554                 OP *o;
12555                 switch (((OP*)ptr)->op_type) {
12556                 case OP_LEAVESUB:
12557                 case OP_LEAVESUBLV:
12558                 case OP_LEAVEEVAL:
12559                 case OP_LEAVE:
12560                 case OP_SCOPE:
12561                 case OP_LEAVEWRITE:
12562                     TOPPTR(nss,ix) = ptr;
12563                     o = (OP*)ptr;
12564                     OP_REFCNT_LOCK;
12565                     (void) OpREFCNT_inc(o);
12566                     OP_REFCNT_UNLOCK;
12567                     break;
12568                 default:
12569                     TOPPTR(nss,ix) = NULL;
12570                     break;
12571                 }
12572             }
12573             else
12574                 TOPPTR(nss,ix) = NULL;
12575             break;
12576         case SAVEt_FREECOPHH:
12577             ptr = POPPTR(ss,ix);
12578             TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
12579             break;
12580         case SAVEt_DELETE:
12581             hv = (const HV *)POPPTR(ss,ix);
12582             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12583             i = POPINT(ss,ix);
12584             TOPINT(nss,ix) = i;
12585             /* Fall through */
12586         case SAVEt_FREEPV:
12587             c = (char*)POPPTR(ss,ix);
12588             TOPPTR(nss,ix) = pv_dup_inc(c);
12589             break;
12590         case SAVEt_STACK_POS:           /* Position on Perl stack */
12591             i = POPINT(ss,ix);
12592             TOPINT(nss,ix) = i;
12593             break;
12594         case SAVEt_DESTRUCTOR:
12595             ptr = POPPTR(ss,ix);
12596             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
12597             dptr = POPDPTR(ss,ix);
12598             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
12599                                         any_dup(FPTR2DPTR(void *, dptr),
12600                                                 proto_perl));
12601             break;
12602         case SAVEt_DESTRUCTOR_X:
12603             ptr = POPPTR(ss,ix);
12604             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
12605             dxptr = POPDXPTR(ss,ix);
12606             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
12607                                          any_dup(FPTR2DPTR(void *, dxptr),
12608                                                  proto_perl));
12609             break;
12610         case SAVEt_REGCONTEXT:
12611         case SAVEt_ALLOC:
12612             ix -= uv >> SAVE_TIGHT_SHIFT;
12613             break;
12614         case SAVEt_AELEM:               /* array element */
12615             sv = (const SV *)POPPTR(ss,ix);
12616             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12617             i = POPINT(ss,ix);
12618             TOPINT(nss,ix) = i;
12619             av = (const AV *)POPPTR(ss,ix);
12620             TOPPTR(nss,ix) = av_dup_inc(av, param);
12621             break;
12622         case SAVEt_OP:
12623             ptr = POPPTR(ss,ix);
12624             TOPPTR(nss,ix) = ptr;
12625             break;
12626         case SAVEt_HINTS:
12627             ptr = POPPTR(ss,ix);
12628             ptr = cophh_copy((COPHH*)ptr);
12629             TOPPTR(nss,ix) = ptr;
12630             i = POPINT(ss,ix);
12631             TOPINT(nss,ix) = i;
12632             if (i & HINT_LOCALIZE_HH) {
12633                 hv = (const HV *)POPPTR(ss,ix);
12634                 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12635             }
12636             break;
12637         case SAVEt_PADSV_AND_MORTALIZE:
12638             longval = (long)POPLONG(ss,ix);
12639             TOPLONG(nss,ix) = longval;
12640             ptr = POPPTR(ss,ix);
12641             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12642             sv = (const SV *)POPPTR(ss,ix);
12643             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12644             break;
12645         case SAVEt_SET_SVFLAGS:
12646             i = POPINT(ss,ix);
12647             TOPINT(nss,ix) = i;
12648             i = POPINT(ss,ix);
12649             TOPINT(nss,ix) = i;
12650             sv = (const SV *)POPPTR(ss,ix);
12651             TOPPTR(nss,ix) = sv_dup(sv, param);
12652             break;
12653         case SAVEt_RE_STATE:
12654             {
12655                 const struct re_save_state *const old_state
12656                     = (struct re_save_state *)
12657                     (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12658                 struct re_save_state *const new_state
12659                     = (struct re_save_state *)
12660                     (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12661
12662                 Copy(old_state, new_state, 1, struct re_save_state);
12663                 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12664
12665                 new_state->re_state_bostr
12666                     = pv_dup(old_state->re_state_bostr);
12667                 new_state->re_state_reginput
12668                     = pv_dup(old_state->re_state_reginput);
12669                 new_state->re_state_regeol
12670                     = pv_dup(old_state->re_state_regeol);
12671                 new_state->re_state_regoffs
12672                     = (regexp_paren_pair*)
12673                         any_dup(old_state->re_state_regoffs, proto_perl);
12674                 new_state->re_state_reglastparen
12675                     = (U32*) any_dup(old_state->re_state_reglastparen,
12676                               proto_perl);
12677                 new_state->re_state_reglastcloseparen
12678                     = (U32*)any_dup(old_state->re_state_reglastcloseparen,
12679                               proto_perl);
12680                 /* XXX This just has to be broken. The old save_re_context
12681                    code did SAVEGENERICPV(PL_reg_start_tmp);
12682                    PL_reg_start_tmp is char **.
12683                    Look above to what the dup code does for
12684                    SAVEt_GENERIC_PVREF
12685                    It can never have worked.
12686                    So this is merely a faithful copy of the exiting bug:  */
12687                 new_state->re_state_reg_start_tmp
12688                     = (char **) pv_dup((char *)
12689                                       old_state->re_state_reg_start_tmp);
12690                 /* I assume that it only ever "worked" because no-one called
12691                    (pseudo)fork while the regexp engine had re-entered itself.
12692                 */
12693 #ifdef PERL_OLD_COPY_ON_WRITE
12694                 new_state->re_state_nrs
12695                     = sv_dup(old_state->re_state_nrs, param);
12696 #endif
12697                 new_state->re_state_reg_magic
12698                     = (MAGIC*) any_dup(old_state->re_state_reg_magic,
12699                                proto_perl);
12700                 new_state->re_state_reg_oldcurpm
12701                     = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
12702                               proto_perl);
12703                 new_state->re_state_reg_curpm
12704                     = (PMOP*)  any_dup(old_state->re_state_reg_curpm,
12705                                proto_perl);
12706                 new_state->re_state_reg_oldsaved
12707                     = pv_dup(old_state->re_state_reg_oldsaved);
12708                 new_state->re_state_reg_poscache
12709                     = pv_dup(old_state->re_state_reg_poscache);
12710                 new_state->re_state_reg_starttry
12711                     = pv_dup(old_state->re_state_reg_starttry);
12712                 break;
12713             }
12714         case SAVEt_COMPILE_WARNINGS:
12715             ptr = POPPTR(ss,ix);
12716             TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12717             break;
12718         case SAVEt_PARSER:
12719             ptr = POPPTR(ss,ix);
12720             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12721             break;
12722         default:
12723             Perl_croak(aTHX_
12724                        "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12725         }
12726     }
12727
12728     return nss;
12729 }
12730
12731
12732 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12733  * flag to the result. This is done for each stash before cloning starts,
12734  * so we know which stashes want their objects cloned */
12735
12736 static void
12737 do_mark_cloneable_stash(pTHX_ SV *const sv)
12738 {
12739     const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12740     if (hvname) {
12741         GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12742         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12743         if (cloner && GvCV(cloner)) {
12744             dSP;
12745             UV status;
12746
12747             ENTER;
12748             SAVETMPS;
12749             PUSHMARK(SP);
12750             mXPUSHs(newSVhek(hvname));
12751             PUTBACK;
12752             call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12753             SPAGAIN;
12754             status = POPu;
12755             PUTBACK;
12756             FREETMPS;
12757             LEAVE;
12758             if (status)
12759                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12760         }
12761     }
12762 }
12763
12764
12765
12766 /*
12767 =for apidoc perl_clone
12768
12769 Create and return a new interpreter by cloning the current one.
12770
12771 perl_clone takes these flags as parameters:
12772
12773 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12774 without it we only clone the data and zero the stacks,
12775 with it we copy the stacks and the new perl interpreter is
12776 ready to run at the exact same point as the previous one.
12777 The pseudo-fork code uses COPY_STACKS while the
12778 threads->create doesn't.
12779
12780 CLONEf_KEEP_PTR_TABLE -
12781 perl_clone keeps a ptr_table with the pointer of the old
12782 variable as a key and the new variable as a value,
12783 this allows it to check if something has been cloned and not
12784 clone it again but rather just use the value and increase the
12785 refcount.  If KEEP_PTR_TABLE is not set then perl_clone will kill
12786 the ptr_table using the function
12787 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12788 reason to keep it around is if you want to dup some of your own
12789 variable who are outside the graph perl scans, example of this
12790 code is in threads.xs create.
12791
12792 CLONEf_CLONE_HOST -
12793 This is a win32 thing, it is ignored on unix, it tells perls
12794 win32host code (which is c++) to clone itself, this is needed on
12795 win32 if you want to run two threads at the same time,
12796 if you just want to do some stuff in a separate perl interpreter
12797 and then throw it away and return to the original one,
12798 you don't need to do anything.
12799
12800 =cut
12801 */
12802
12803 /* XXX the above needs expanding by someone who actually understands it ! */
12804 EXTERN_C PerlInterpreter *
12805 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12806
12807 PerlInterpreter *
12808 perl_clone(PerlInterpreter *proto_perl, UV flags)
12809 {
12810    dVAR;
12811 #ifdef PERL_IMPLICIT_SYS
12812
12813     PERL_ARGS_ASSERT_PERL_CLONE;
12814
12815    /* perlhost.h so we need to call into it
12816    to clone the host, CPerlHost should have a c interface, sky */
12817
12818    if (flags & CLONEf_CLONE_HOST) {
12819        return perl_clone_host(proto_perl,flags);
12820    }
12821    return perl_clone_using(proto_perl, flags,
12822                             proto_perl->IMem,
12823                             proto_perl->IMemShared,
12824                             proto_perl->IMemParse,
12825                             proto_perl->IEnv,
12826                             proto_perl->IStdIO,
12827                             proto_perl->ILIO,
12828                             proto_perl->IDir,
12829                             proto_perl->ISock,
12830                             proto_perl->IProc);
12831 }
12832
12833 PerlInterpreter *
12834 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12835                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
12836                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12837                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12838                  struct IPerlDir* ipD, struct IPerlSock* ipS,
12839                  struct IPerlProc* ipP)
12840 {
12841     /* XXX many of the string copies here can be optimized if they're
12842      * constants; they need to be allocated as common memory and just
12843      * their pointers copied. */
12844
12845     IV i;
12846     CLONE_PARAMS clone_params;
12847     CLONE_PARAMS* const param = &clone_params;
12848
12849     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12850
12851     PERL_ARGS_ASSERT_PERL_CLONE_USING;
12852 #else           /* !PERL_IMPLICIT_SYS */
12853     IV i;
12854     CLONE_PARAMS clone_params;
12855     CLONE_PARAMS* param = &clone_params;
12856     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12857
12858     PERL_ARGS_ASSERT_PERL_CLONE;
12859 #endif          /* PERL_IMPLICIT_SYS */
12860
12861     /* for each stash, determine whether its objects should be cloned */
12862     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12863     PERL_SET_THX(my_perl);
12864
12865 #ifdef DEBUGGING
12866     PoisonNew(my_perl, 1, PerlInterpreter);
12867     PL_op = NULL;
12868     PL_curcop = NULL;
12869     PL_defstash = NULL; /* may be used by perl malloc() */
12870     PL_markstack = 0;
12871     PL_scopestack = 0;
12872     PL_scopestack_name = 0;
12873     PL_savestack = 0;
12874     PL_savestack_ix = 0;
12875     PL_savestack_max = -1;
12876     PL_sig_pending = 0;
12877     PL_parser = NULL;
12878     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12879 #  ifdef DEBUG_LEAKING_SCALARS
12880     PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12881 #  endif
12882 #else   /* !DEBUGGING */
12883     Zero(my_perl, 1, PerlInterpreter);
12884 #endif  /* DEBUGGING */
12885
12886 #ifdef PERL_IMPLICIT_SYS
12887     /* host pointers */
12888     PL_Mem              = ipM;
12889     PL_MemShared        = ipMS;
12890     PL_MemParse         = ipMP;
12891     PL_Env              = ipE;
12892     PL_StdIO            = ipStd;
12893     PL_LIO              = ipLIO;
12894     PL_Dir              = ipD;
12895     PL_Sock             = ipS;
12896     PL_Proc             = ipP;
12897 #endif          /* PERL_IMPLICIT_SYS */
12898
12899     param->flags = flags;
12900     /* Nothing in the core code uses this, but we make it available to
12901        extensions (using mg_dup).  */
12902     param->proto_perl = proto_perl;
12903     /* Likely nothing will use this, but it is initialised to be consistent
12904        with Perl_clone_params_new().  */
12905     param->new_perl = my_perl;
12906     param->unreferenced = NULL;
12907
12908     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12909
12910     PL_body_arenas = NULL;
12911     Zero(&PL_body_roots, 1, PL_body_roots);
12912
12913     PL_sv_count         = 0;
12914     PL_sv_objcount      = 0;
12915     PL_sv_root          = NULL;
12916     PL_sv_arenaroot     = NULL;
12917
12918     PL_debug            = proto_perl->Idebug;
12919
12920     PL_hash_seed        = proto_perl->Ihash_seed;
12921     PL_rehash_seed      = proto_perl->Irehash_seed;
12922
12923     SvANY(&PL_sv_undef)         = NULL;
12924     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
12925     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
12926     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
12927     SvFLAGS(&PL_sv_no)          = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12928                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12929
12930     SvANY(&PL_sv_yes)           = new_XPVNV();
12931     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
12932     SvFLAGS(&PL_sv_yes)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12933                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12934
12935     /* dbargs array probably holds garbage */
12936     PL_dbargs           = NULL;
12937
12938     PL_compiling = proto_perl->Icompiling;
12939
12940 #ifdef PERL_DEBUG_READONLY_OPS
12941     PL_slabs = NULL;
12942     PL_slab_count = 0;
12943 #endif
12944
12945     /* pseudo environmental stuff */
12946     PL_origargc         = proto_perl->Iorigargc;
12947     PL_origargv         = proto_perl->Iorigargv;
12948
12949     /* Set tainting stuff before PerlIO_debug can possibly get called */
12950     PL_tainting         = proto_perl->Itainting;
12951     PL_taint_warn       = proto_perl->Itaint_warn;
12952
12953     PL_minus_c          = proto_perl->Iminus_c;
12954
12955     PL_localpatches     = proto_perl->Ilocalpatches;
12956     PL_splitstr         = proto_perl->Isplitstr;
12957     PL_minus_n          = proto_perl->Iminus_n;
12958     PL_minus_p          = proto_perl->Iminus_p;
12959     PL_minus_l          = proto_perl->Iminus_l;
12960     PL_minus_a          = proto_perl->Iminus_a;
12961     PL_minus_E          = proto_perl->Iminus_E;
12962     PL_minus_F          = proto_perl->Iminus_F;
12963     PL_doswitches       = proto_perl->Idoswitches;
12964     PL_dowarn           = proto_perl->Idowarn;
12965     PL_sawampersand     = proto_perl->Isawampersand;
12966     PL_unsafe           = proto_perl->Iunsafe;
12967     PL_perldb           = proto_perl->Iperldb;
12968     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12969     PL_exit_flags       = proto_perl->Iexit_flags;
12970
12971     /* XXX time(&PL_basetime) when asked for? */
12972     PL_basetime         = proto_perl->Ibasetime;
12973
12974     PL_maxsysfd         = proto_perl->Imaxsysfd;
12975     PL_statusvalue      = proto_perl->Istatusvalue;
12976 #ifdef VMS
12977     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
12978 #else
12979     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12980 #endif
12981
12982     /* RE engine related */
12983     Zero(&PL_reg_state, 1, struct re_save_state);
12984     PL_reginterp_cnt    = 0;
12985     PL_regmatch_slab    = NULL;
12986
12987     PL_sub_generation   = proto_perl->Isub_generation;
12988
12989     /* funky return mechanisms */
12990     PL_forkprocess      = proto_perl->Iforkprocess;
12991
12992     /* internal state */
12993     PL_maxo             = proto_perl->Imaxo;
12994
12995     PL_main_start       = proto_perl->Imain_start;
12996     PL_eval_root        = proto_perl->Ieval_root;
12997     PL_eval_start       = proto_perl->Ieval_start;
12998
12999     PL_filemode         = proto_perl->Ifilemode;
13000     PL_lastfd           = proto_perl->Ilastfd;
13001     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
13002     PL_Argv             = NULL;
13003     PL_Cmd              = NULL;
13004     PL_gensym           = proto_perl->Igensym;
13005
13006     PL_laststatval      = proto_perl->Ilaststatval;
13007     PL_laststype        = proto_perl->Ilaststype;
13008     PL_mess_sv          = NULL;
13009
13010     PL_profiledata      = NULL;
13011
13012     PL_generation       = proto_perl->Igeneration;
13013
13014     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
13015     PL_in_clean_all     = proto_perl->Iin_clean_all;
13016
13017     PL_uid              = proto_perl->Iuid;
13018     PL_euid             = proto_perl->Ieuid;
13019     PL_gid              = proto_perl->Igid;
13020     PL_egid             = proto_perl->Iegid;
13021     PL_nomemok          = proto_perl->Inomemok;
13022     PL_an               = proto_perl->Ian;
13023     PL_evalseq          = proto_perl->Ievalseq;
13024     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
13025     PL_origalen         = proto_perl->Iorigalen;
13026
13027     PL_sighandlerp      = proto_perl->Isighandlerp;
13028
13029     PL_runops           = proto_perl->Irunops;
13030
13031     PL_subline          = proto_perl->Isubline;
13032
13033 #ifdef FCRYPT
13034     PL_cryptseen        = proto_perl->Icryptseen;
13035 #endif
13036
13037     PL_hints            = proto_perl->Ihints;
13038
13039     PL_amagic_generation        = proto_perl->Iamagic_generation;
13040
13041 #ifdef USE_LOCALE_COLLATE
13042     PL_collation_ix     = proto_perl->Icollation_ix;
13043     PL_collation_standard       = proto_perl->Icollation_standard;
13044     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
13045     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
13046 #endif /* USE_LOCALE_COLLATE */
13047
13048 #ifdef USE_LOCALE_NUMERIC
13049     PL_numeric_standard = proto_perl->Inumeric_standard;
13050     PL_numeric_local    = proto_perl->Inumeric_local;
13051 #endif /* !USE_LOCALE_NUMERIC */
13052
13053     /* Did the locale setup indicate UTF-8? */
13054     PL_utf8locale       = proto_perl->Iutf8locale;
13055     /* Unicode features (see perlrun/-C) */
13056     PL_unicode          = proto_perl->Iunicode;
13057
13058     /* Pre-5.8 signals control */
13059     PL_signals          = proto_perl->Isignals;
13060
13061     /* times() ticks per second */
13062     PL_clocktick        = proto_perl->Iclocktick;
13063
13064     /* Recursion stopper for PerlIO_find_layer */
13065     PL_in_load_module   = proto_perl->Iin_load_module;
13066
13067     /* sort() routine */
13068     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
13069
13070     /* Not really needed/useful since the reenrant_retint is "volatile",
13071      * but do it for consistency's sake. */
13072     PL_reentrant_retint = proto_perl->Ireentrant_retint;
13073
13074     /* Hooks to shared SVs and locks. */
13075     PL_sharehook        = proto_perl->Isharehook;
13076     PL_lockhook         = proto_perl->Ilockhook;
13077     PL_unlockhook       = proto_perl->Iunlockhook;
13078     PL_threadhook       = proto_perl->Ithreadhook;
13079     PL_destroyhook      = proto_perl->Idestroyhook;
13080     PL_signalhook       = proto_perl->Isignalhook;
13081
13082     PL_globhook         = proto_perl->Iglobhook;
13083
13084 #ifdef THREADS_HAVE_PIDS
13085     PL_ppid             = proto_perl->Ippid;
13086 #endif
13087
13088     /* swatch cache */
13089     PL_last_swash_hv    = NULL; /* reinits on demand */
13090     PL_last_swash_klen  = 0;
13091     PL_last_swash_key[0]= '\0';
13092     PL_last_swash_tmps  = (U8*)NULL;
13093     PL_last_swash_slen  = 0;
13094
13095     PL_glob_index       = proto_perl->Iglob_index;
13096     PL_srand_called     = proto_perl->Isrand_called;
13097
13098     if (flags & CLONEf_COPY_STACKS) {
13099         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13100         PL_tmps_ix              = proto_perl->Itmps_ix;
13101         PL_tmps_max             = proto_perl->Itmps_max;
13102         PL_tmps_floor           = proto_perl->Itmps_floor;
13103
13104         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13105          * NOTE: unlike the others! */
13106         PL_scopestack_ix        = proto_perl->Iscopestack_ix;
13107         PL_scopestack_max       = proto_perl->Iscopestack_max;
13108
13109         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13110          * NOTE: unlike the others! */
13111         PL_savestack_ix         = proto_perl->Isavestack_ix;
13112         PL_savestack_max        = proto_perl->Isavestack_max;
13113     }
13114
13115     PL_start_env        = proto_perl->Istart_env;       /* XXXXXX */
13116     PL_top_env          = &PL_start_env;
13117
13118     PL_op               = proto_perl->Iop;
13119
13120     PL_Sv               = NULL;
13121     PL_Xpv              = (XPV*)NULL;
13122     my_perl->Ina        = proto_perl->Ina;
13123
13124     PL_statbuf          = proto_perl->Istatbuf;
13125     PL_statcache        = proto_perl->Istatcache;
13126
13127 #ifdef HAS_TIMES
13128     PL_timesbuf         = proto_perl->Itimesbuf;
13129 #endif
13130
13131     PL_tainted          = proto_perl->Itainted;
13132     PL_curpm            = proto_perl->Icurpm;   /* XXX No PMOP ref count */
13133
13134     PL_chopset          = proto_perl->Ichopset; /* XXX never deallocated */
13135
13136     PL_restartjmpenv    = proto_perl->Irestartjmpenv;
13137     PL_restartop        = proto_perl->Irestartop;
13138     PL_in_eval          = proto_perl->Iin_eval;
13139     PL_delaymagic       = proto_perl->Idelaymagic;
13140     PL_phase            = proto_perl->Iphase;
13141     PL_localizing       = proto_perl->Ilocalizing;
13142
13143     PL_hv_fetch_ent_mh  = NULL;
13144     PL_modcount         = proto_perl->Imodcount;
13145     PL_lastgotoprobe    = NULL;
13146     PL_dumpindent       = proto_perl->Idumpindent;
13147
13148     PL_efloatbuf        = NULL;         /* reinits on demand */
13149     PL_efloatsize       = 0;                    /* reinits on demand */
13150
13151     /* regex stuff */
13152
13153     PL_regdummy         = proto_perl->Iregdummy;
13154     PL_colorset         = 0;            /* reinits PL_colors[] */
13155     /*PL_colors[6]      = {0,0,0,0,0,0};*/
13156
13157     /* Pluggable optimizer */
13158     PL_peepp            = proto_perl->Ipeepp;
13159     PL_rpeepp           = proto_perl->Irpeepp;
13160     /* op_free() hook */
13161     PL_opfreehook       = proto_perl->Iopfreehook;
13162
13163 #ifdef USE_REENTRANT_API
13164     /* XXX: things like -Dm will segfault here in perlio, but doing
13165      *  PERL_SET_CONTEXT(proto_perl);
13166      * breaks too many other things
13167      */
13168     Perl_reentrant_init(aTHX);
13169 #endif
13170
13171     /* create SV map for pointer relocation */
13172     PL_ptr_table = ptr_table_new();
13173
13174     /* initialize these special pointers as early as possible */
13175     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
13176
13177     SvANY(&PL_sv_no)            = new_XPVNV();
13178     SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
13179     SvCUR_set(&PL_sv_no, 0);
13180     SvLEN_set(&PL_sv_no, 1);
13181     SvIV_set(&PL_sv_no, 0);
13182     SvNV_set(&PL_sv_no, 0);
13183     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
13184
13185     SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
13186     SvCUR_set(&PL_sv_yes, 1);
13187     SvLEN_set(&PL_sv_yes, 2);
13188     SvIV_set(&PL_sv_yes, 1);
13189     SvNV_set(&PL_sv_yes, 1);
13190     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
13191
13192     /* create (a non-shared!) shared string table */
13193     PL_strtab           = newHV();
13194     HvSHAREKEYS_off(PL_strtab);
13195     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
13196     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
13197
13198     /* These two PVs will be free'd special way so must set them same way op.c does */
13199     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
13200     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
13201
13202     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
13203     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
13204
13205     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
13206     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
13207     CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
13208     PL_curcop           = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
13209
13210     param->stashes      = newAV();  /* Setup array of objects to call clone on */
13211     /* This makes no difference to the implementation, as it always pushes
13212        and shifts pointers to other SVs without changing their reference
13213        count, with the array becoming empty before it is freed. However, it
13214        makes it conceptually clear what is going on, and will avoid some
13215        work inside av.c, filling slots between AvFILL() and AvMAX() with
13216        &PL_sv_undef, and SvREFCNT_dec()ing those.  */
13217     AvREAL_off(param->stashes);
13218
13219     if (!(flags & CLONEf_COPY_STACKS)) {
13220         param->unreferenced = newAV();
13221     }
13222
13223 #ifdef PERLIO_LAYERS
13224     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
13225     PerlIO_clone(aTHX_ proto_perl, param);
13226 #endif
13227
13228     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
13229     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
13230     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
13231     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
13232     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
13233     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
13234
13235     /* switches */
13236     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
13237     PL_apiversion       = sv_dup_inc(proto_perl->Iapiversion, param);
13238     PL_inplace          = SAVEPV(proto_perl->Iinplace);
13239     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
13240
13241     /* magical thingies */
13242     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
13243
13244     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
13245
13246     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
13247     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
13248     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
13249
13250
13251     /* Clone the regex array */
13252     /* ORANGE FIXME for plugins, probably in the SV dup code.
13253        newSViv(PTR2IV(CALLREGDUPE(
13254        INT2PTR(REGEXP *, SvIVX(regex)), param))))
13255     */
13256     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
13257     PL_regex_pad = AvARRAY(PL_regex_padav);
13258
13259     /* shortcuts to various I/O objects */
13260     PL_ofsgv            = gv_dup_inc(proto_perl->Iofsgv, param);
13261     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
13262     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
13263     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
13264     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
13265     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
13266     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
13267
13268     /* shortcuts to regexp stuff */
13269     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
13270
13271     /* shortcuts to misc objects */
13272     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
13273
13274     /* shortcuts to debugging objects */
13275     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
13276     PL_DBline           = gv_dup(proto_perl->IDBline, param);
13277     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
13278     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
13279     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
13280     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
13281
13282     /* symbol tables */
13283     PL_defstash         = hv_dup_inc(proto_perl->Idefstash, param);
13284     PL_curstash         = hv_dup_inc(proto_perl->Icurstash, param);
13285     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
13286     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
13287     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
13288
13289     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
13290     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
13291     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
13292     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
13293     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
13294     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
13295     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
13296     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
13297
13298     PL_isarev           = hv_dup_inc(proto_perl->Iisarev, param);
13299
13300     /* subprocess state */
13301     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
13302
13303     if (proto_perl->Iop_mask)
13304         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
13305     else
13306         PL_op_mask      = NULL;
13307     /* PL_asserting        = proto_perl->Iasserting; */
13308
13309     /* current interpreter roots */
13310     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
13311     OP_REFCNT_LOCK;
13312     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
13313     OP_REFCNT_UNLOCK;
13314
13315     /* runtime control stuff */
13316     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
13317
13318     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
13319
13320     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
13321
13322     /* interpreter atexit processing */
13323     PL_exitlistlen      = proto_perl->Iexitlistlen;
13324     if (PL_exitlistlen) {
13325         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13326         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13327     }
13328     else
13329         PL_exitlist     = (PerlExitListEntry*)NULL;
13330
13331     PL_my_cxt_size = proto_perl->Imy_cxt_size;
13332     if (PL_my_cxt_size) {
13333         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
13334         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
13335 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13336         Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
13337         Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
13338 #endif
13339     }
13340     else {
13341         PL_my_cxt_list  = (void**)NULL;
13342 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13343         PL_my_cxt_keys  = (const char**)NULL;
13344 #endif
13345     }
13346     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
13347     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
13348     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
13349     PL_custom_ops       = hv_dup_inc(proto_perl->Icustom_ops, param);
13350
13351     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
13352
13353     PAD_CLONE_VARS(proto_perl, param);
13354
13355 #ifdef HAVE_INTERP_INTERN
13356     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
13357 #endif
13358
13359     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
13360
13361 #ifdef PERL_USES_PL_PIDSTATUS
13362     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
13363 #endif
13364     PL_osname           = SAVEPV(proto_perl->Iosname);
13365     PL_parser           = parser_dup(proto_perl->Iparser, param);
13366
13367     /* XXX this only works if the saved cop has already been cloned */
13368     if (proto_perl->Iparser) {
13369         PL_parser->saved_curcop = (COP*)any_dup(
13370                                     proto_perl->Iparser->saved_curcop,
13371                                     proto_perl);
13372     }
13373
13374     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
13375
13376 #ifdef USE_LOCALE_COLLATE
13377     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
13378 #endif /* USE_LOCALE_COLLATE */
13379
13380 #ifdef USE_LOCALE_NUMERIC
13381     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
13382     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13383 #endif /* !USE_LOCALE_NUMERIC */
13384
13385     /* Unicode inversion lists */
13386     PL_ASCII            = sv_dup_inc(proto_perl->IASCII, param);
13387     PL_Latin1           = sv_dup_inc(proto_perl->ILatin1, param);
13388
13389     PL_PerlSpace        = sv_dup_inc(proto_perl->IPerlSpace, param);
13390     PL_XPerlSpace       = sv_dup_inc(proto_perl->IXPerlSpace, param);
13391
13392     PL_L1PosixAlnum     = sv_dup_inc(proto_perl->IL1PosixAlnum, param);
13393     PL_PosixAlnum       = sv_dup_inc(proto_perl->IPosixAlnum, param);
13394
13395     PL_L1PosixAlpha     = sv_dup_inc(proto_perl->IL1PosixAlpha, param);
13396     PL_PosixAlpha       = sv_dup_inc(proto_perl->IPosixAlpha, param);
13397
13398     PL_PosixBlank       = sv_dup_inc(proto_perl->IPosixBlank, param);
13399     PL_XPosixBlank      = sv_dup_inc(proto_perl->IXPosixBlank, param);
13400
13401     PL_PosixCntrl       = sv_dup_inc(proto_perl->IPosixCntrl, param);
13402     PL_XPosixCntrl      = sv_dup_inc(proto_perl->IXPosixCntrl, param);
13403
13404     PL_PosixDigit       = sv_dup_inc(proto_perl->IPosixDigit, param);
13405
13406     PL_L1PosixGraph     = sv_dup_inc(proto_perl->IL1PosixGraph, param);
13407     PL_PosixGraph       = sv_dup_inc(proto_perl->IPosixGraph, param);
13408
13409     PL_HorizSpace       = sv_dup_inc(proto_perl->IHorizSpace, param);
13410
13411     PL_L1PosixLower     = sv_dup_inc(proto_perl->IL1PosixLower, param);
13412     PL_PosixLower       = sv_dup_inc(proto_perl->IPosixLower, param);
13413
13414     PL_L1PosixPrint     = sv_dup_inc(proto_perl->IL1PosixPrint, param);
13415     PL_PosixPrint       = sv_dup_inc(proto_perl->IPosixPrint, param);
13416
13417     PL_L1PosixPunct     = sv_dup_inc(proto_perl->IL1PosixPunct, param);
13418     PL_PosixPunct       = sv_dup_inc(proto_perl->IPosixPunct, param);
13419
13420     PL_PosixSpace       = sv_dup_inc(proto_perl->IPosixSpace, param);
13421     PL_XPosixSpace      = sv_dup_inc(proto_perl->IXPosixSpace, param);
13422
13423     PL_L1PosixUpper     = sv_dup_inc(proto_perl->IL1PosixUpper, param);
13424     PL_PosixUpper       = sv_dup_inc(proto_perl->IPosixUpper, param);
13425
13426     PL_L1PosixWord      = sv_dup_inc(proto_perl->IL1PosixWord, param);
13427     PL_PosixWord        = sv_dup_inc(proto_perl->IPosixWord, param);
13428
13429     PL_PosixXDigit      = sv_dup_inc(proto_perl->IPosixXDigit, param);
13430     PL_XPosixXDigit     = sv_dup_inc(proto_perl->IXPosixXDigit, param);
13431
13432     PL_VertSpace        = sv_dup_inc(proto_perl->IVertSpace, param);
13433
13434     /* utf8 character class swashes */
13435     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
13436     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
13437     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
13438     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
13439     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
13440     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
13441     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
13442     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
13443     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
13444     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
13445     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
13446     PL_utf8_X_begin     = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
13447     PL_utf8_X_extend    = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13448     PL_utf8_X_prepend   = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
13449     PL_utf8_X_non_hangul        = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
13450     PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
13451     PL_utf8_X_LV        = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
13452     PL_utf8_X_LVT       = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
13453     PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
13454     PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
13455     PL_utf8_X_LV_LVT_V  = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
13456     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13457     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13458     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13459     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13460     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13461     PL_utf8_xidstart    = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
13462     PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
13463     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13464     PL_utf8_xidcont     = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
13465     PL_utf8_foldable    = sv_dup_inc(proto_perl->Iutf8_foldable, param);
13466     PL_ASCII            = sv_dup_inc(proto_perl->IASCII, param);
13467     PL_AboveLatin1      = sv_dup_inc(proto_perl->IAboveLatin1, param);
13468     PL_Latin1           = sv_dup_inc(proto_perl->ILatin1, param);
13469
13470
13471     if (proto_perl->Ipsig_pend) {
13472         Newxz(PL_psig_pend, SIG_SIZE, int);
13473     }
13474     else {
13475         PL_psig_pend    = (int*)NULL;
13476     }
13477
13478     if (proto_perl->Ipsig_name) {
13479         Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13480         sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13481                             param);
13482         PL_psig_ptr = PL_psig_name + SIG_SIZE;
13483     }
13484     else {
13485         PL_psig_ptr     = (SV**)NULL;
13486         PL_psig_name    = (SV**)NULL;
13487     }
13488
13489     if (flags & CLONEf_COPY_STACKS) {
13490         Newx(PL_tmps_stack, PL_tmps_max, SV*);
13491         sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13492                             PL_tmps_ix+1, param);
13493
13494         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13495         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13496         Newxz(PL_markstack, i, I32);
13497         PL_markstack_max        = PL_markstack + (proto_perl->Imarkstack_max
13498                                                   - proto_perl->Imarkstack);
13499         PL_markstack_ptr        = PL_markstack + (proto_perl->Imarkstack_ptr
13500                                                   - proto_perl->Imarkstack);
13501         Copy(proto_perl->Imarkstack, PL_markstack,
13502              PL_markstack_ptr - PL_markstack + 1, I32);
13503
13504         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13505          * NOTE: unlike the others! */
13506         Newxz(PL_scopestack, PL_scopestack_max, I32);
13507         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13508
13509 #ifdef DEBUGGING
13510         Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13511         Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13512 #endif
13513         /* NOTE: si_dup() looks at PL_markstack */
13514         PL_curstackinfo         = si_dup(proto_perl->Icurstackinfo, param);
13515
13516         /* PL_curstack          = PL_curstackinfo->si_stack; */
13517         PL_curstack             = av_dup(proto_perl->Icurstack, param);
13518         PL_mainstack            = av_dup(proto_perl->Imainstack, param);
13519
13520         /* next PUSHs() etc. set *(PL_stack_sp+1) */
13521         PL_stack_base           = AvARRAY(PL_curstack);
13522         PL_stack_sp             = PL_stack_base + (proto_perl->Istack_sp
13523                                                    - proto_perl->Istack_base);
13524         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
13525
13526         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13527         PL_savestack            = ss_dup(proto_perl, param);
13528     }
13529     else {
13530         init_stacks();
13531         ENTER;                  /* perl_destruct() wants to LEAVE; */
13532     }
13533
13534     PL_statgv           = gv_dup(proto_perl->Istatgv, param);
13535     PL_statname         = sv_dup_inc(proto_perl->Istatname, param);
13536
13537     PL_rs               = sv_dup_inc(proto_perl->Irs, param);
13538     PL_last_in_gv       = gv_dup(proto_perl->Ilast_in_gv, param);
13539     PL_defoutgv         = gv_dup_inc(proto_perl->Idefoutgv, param);
13540     PL_toptarget        = sv_dup_inc(proto_perl->Itoptarget, param);
13541     PL_bodytarget       = sv_dup_inc(proto_perl->Ibodytarget, param);
13542     PL_formtarget       = sv_dup(proto_perl->Iformtarget, param);
13543
13544     PL_errors           = sv_dup_inc(proto_perl->Ierrors, param);
13545
13546     PL_sortcop          = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13547     PL_sortstash        = hv_dup(proto_perl->Isortstash, param);
13548     PL_firstgv          = gv_dup(proto_perl->Ifirstgv, param);
13549     PL_secondgv         = gv_dup(proto_perl->Isecondgv, param);
13550
13551     PL_stashcache       = newHV();
13552
13553     PL_watchaddr        = (char **) ptr_table_fetch(PL_ptr_table,
13554                                             proto_perl->Iwatchaddr);
13555     PL_watchok          = PL_watchaddr ? * PL_watchaddr : NULL;
13556     if (PL_debug && PL_watchaddr) {
13557         PerlIO_printf(Perl_debug_log,
13558           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13559           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13560           PTR2UV(PL_watchok));
13561     }
13562
13563     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
13564     PL_blockhooks       = av_dup_inc(proto_perl->Iblockhooks, param);
13565     PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13566
13567     /* Call the ->CLONE method, if it exists, for each of the stashes
13568        identified by sv_dup() above.
13569     */
13570     while(av_len(param->stashes) != -1) {
13571         HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13572         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13573         if (cloner && GvCV(cloner)) {
13574             dSP;
13575             ENTER;
13576             SAVETMPS;
13577             PUSHMARK(SP);
13578             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13579             PUTBACK;
13580             call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13581             FREETMPS;
13582             LEAVE;
13583         }
13584     }
13585
13586     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13587         ptr_table_free(PL_ptr_table);
13588         PL_ptr_table = NULL;
13589     }
13590
13591     if (!(flags & CLONEf_COPY_STACKS)) {
13592         unreferenced_to_tmp_stack(param->unreferenced);
13593     }
13594
13595     SvREFCNT_dec(param->stashes);
13596
13597     /* orphaned? eg threads->new inside BEGIN or use */
13598     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13599         SvREFCNT_inc_simple_void(PL_compcv);
13600         SAVEFREESV(PL_compcv);
13601     }
13602
13603     return my_perl;
13604 }
13605
13606 static void
13607 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13608 {
13609     PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13610
13611     if (AvFILLp(unreferenced) > -1) {
13612         SV **svp = AvARRAY(unreferenced);
13613         SV **const last = svp + AvFILLp(unreferenced);
13614         SSize_t count = 0;
13615
13616         do {
13617             if (SvREFCNT(*svp) == 1)
13618                 ++count;
13619         } while (++svp <= last);
13620
13621         EXTEND_MORTAL(count);
13622         svp = AvARRAY(unreferenced);
13623
13624         do {
13625             if (SvREFCNT(*svp) == 1) {
13626                 /* Our reference is the only one to this SV. This means that
13627                    in this thread, the scalar effectively has a 0 reference.
13628                    That doesn't work (cleanup never happens), so donate our
13629                    reference to it onto the save stack. */
13630                 PL_tmps_stack[++PL_tmps_ix] = *svp;
13631             } else {
13632                 /* As an optimisation, because we are already walking the
13633                    entire array, instead of above doing either
13634                    SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13635                    release our reference to the scalar, so that at the end of
13636                    the array owns zero references to the scalars it happens to
13637                    point to. We are effectively converting the array from
13638                    AvREAL() on to AvREAL() off. This saves the av_clear()
13639                    (triggered by the SvREFCNT_dec(unreferenced) below) from
13640                    walking the array a second time.  */
13641                 SvREFCNT_dec(*svp);
13642             }
13643
13644         } while (++svp <= last);
13645         AvREAL_off(unreferenced);
13646     }
13647     SvREFCNT_dec(unreferenced);
13648 }
13649
13650 void
13651 Perl_clone_params_del(CLONE_PARAMS *param)
13652 {
13653     /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13654        happy: */
13655     PerlInterpreter *const to = param->new_perl;
13656     dTHXa(to);
13657     PerlInterpreter *const was = PERL_GET_THX;
13658
13659     PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13660
13661     if (was != to) {
13662         PERL_SET_THX(to);
13663     }
13664
13665     SvREFCNT_dec(param->stashes);
13666     if (param->unreferenced)
13667         unreferenced_to_tmp_stack(param->unreferenced);
13668
13669     Safefree(param);
13670
13671     if (was != to) {
13672         PERL_SET_THX(was);
13673     }
13674 }
13675
13676 CLONE_PARAMS *
13677 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13678 {
13679     dVAR;
13680     /* Need to play this game, as newAV() can call safesysmalloc(), and that
13681        does a dTHX; to get the context from thread local storage.
13682        FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13683        a version that passes in my_perl.  */
13684     PerlInterpreter *const was = PERL_GET_THX;
13685     CLONE_PARAMS *param;
13686
13687     PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13688
13689     if (was != to) {
13690         PERL_SET_THX(to);
13691     }
13692
13693     /* Given that we've set the context, we can do this unshared.  */
13694     Newx(param, 1, CLONE_PARAMS);
13695
13696     param->flags = 0;
13697     param->proto_perl = from;
13698     param->new_perl = to;
13699     param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13700     AvREAL_off(param->stashes);
13701     param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13702
13703     if (was != to) {
13704         PERL_SET_THX(was);
13705     }
13706     return param;
13707 }
13708
13709 #endif /* USE_ITHREADS */
13710
13711 /*
13712 =head1 Unicode Support
13713
13714 =for apidoc sv_recode_to_utf8
13715
13716 The encoding is assumed to be an Encode object, on entry the PV
13717 of the sv is assumed to be octets in that encoding, and the sv
13718 will be converted into Unicode (and UTF-8).
13719
13720 If the sv already is UTF-8 (or if it is not POK), or if the encoding
13721 is not a reference, nothing is done to the sv.  If the encoding is not
13722 an C<Encode::XS> Encoding object, bad things will happen.
13723 (See F<lib/encoding.pm> and L<Encode>.)
13724
13725 The PV of the sv is returned.
13726
13727 =cut */
13728
13729 char *
13730 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
13731 {
13732     dVAR;
13733
13734     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
13735
13736     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
13737         SV *uni;
13738         STRLEN len;
13739         const char *s;
13740         dSP;
13741         ENTER;
13742         SAVETMPS;
13743         save_re_context();
13744         PUSHMARK(sp);
13745         EXTEND(SP, 3);
13746         XPUSHs(encoding);
13747         XPUSHs(sv);
13748 /*
13749   NI-S 2002/07/09
13750   Passing sv_yes is wrong - it needs to be or'ed set of constants
13751   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
13752   remove converted chars from source.
13753
13754   Both will default the value - let them.
13755
13756         XPUSHs(&PL_sv_yes);
13757 */
13758         PUTBACK;
13759         call_method("decode", G_SCALAR);
13760         SPAGAIN;
13761         uni = POPs;
13762         PUTBACK;
13763         s = SvPV_const(uni, len);
13764         if (s != SvPVX_const(sv)) {
13765             SvGROW(sv, len + 1);
13766             Move(s, SvPVX(sv), len + 1, char);
13767             SvCUR_set(sv, len);
13768         }
13769         FREETMPS;
13770         LEAVE;
13771         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
13772             /* clear pos and any utf8 cache */
13773             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
13774             if (mg)
13775                 mg->mg_len = -1;
13776             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
13777                 magic_setutf8(sv,mg); /* clear UTF8 cache */
13778         }
13779         SvUTF8_on(sv);
13780         return SvPVX(sv);
13781     }
13782     return SvPOKp(sv) ? SvPVX(sv) : NULL;
13783 }
13784
13785 /*
13786 =for apidoc sv_cat_decode
13787
13788 The encoding is assumed to be an Encode object, the PV of the ssv is
13789 assumed to be octets in that encoding and decoding the input starts
13790 from the position which (PV + *offset) pointed to.  The dsv will be
13791 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
13792 when the string tstr appears in decoding output or the input ends on
13793 the PV of the ssv.  The value which the offset points will be modified
13794 to the last input position on the ssv.
13795
13796 Returns TRUE if the terminator was found, else returns FALSE.
13797
13798 =cut */
13799
13800 bool
13801 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13802                    SV *ssv, int *offset, char *tstr, int tlen)
13803 {
13804     dVAR;
13805     bool ret = FALSE;
13806
13807     PERL_ARGS_ASSERT_SV_CAT_DECODE;
13808
13809     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13810         SV *offsv;
13811         dSP;
13812         ENTER;
13813         SAVETMPS;
13814         save_re_context();
13815         PUSHMARK(sp);
13816         EXTEND(SP, 6);
13817         XPUSHs(encoding);
13818         XPUSHs(dsv);
13819         XPUSHs(ssv);
13820         offsv = newSViv(*offset);
13821         mXPUSHs(offsv);
13822         mXPUSHp(tstr, tlen);
13823         PUTBACK;
13824         call_method("cat_decode", G_SCALAR);
13825         SPAGAIN;
13826         ret = SvTRUE(TOPs);
13827         *offset = SvIV(offsv);
13828         PUTBACK;
13829         FREETMPS;
13830         LEAVE;
13831     }
13832     else
13833         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13834     return ret;
13835
13836 }
13837
13838 /* ---------------------------------------------------------------------
13839  *
13840  * support functions for report_uninit()
13841  */
13842
13843 /* the maxiumum size of array or hash where we will scan looking
13844  * for the undefined element that triggered the warning */
13845
13846 #define FUV_MAX_SEARCH_SIZE 1000
13847
13848 /* Look for an entry in the hash whose value has the same SV as val;
13849  * If so, return a mortal copy of the key. */
13850
13851 STATIC SV*
13852 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13853 {
13854     dVAR;
13855     register HE **array;
13856     I32 i;
13857
13858     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13859
13860     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13861                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13862         return NULL;
13863
13864     array = HvARRAY(hv);
13865
13866     for (i=HvMAX(hv); i>0; i--) {
13867         register HE *entry;
13868         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13869             if (HeVAL(entry) != val)
13870                 continue;
13871             if (    HeVAL(entry) == &PL_sv_undef ||
13872                     HeVAL(entry) == &PL_sv_placeholder)
13873                 continue;
13874             if (!HeKEY(entry))
13875                 return NULL;
13876             if (HeKLEN(entry) == HEf_SVKEY)
13877                 return sv_mortalcopy(HeKEY_sv(entry));
13878             return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13879         }
13880     }
13881     return NULL;
13882 }
13883
13884 /* Look for an entry in the array whose value has the same SV as val;
13885  * If so, return the index, otherwise return -1. */
13886
13887 STATIC I32
13888 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13889 {
13890     dVAR;
13891
13892     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13893
13894     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13895                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13896         return -1;
13897
13898     if (val != &PL_sv_undef) {
13899         SV ** const svp = AvARRAY(av);
13900         I32 i;
13901
13902         for (i=AvFILLp(av); i>=0; i--)
13903             if (svp[i] == val)
13904                 return i;
13905     }
13906     return -1;
13907 }
13908
13909 /* S_varname(): return the name of a variable, optionally with a subscript.
13910  * If gv is non-zero, use the name of that global, along with gvtype (one
13911  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13912  * targ.  Depending on the value of the subscript_type flag, return:
13913  */
13914
13915 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
13916 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
13917 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
13918 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
13919
13920 SV*
13921 Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13922         const SV *const keyname, I32 aindex, int subscript_type)
13923 {
13924
13925     SV * const name = sv_newmortal();
13926     if (gv && isGV(gv)) {
13927         char buffer[2];
13928         buffer[0] = gvtype;
13929         buffer[1] = 0;
13930
13931         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
13932
13933         gv_fullname4(name, gv, buffer, 0);
13934
13935         if ((unsigned int)SvPVX(name)[1] <= 26) {
13936             buffer[0] = '^';
13937             buffer[1] = SvPVX(name)[1] + 'A' - 1;
13938
13939             /* Swap the 1 unprintable control character for the 2 byte pretty
13940                version - ie substr($name, 1, 1) = $buffer; */
13941             sv_insert(name, 1, 1, buffer, 2);
13942         }
13943     }
13944     else {
13945         CV * const cv = gv ? (CV *)gv : find_runcv(NULL);
13946         SV *sv;
13947         AV *av;
13948
13949         assert(!cv || SvTYPE(cv) == SVt_PVCV);
13950
13951         if (!cv || !CvPADLIST(cv))
13952             return NULL;
13953         av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13954         sv = *av_fetch(av, targ, FALSE);
13955         sv_setsv(name, sv);
13956     }
13957
13958     if (subscript_type == FUV_SUBSCRIPT_HASH) {
13959         SV * const sv = newSV(0);
13960         *SvPVX(name) = '$';
13961         Perl_sv_catpvf(aTHX_ name, "{%s}",
13962             pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
13963                     PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
13964         SvREFCNT_dec(sv);
13965     }
13966     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13967         *SvPVX(name) = '$';
13968         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13969     }
13970     else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13971         /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13972         Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
13973     }
13974
13975     return name;
13976 }
13977
13978
13979 /*
13980 =for apidoc find_uninit_var
13981
13982 Find the name of the undefined variable (if any) that caused the operator
13983 to issue a "Use of uninitialized value" warning.
13984 If match is true, only return a name if its value matches uninit_sv.
13985 So roughly speaking, if a unary operator (such as OP_COS) generates a
13986 warning, then following the direct child of the op may yield an
13987 OP_PADSV or OP_GV that gives the name of the undefined variable.  On the
13988 other hand, with OP_ADD there are two branches to follow, so we only print
13989 the variable name if we get an exact match.
13990
13991 The name is returned as a mortal SV.
13992
13993 Assumes that PL_op is the op that originally triggered the error, and that
13994 PL_comppad/PL_curpad points to the currently executing pad.
13995
13996 =cut
13997 */
13998
13999 STATIC SV *
14000 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
14001                   bool match)
14002 {
14003     dVAR;
14004     SV *sv;
14005     const GV *gv;
14006     const OP *o, *o2, *kid;
14007
14008     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
14009                             uninit_sv == &PL_sv_placeholder)))
14010         return NULL;
14011
14012     switch (obase->op_type) {
14013
14014     case OP_RV2AV:
14015     case OP_RV2HV:
14016     case OP_PADAV:
14017     case OP_PADHV:
14018       {
14019         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
14020         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
14021         I32 index = 0;
14022         SV *keysv = NULL;
14023         int subscript_type = FUV_SUBSCRIPT_WITHIN;
14024
14025         if (pad) { /* @lex, %lex */
14026             sv = PAD_SVl(obase->op_targ);
14027             gv = NULL;
14028         }
14029         else {
14030             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14031             /* @global, %global */
14032                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14033                 if (!gv)
14034                     break;
14035                 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
14036             }
14037             else if (obase == PL_op) /* @{expr}, %{expr} */
14038                 return find_uninit_var(cUNOPx(obase)->op_first,
14039                                                     uninit_sv, match);
14040             else /* @{expr}, %{expr} as a sub-expression */
14041                 return NULL;
14042         }
14043
14044         /* attempt to find a match within the aggregate */
14045         if (hash) {
14046             keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14047             if (keysv)
14048                 subscript_type = FUV_SUBSCRIPT_HASH;
14049         }
14050         else {
14051             index = find_array_subscript((const AV *)sv, uninit_sv);
14052             if (index >= 0)
14053                 subscript_type = FUV_SUBSCRIPT_ARRAY;
14054         }
14055
14056         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
14057             break;
14058
14059         return varname(gv, hash ? '%' : '@', obase->op_targ,
14060                                     keysv, index, subscript_type);
14061       }
14062
14063     case OP_RV2SV:
14064         if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14065             /* $global */
14066             gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14067             if (!gv || !GvSTASH(gv))
14068                 break;
14069             if (match && (GvSV(gv) != uninit_sv))
14070                 break;
14071             return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14072         }
14073         /* ${expr} */
14074         return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
14075
14076     case OP_PADSV:
14077         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
14078             break;
14079         return varname(NULL, '$', obase->op_targ,
14080                                     NULL, 0, FUV_SUBSCRIPT_NONE);
14081
14082     case OP_GVSV:
14083         gv = cGVOPx_gv(obase);
14084         if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
14085             break;
14086         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14087
14088     case OP_AELEMFAST_LEX:
14089         if (match) {
14090             SV **svp;
14091             AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
14092             if (!av || SvRMAGICAL(av))
14093                 break;
14094             svp = av_fetch(av, (I32)obase->op_private, FALSE);
14095             if (!svp || *svp != uninit_sv)
14096                 break;
14097         }
14098         return varname(NULL, '$', obase->op_targ,
14099                        NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14100     case OP_AELEMFAST:
14101         {
14102             gv = cGVOPx_gv(obase);
14103             if (!gv)
14104                 break;
14105             if (match) {
14106                 SV **svp;
14107                 AV *const av = GvAV(gv);
14108                 if (!av || SvRMAGICAL(av))
14109                     break;
14110                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
14111                 if (!svp || *svp != uninit_sv)
14112                     break;
14113             }
14114             return varname(gv, '$', 0,
14115                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14116         }
14117         break;
14118
14119     case OP_EXISTS:
14120         o = cUNOPx(obase)->op_first;
14121         if (!o || o->op_type != OP_NULL ||
14122                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
14123             break;
14124         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
14125
14126     case OP_AELEM:
14127     case OP_HELEM:
14128     {
14129         bool negate = FALSE;
14130
14131         if (PL_op == obase)
14132             /* $a[uninit_expr] or $h{uninit_expr} */
14133             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
14134
14135         gv = NULL;
14136         o = cBINOPx(obase)->op_first;
14137         kid = cBINOPx(obase)->op_last;
14138
14139         /* get the av or hv, and optionally the gv */
14140         sv = NULL;
14141         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
14142             sv = PAD_SV(o->op_targ);
14143         }
14144         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
14145                 && cUNOPo->op_first->op_type == OP_GV)
14146         {
14147             gv = cGVOPx_gv(cUNOPo->op_first);
14148             if (!gv)
14149                 break;
14150             sv = o->op_type
14151                 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
14152         }
14153         if (!sv)
14154             break;
14155
14156         if (kid && kid->op_type == OP_NEGATE) {
14157             negate = TRUE;
14158             kid = cUNOPx(kid)->op_first;
14159         }
14160
14161         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
14162             /* index is constant */
14163             SV* kidsv;
14164             if (negate) {
14165                 kidsv = sv_2mortal(newSVpvs("-"));
14166                 sv_catsv(kidsv, cSVOPx_sv(kid));
14167             }
14168             else
14169                 kidsv = cSVOPx_sv(kid);
14170             if (match) {
14171                 if (SvMAGICAL(sv))
14172                     break;
14173                 if (obase->op_type == OP_HELEM) {
14174                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
14175                     if (!he || HeVAL(he) != uninit_sv)
14176                         break;
14177                 }
14178                 else {
14179                     SV * const * const svp = av_fetch(MUTABLE_AV(sv),
14180                         negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
14181                         FALSE);
14182                     if (!svp || *svp != uninit_sv)
14183                         break;
14184                 }
14185             }
14186             if (obase->op_type == OP_HELEM)
14187                 return varname(gv, '%', o->op_targ,
14188                             kidsv, 0, FUV_SUBSCRIPT_HASH);
14189             else
14190                 return varname(gv, '@', o->op_targ, NULL,
14191                     negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
14192                     FUV_SUBSCRIPT_ARRAY);
14193         }
14194         else  {
14195             /* index is an expression;
14196              * attempt to find a match within the aggregate */
14197             if (obase->op_type == OP_HELEM) {
14198                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14199                 if (keysv)
14200                     return varname(gv, '%', o->op_targ,
14201                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
14202             }
14203             else {
14204                 const I32 index
14205                     = find_array_subscript((const AV *)sv, uninit_sv);
14206                 if (index >= 0)
14207                     return varname(gv, '@', o->op_targ,
14208                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
14209             }
14210             if (match)
14211                 break;
14212             return varname(gv,
14213                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
14214                 ? '@' : '%',
14215                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
14216         }
14217         break;
14218     }
14219
14220     case OP_AASSIGN:
14221         /* only examine RHS */
14222         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
14223
14224     case OP_OPEN:
14225         o = cUNOPx(obase)->op_first;
14226         if (o->op_type == OP_PUSHMARK)
14227             o = o->op_sibling;
14228
14229         if (!o->op_sibling) {
14230             /* one-arg version of open is highly magical */
14231
14232             if (o->op_type == OP_GV) { /* open FOO; */
14233                 gv = cGVOPx_gv(o);
14234                 if (match && GvSV(gv) != uninit_sv)
14235                     break;
14236                 return varname(gv, '$', 0,
14237                             NULL, 0, FUV_SUBSCRIPT_NONE);
14238             }
14239             /* other possibilities not handled are:
14240              * open $x; or open my $x;  should return '${*$x}'
14241              * open expr;               should return '$'.expr ideally
14242              */
14243              break;
14244         }
14245         goto do_op;
14246
14247     /* ops where $_ may be an implicit arg */
14248     case OP_TRANS:
14249     case OP_TRANSR:
14250     case OP_SUBST:
14251     case OP_MATCH:
14252         if ( !(obase->op_flags & OPf_STACKED)) {
14253             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
14254                                  ? PAD_SVl(obase->op_targ)
14255                                  : DEFSV))
14256             {
14257                 sv = sv_newmortal();
14258                 sv_setpvs(sv, "$_");
14259                 return sv;
14260             }
14261         }
14262         goto do_op;
14263
14264     case OP_PRTF:
14265     case OP_PRINT:
14266     case OP_SAY:
14267         match = 1; /* print etc can return undef on defined args */
14268         /* skip filehandle as it can't produce 'undef' warning  */
14269         o = cUNOPx(obase)->op_first;
14270         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
14271             o = o->op_sibling->op_sibling;
14272         goto do_op2;
14273
14274
14275     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
14276     case OP_CUSTOM: /* XS or custom code could trigger random warnings */
14277
14278         /* the following ops are capable of returning PL_sv_undef even for
14279          * defined arg(s) */
14280
14281     case OP_BACKTICK:
14282     case OP_PIPE_OP:
14283     case OP_FILENO:
14284     case OP_BINMODE:
14285     case OP_TIED:
14286     case OP_GETC:
14287     case OP_SYSREAD:
14288     case OP_SEND:
14289     case OP_IOCTL:
14290     case OP_SOCKET:
14291     case OP_SOCKPAIR:
14292     case OP_BIND:
14293     case OP_CONNECT:
14294     case OP_LISTEN:
14295     case OP_ACCEPT:
14296     case OP_SHUTDOWN:
14297     case OP_SSOCKOPT:
14298     case OP_GETPEERNAME:
14299     case OP_FTRREAD:
14300     case OP_FTRWRITE:
14301     case OP_FTREXEC:
14302     case OP_FTROWNED:
14303     case OP_FTEREAD:
14304     case OP_FTEWRITE:
14305     case OP_FTEEXEC:
14306     case OP_FTEOWNED:
14307     case OP_FTIS:
14308     case OP_FTZERO:
14309     case OP_FTSIZE:
14310     case OP_FTFILE:
14311     case OP_FTDIR:
14312     case OP_FTLINK:
14313     case OP_FTPIPE:
14314     case OP_FTSOCK:
14315     case OP_FTBLK:
14316     case OP_FTCHR:
14317     case OP_FTTTY:
14318     case OP_FTSUID:
14319     case OP_FTSGID:
14320     case OP_FTSVTX:
14321     case OP_FTTEXT:
14322     case OP_FTBINARY:
14323     case OP_FTMTIME:
14324     case OP_FTATIME:
14325     case OP_FTCTIME:
14326     case OP_READLINK:
14327     case OP_OPEN_DIR:
14328     case OP_READDIR:
14329     case OP_TELLDIR:
14330     case OP_SEEKDIR:
14331     case OP_REWINDDIR:
14332     case OP_CLOSEDIR:
14333     case OP_GMTIME:
14334     case OP_ALARM:
14335     case OP_SEMGET:
14336     case OP_GETLOGIN:
14337     case OP_UNDEF:
14338     case OP_SUBSTR:
14339     case OP_AEACH:
14340     case OP_EACH:
14341     case OP_SORT:
14342     case OP_CALLER:
14343     case OP_DOFILE:
14344     case OP_PROTOTYPE:
14345     case OP_NCMP:
14346     case OP_SMARTMATCH:
14347     case OP_UNPACK:
14348     case OP_SYSOPEN:
14349     case OP_SYSSEEK:
14350         match = 1;
14351         goto do_op;
14352
14353     case OP_ENTERSUB:
14354     case OP_GOTO:
14355         /* XXX tmp hack: these two may call an XS sub, and currently
14356           XS subs don't have a SUB entry on the context stack, so CV and
14357           pad determination goes wrong, and BAD things happen. So, just
14358           don't try to determine the value under those circumstances.
14359           Need a better fix at dome point. DAPM 11/2007 */
14360         break;
14361
14362     case OP_FLIP:
14363     case OP_FLOP:
14364     {
14365         GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
14366         if (gv && GvSV(gv) == uninit_sv)
14367             return newSVpvs_flags("$.", SVs_TEMP);
14368         goto do_op;
14369     }
14370
14371     case OP_POS:
14372         /* def-ness of rval pos() is independent of the def-ness of its arg */
14373         if ( !(obase->op_flags & OPf_MOD))
14374             break;
14375
14376     case OP_SCHOMP:
14377     case OP_CHOMP:
14378         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
14379             return newSVpvs_flags("${$/}", SVs_TEMP);
14380         /*FALLTHROUGH*/
14381
14382     default:
14383     do_op:
14384         if (!(obase->op_flags & OPf_KIDS))
14385             break;
14386         o = cUNOPx(obase)->op_first;
14387
14388     do_op2:
14389         if (!o)
14390             break;
14391
14392         /* This loop checks all the kid ops, skipping any that cannot pos-
14393          * sibly be responsible for the uninitialized value; i.e., defined
14394          * constants and ops that return nothing.  If there is only one op
14395          * left that is not skipped, then we *know* it is responsible for
14396          * the uninitialized value.  If there is more than one op left, we
14397          * have to look for an exact match in the while() loop below.
14398          */
14399         o2 = NULL;
14400         for (kid=o; kid; kid = kid->op_sibling) {
14401             if (kid) {
14402                 const OPCODE type = kid->op_type;
14403                 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
14404                   || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
14405                   || (type == OP_PUSHMARK)
14406                 )
14407                 continue;
14408             }
14409             if (o2) { /* more than one found */
14410                 o2 = NULL;
14411                 break;
14412             }
14413             o2 = kid;
14414         }
14415         if (o2)
14416             return find_uninit_var(o2, uninit_sv, match);
14417
14418         /* scan all args */
14419         while (o) {
14420             sv = find_uninit_var(o, uninit_sv, 1);
14421             if (sv)
14422                 return sv;
14423             o = o->op_sibling;
14424         }
14425         break;
14426     }
14427     return NULL;
14428 }
14429
14430
14431 /*
14432 =for apidoc report_uninit
14433
14434 Print appropriate "Use of uninitialized variable" warning.
14435
14436 =cut
14437 */
14438
14439 void
14440 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14441 {
14442     dVAR;
14443     if (PL_op) {
14444         SV* varname = NULL;
14445         if (uninit_sv && PL_curpad) {
14446             varname = find_uninit_var(PL_op, uninit_sv,0);
14447             if (varname)
14448                 sv_insert(varname, 0, 0, " ", 1);
14449         }
14450         /* diag_listed_as: Use of uninitialized value%s */
14451         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
14452                 SVfARG(varname ? varname : &PL_sv_no),
14453                 " in ", OP_DESC(PL_op));
14454     }
14455     else
14456         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14457                     "", "", "");
14458 }
14459
14460 /*
14461  * Local variables:
14462  * c-indentation-style: bsd
14463  * c-basic-offset: 4
14464  * indent-tabs-mode: t
14465  * End:
14466  *
14467  * ex: set ts=8 sts=4 sw=4 noet:
14468  */