sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
   5  *    and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'I wonder what the Entish is for "yes" and "no",' he thought.
  14  *                                                      --Pippin
  15  *
  16  *     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
  17  */
  18
  19 /*
  20  *
  21  *
  22  * This file contains the code that creates, manipulates and destroys
  23  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
  24  * structure of an SV, so their creation and destruction is handled
  25  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
  26  * level functions (eg. substr, split, join) for each of the types are
  27  * in the pp*.c files.
  28  */
  29
  30 #include "EXTERN.h"
  31 #define PERL_IN_SV_C
  32 #include "perl.h"
  33 #include "regcomp.h"
  34
  35 #define FCALL *f
  36
  37 #ifdef __Lynx__
  38 /* Missing proto on LynxOS */
  39   char *gconvert(double, int, int,  char *);
  40 #endif
  41
  42 #ifdef PERL_UTF8_CACHE_ASSERT
  43 /* if adding more checks watch out for the following tests:
  44  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
  45  *   lib/utf8.t lib/Unicode/Collate/t/index.t
  46  * --jhi
  47  */
  48 #   define ASSERT_UTF8_CACHE(cache) \
  49     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
  50                               assert((cache)[2] <= (cache)[3]); \
  51                               assert((cache)[3] <= (cache)[1]);} \
  52                               } STMT_END
  53 #else
  54 #   define ASSERT_UTF8_CACHE(cache) NOOP
  55 #endif
  56
  57 #ifdef PERL_OLD_COPY_ON_WRITE
  58 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
  59 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
  60 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
  61    on-write.  */
  62 #endif
  63
  64 /* ============================================================================
  65
  66 =head1 Allocation and deallocation of SVs.
  67
  68 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
  69 sv, av, hv...) contains type and reference count information, and for
  70 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
  71 contains fields specific to each type.  Some types store all they need
  72 in the head, so don't have a body.
  73
  74 In all but the most memory-paranoid configuations (ex: PURIFY), heads
  75 and bodies are allocated out of arenas, which by default are
  76 approximately 4K chunks of memory parcelled up into N heads or bodies.
  77 Sv-bodies are allocated by their sv-type, guaranteeing size
  78 consistency needed to allocate safely from arrays.
  79
  80 For SV-heads, the first slot in each arena is reserved, and holds a
  81 link to the next arena, some flags, and a note of the number of slots.
  82 Snaked through each arena chain is a linked list of free items; when
  83 this becomes empty, an extra arena is allocated and divided up into N
  84 items which are threaded into the free list.
  85
  86 SV-bodies are similar, but they use arena-sets by default, which
  87 separate the link and info from the arena itself, and reclaim the 1st
  88 slot in the arena.  SV-bodies are further described later.
  89
  90 The following global variables are associated with arenas:
  91
  92     PL_sv_arenaroot     pointer to list of SV arenas
  93     PL_sv_root          pointer to list of free SV structures
  94
  95     PL_body_arenas      head of linked-list of body arenas
  96     PL_body_roots[]     array of pointers to list of free bodies of svtype
  97                         arrays are indexed by the svtype needed
  98
  99 A few special SV heads are not allocated from an arena, but are
 100 instead directly created in the interpreter structure, eg PL_sv_undef.
 101 The size of arenas can be changed from the default by setting
 102 PERL_ARENA_SIZE appropriately at compile time.
 103
 104 The SV arena serves the secondary purpose of allowing still-live SVs
 105 to be located and destroyed during final cleanup.
 106
 107 At the lowest level, the macros new_SV() and del_SV() grab and free
 108 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
 109 to return the SV to the free list with error checking.) new_SV() calls
 110 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
 111 SVs in the free list have their SvTYPE field set to all ones.
 112
 113 At the time of very final cleanup, sv_free_arenas() is called from
 114 perl_destruct() to physically free all the arenas allocated since the
 115 start of the interpreter.
 116
 117 The function visit() scans the SV arenas list, and calls a specified
 118 function for each SV it finds which is still live - ie which has an SvTYPE
 119 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
 120 following functions (specified as [function that calls visit()] / [function
 121 called by visit() for each SV]):
 122
 123     sv_report_used() / do_report_used()
 124                         dump all remaining SVs (debugging aid)
 125
 126     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
 127                         Attempt to free all objects pointed to by RVs,
 128                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
 129                         try to do the same for all objects indirectly
 130                         referenced by typeglobs too.  Called once from
 131                         perl_destruct(), prior to calling sv_clean_all()
 132                         below.
 133
 134     sv_clean_all() / do_clean_all()
 135                         SvREFCNT_dec(sv) each remaining SV, possibly
 136                         triggering an sv_free(). It also sets the
 137                         SVf_BREAK flag on the SV to indicate that the
 138                         refcnt has been artificially lowered, and thus
 139                         stopping sv_free() from giving spurious warnings
 140                         about SVs which unexpectedly have a refcnt
 141                         of zero.  called repeatedly from perl_destruct()
 142                         until there are no SVs left.
 143
 144 =head2 Arena allocator API Summary
 145
 146 Private API to rest of sv.c
 147
 148     new_SV(),  del_SV(),
 149
 150     new_XIV(), del_XIV(),
 151     new_XNV(), del_XNV(),
 152     etc
 153
 154 Public API:
 155
 156     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
 157
 158 =cut
 159
 160  * ========================================================================= */
 161
 162 /*
 163  * "A time to plant, and a time to uproot what was planted..."
 164  */
 165
 166 void
 167 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
 168 {
 169     dVAR;
 170     void *new_chunk;
 171     U32 new_chunk_size;
 172
 173     PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
 174
 175     new_chunk = (void *)(chunk);
 176     new_chunk_size = (chunk_size);
 177     if (new_chunk_size > PL_nice_chunk_size) {
 178         Safefree(PL_nice_chunk);
 179         PL_nice_chunk = (char *) new_chunk;
 180         PL_nice_chunk_size = new_chunk_size;
 181     } else {
 182         Safefree(chunk);
 183     }
 184 }
 185
 186 #ifdef PERL_MEM_LOG
 187 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
 188             Perl_mem_log_new_sv(sv, file, line, func)
 189 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
 190             Perl_mem_log_del_sv(sv, file, line, func)
 191 #else
 192 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
 193 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
 194 #endif
 195
 196 #ifdef DEBUG_LEAKING_SCALARS
 197 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
 198 #  define DEBUG_SV_SERIAL(sv)                                               \
 199     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
 200             PTR2UV(sv), (long)(sv)->sv_debug_serial))
 201 #else
 202 #  define FREE_SV_DEBUG_FILE(sv)
 203 #  define DEBUG_SV_SERIAL(sv)   NOOP
 204 #endif
 205
 206 #ifdef PERL_POISON
 207 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
 208 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = MUTABLE_SV((val))
 209 /* Whilst I'd love to do this, it seems that things like to check on
 210    unreferenced scalars
 211 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
 212 */
 213 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
 214                                 PoisonNew(&SvREFCNT(sv), 1, U32)
 215 #else
 216 #  define SvARENA_CHAIN(sv)     SvANY(sv)
 217 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
 218 #  define POSION_SV_HEAD(sv)
 219 #endif
 220
 221 /* Mark an SV head as unused, and add to free list.
 222  *
 223  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
 224  * its refcount artificially decremented during global destruction, so
 225  * there may be dangling pointers to it. The last thing we want in that
 226  * case is for it to be reused. */
 227
 228 #define plant_SV(p) \
 229     STMT_START {                                        \
 230         const U32 old_flags = SvFLAGS(p);                       \
 231         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 232         DEBUG_SV_SERIAL(p);                             \
 233         FREE_SV_DEBUG_FILE(p);                          \
 234         POSION_SV_HEAD(p);                              \
 235         SvFLAGS(p) = SVTYPEMASK;                        \
 236         if (!(old_flags & SVf_BREAK)) {         \
 237             SvARENA_CHAIN_SET(p, PL_sv_root);   \
 238             PL_sv_root = (p);                           \
 239         }                                               \
 240         --PL_sv_count;                                  \
 241     } STMT_END
 242
 243 #define uproot_SV(p) \
 244     STMT_START {                                        \
 245         (p) = PL_sv_root;                               \
 246         PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p));              \
 247         ++PL_sv_count;                                  \
 248     } STMT_END
 249
 250
 251 /* make some more SVs by adding another arena */
 252
 253 STATIC SV*
 254 S_more_sv(pTHX)
 255 {
 256     dVAR;
 257     SV* sv;
 258
 259     if (PL_nice_chunk) {
 260         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 261         PL_nice_chunk = NULL;
 262         PL_nice_chunk_size = 0;
 263     }
 264     else {
 265         char *chunk;                /* must use New here to match call to */
 266         Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
 267         sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
 268     }
 269     uproot_SV(sv);
 270     return sv;
 271 }
 272
 273 /* new_SV(): return a new, empty SV head */
 274
 275 #ifdef DEBUG_LEAKING_SCALARS
 276 /* provide a real function for a debugger to play with */
 277 STATIC SV*
 278 S_new_SV(pTHX_ const char *file, int line, const char *func)
 279 {
 280     SV* sv;
 281
 282     if (PL_sv_root)
 283         uproot_SV(sv);
 284     else
 285         sv = S_more_sv(aTHX);
 286     SvANY(sv) = 0;
 287     SvREFCNT(sv) = 1;
 288     SvFLAGS(sv) = 0;
 289     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
 290     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
 291                 ? PL_parser->copline
 292                 :  PL_curcop
 293                     ? CopLINE(PL_curcop)
 294                     : 0
 295             );
 296     sv->sv_debug_inpad = 0;
 297     sv->sv_debug_cloned = 0;
 298     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 299
 300     sv->sv_debug_serial = PL_sv_serial++;
 301
 302     MEM_LOG_NEW_SV(sv, file, line, func);
 303     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
 304             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
 305
 306     return sv;
 307 }
 308 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
 309
 310 #else
 311 #  define new_SV(p) \
 312     STMT_START {                                        \
 313         if (PL_sv_root)                                 \
 314             uproot_SV(p);                               \
 315         else                                            \
 316             (p) = S_more_sv(aTHX);                      \
 317         SvANY(p) = 0;                                   \
 318         SvREFCNT(p) = 1;                                \
 319         SvFLAGS(p) = 0;                                 \
 320         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 321     } STMT_END
 322 #endif
 323
 324
 325 /* del_SV(): return an empty SV head to the free list */
 326
 327 #ifdef DEBUGGING
 328
 329 #define del_SV(p) \
 330     STMT_START {                                        \
 331         if (DEBUG_D_TEST)                               \
 332             del_sv(p);                                  \
 333         else                                            \
 334             plant_SV(p);                                \
 335     } STMT_END
 336
 337 STATIC void
 338 S_del_sv(pTHX_ SV *p)
 339 {
 340     dVAR;
 341
 342     PERL_ARGS_ASSERT_DEL_SV;
 343
 344     if (DEBUG_D_TEST) {
 345         SV* sva;
 346         bool ok = 0;
 347         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 348             const SV * const sv = sva + 1;
 349             const SV * const svend = &sva[SvREFCNT(sva)];
 350             if (p >= sv && p < svend) {
 351                 ok = 1;
 352                 break;
 353             }
 354         }
 355         if (!ok) {
 356             if (ckWARN_d(WARN_INTERNAL))
 357                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 358                             "Attempt to free non-arena SV: 0x%"UVxf
 359                             pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
 360             return;
 361         }
 362     }
 363     plant_SV(p);
 364 }
 365
 366 #else /* ! DEBUGGING */
 367
 368 #define del_SV(p)   plant_SV(p)
 369
 370 #endif /* DEBUGGING */
 371
 372
 373 /*
 374 =head1 SV Manipulation Functions
 375
 376 =for apidoc sv_add_arena
 377
 378 Given a chunk of memory, link it to the head of the list of arenas,
 379 and split it into a list of free SVs.
 380
 381 =cut
 382 */
 383
 384 static void
 385 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
 386 {
 387     dVAR;
 388     SV *const sva = MUTABLE_SV(ptr);
 389     register SV* sv;
 390     register SV* svend;
 391
 392     PERL_ARGS_ASSERT_SV_ADD_ARENA;
 393
 394     /* The first SV in an arena isn't an SV. */
 395     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 396     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 397     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 398
 399     PL_sv_arenaroot = sva;
 400     PL_sv_root = sva + 1;
 401
 402     svend = &sva[SvREFCNT(sva) - 1];
 403     sv = sva + 1;
 404     while (sv < svend) {
 405         SvARENA_CHAIN_SET(sv, (sv + 1));
 406 #ifdef DEBUGGING
 407         SvREFCNT(sv) = 0;
 408 #endif
 409         /* Must always set typemask because it's always checked in on cleanup
 410            when the arenas are walked looking for objects.  */
 411         SvFLAGS(sv) = SVTYPEMASK;
 412         sv++;
 413     }
 414     SvARENA_CHAIN_SET(sv, 0);
 415 #ifdef DEBUGGING
 416     SvREFCNT(sv) = 0;
 417 #endif
 418     SvFLAGS(sv) = SVTYPEMASK;
 419 }
 420
 421 /* visit(): call the named function for each non-free SV in the arenas
 422  * whose flags field matches the flags/mask args. */
 423
 424 STATIC I32
 425 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
 426 {
 427     dVAR;
 428     SV* sva;
 429     I32 visited = 0;
 430
 431     PERL_ARGS_ASSERT_VISIT;
 432
 433     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 434         register const SV * const svend = &sva[SvREFCNT(sva)];
 435         register SV* sv;
 436         for (sv = sva + 1; sv < svend; ++sv) {
 437             if (SvTYPE(sv) != SVTYPEMASK
 438                     && (sv->sv_flags & mask) == flags
 439                     && SvREFCNT(sv))
 440             {
 441                 (FCALL)(aTHX_ sv);
 442                 ++visited;
 443             }
 444         }
 445     }
 446     return visited;
 447 }
 448
 449 #ifdef DEBUGGING
 450
 451 /* called by sv_report_used() for each live SV */
 452
 453 static void
 454 do_report_used(pTHX_ SV *const sv)
 455 {
 456     if (SvTYPE(sv) != SVTYPEMASK) {
 457         PerlIO_printf(Perl_debug_log, "****\n");
 458         sv_dump(sv);
 459     }
 460 }
 461 #endif
 462
 463 /*
 464 =for apidoc sv_report_used
 465
 466 Dump the contents of all SVs not yet freed. (Debugging aid).
 467
 468 =cut
 469 */
 470
 471 void
 472 Perl_sv_report_used(pTHX)
 473 {
 474 #ifdef DEBUGGING
 475     visit(do_report_used, 0, 0);
 476 #else
 477     PERL_UNUSED_CONTEXT;
 478 #endif
 479 }
 480
 481 /* called by sv_clean_objs() for each live SV */
 482
 483 static void
 484 do_clean_objs(pTHX_ SV *const ref)
 485 {
 486     dVAR;
 487     assert (SvROK(ref));
 488     {
 489         SV * const target = SvRV(ref);
 490         if (SvOBJECT(target)) {
 491             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
 492             if (SvWEAKREF(ref)) {
 493                 sv_del_backref(target, ref);
 494                 SvWEAKREF_off(ref);
 495                 SvRV_set(ref, NULL);
 496             } else {
 497                 SvROK_off(ref);
 498                 SvRV_set(ref, NULL);
 499                 SvREFCNT_dec(target);
 500             }
 501         }
 502     }
 503
 504     /* XXX Might want to check arrays, etc. */
 505 }
 506
 507 /* called by sv_clean_objs() for each live SV */
 508
 509 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 510 static void
 511 do_clean_named_objs(pTHX_ SV *const sv)
 512 {
 513     dVAR;
 514     assert(SvTYPE(sv) == SVt_PVGV);
 515     assert(isGV_with_GP(sv));
 516     if (GvGP(sv)) {
 517         if ((
 518 #ifdef PERL_DONT_CREATE_GVSV
 519              GvSV(sv) &&
 520 #endif
 521              SvOBJECT(GvSV(sv))) ||
 522              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
 523              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
 524              /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
 525              (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
 526              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
 527         {
 528             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
 529             SvFLAGS(sv) |= SVf_BREAK;
 530             SvREFCNT_dec(sv);
 531         }
 532     }
 533 }
 534 #endif
 535
 536 /*
 537 =for apidoc sv_clean_objs
 538
 539 Attempt to destroy all objects not yet freed
 540
 541 =cut
 542 */
 543
 544 void
 545 Perl_sv_clean_objs(pTHX)
 546 {
 547     dVAR;
 548     PL_in_clean_objs = TRUE;
 549     visit(do_clean_objs, SVf_ROK, SVf_ROK);
 550 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 551     /* some barnacles may yet remain, clinging to typeglobs */
 552     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
 553 #endif
 554     PL_in_clean_objs = FALSE;
 555 }
 556
 557 /* called by sv_clean_all() for each live SV */
 558
 559 static void
 560 do_clean_all(pTHX_ SV *const sv)
 561 {
 562     dVAR;
 563     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
 564         /* don't clean pid table and strtab */
 565         return;
 566     }
 567     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
 568     SvFLAGS(sv) |= SVf_BREAK;
 569     SvREFCNT_dec(sv);
 570 }
 571
 572 /*
 573 =for apidoc sv_clean_all
 574
 575 Decrement the refcnt of each remaining SV, possibly triggering a
 576 cleanup. This function may have to be called multiple times to free
 577 SVs which are in complex self-referential hierarchies.
 578
 579 =cut
 580 */
 581
 582 I32
 583 Perl_sv_clean_all(pTHX)
 584 {
 585     dVAR;
 586     I32 cleaned;
 587     PL_in_clean_all = TRUE;
 588     cleaned = visit(do_clean_all, 0,0);
 589     PL_in_clean_all = FALSE;
 590     return cleaned;
 591 }
 592
 593 /*
 594   ARENASETS: a meta-arena implementation which separates arena-info
 595   into struct arena_set, which contains an array of struct
 596   arena_descs, each holding info for a single arena.  By separating
 597   the meta-info from the arena, we recover the 1st slot, formerly
 598   borrowed for list management.  The arena_set is about the size of an
 599   arena, avoiding the needless malloc overhead of a naive linked-list.
 600
 601   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
 602   memory in the last arena-set (1/2 on average).  In trade, we get
 603   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
 604   smaller types).  The recovery of the wasted space allows use of
 605   small arenas for large, rare body types, by changing array* fields
 606   in body_details_by_type[] below.
 607 */
 608 struct arena_desc {
 609     char       *arena;          /* the raw storage, allocated aligned */
 610     size_t      size;           /* its size ~4k typ */
 611     U32         misc;           /* type, and in future other things. */
 612 };
 613
 614 struct arena_set;
 615
 616 /* Get the maximum number of elements in set[] such that struct arena_set
 617    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
 618    therefore likely to be 1 aligned memory page.  */
 619
 620 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
 621                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
 622
 623 struct arena_set {
 624     struct arena_set* next;
 625     unsigned int   set_size;    /* ie ARENAS_PER_SET */
 626     unsigned int   curr;        /* index of next available arena-desc */
 627     struct arena_desc set[ARENAS_PER_SET];
 628 };
 629
 630 /*
 631 =for apidoc sv_free_arenas
 632
 633 Deallocate the memory used by all arenas. Note that all the individual SV
 634 heads and bodies within the arenas must already have been freed.
 635
 636 =cut
 637 */
 638 void
 639 Perl_sv_free_arenas(pTHX)
 640 {
 641     dVAR;
 642     SV* sva;
 643     SV* svanext;
 644     unsigned int i;
 645
 646     /* Free arenas here, but be careful about fake ones.  (We assume
 647        contiguity of the fake ones with the corresponding real ones.) */
 648
 649     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 650         svanext = MUTABLE_SV(SvANY(sva));
 651         while (svanext && SvFAKE(svanext))
 652             svanext = MUTABLE_SV(SvANY(svanext));
 653
 654         if (!SvFAKE(sva))
 655             Safefree(sva);
 656     }
 657
 658     {
 659         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 660
 661         while (aroot) {
 662             struct arena_set *current = aroot;
 663             i = aroot->curr;
 664             while (i--) {
 665                 assert(aroot->set[i].arena);
 666                 Safefree(aroot->set[i].arena);
 667             }
 668             aroot = aroot->next;
 669             Safefree(current);
 670         }
 671     }
 672     PL_body_arenas = 0;
 673
 674     i = PERL_ARENA_ROOTS_SIZE;
 675     while (i--)
 676         PL_body_roots[i] = 0;
 677
 678     Safefree(PL_nice_chunk);
 679     PL_nice_chunk = NULL;
 680     PL_nice_chunk_size = 0;
 681     PL_sv_arenaroot = 0;
 682     PL_sv_root = 0;
 683 }
 684
 685 /*
 686   Here are mid-level routines that manage the allocation of bodies out
 687   of the various arenas.  There are 5 kinds of arenas:
 688
 689   1. SV-head arenas, which are discussed and handled above
 690   2. regular body arenas
 691   3. arenas for reduced-size bodies
 692   4. Hash-Entry arenas
 693   5. pte arenas (thread related)
 694
 695   Arena types 2 & 3 are chained by body-type off an array of
 696   arena-root pointers, which is indexed by svtype.  Some of the
 697   larger/less used body types are malloced singly, since a large
 698   unused block of them is wasteful.  Also, several svtypes dont have
 699   bodies; the data fits into the sv-head itself.  The arena-root
 700   pointer thus has a few unused root-pointers (which may be hijacked
 701   later for arena types 4,5)
 702
 703   3 differs from 2 as an optimization; some body types have several
 704   unused fields in the front of the structure (which are kept in-place
 705   for consistency).  These bodies can be allocated in smaller chunks,
 706   because the leading fields arent accessed.  Pointers to such bodies
 707   are decremented to point at the unused 'ghost' memory, knowing that
 708   the pointers are used with offsets to the real memory.
 709
 710   HE, HEK arenas are managed separately, with separate code, but may
 711   be merge-able later..
 712
 713   PTE arenas are not sv-bodies, but they share these mid-level
 714   mechanics, so are considered here.  The new mid-level mechanics rely
 715   on the sv_type of the body being allocated, so we just reserve one
 716   of the unused body-slots for PTEs, then use it in those (2) PTE
 717   contexts below (line ~10k)
 718 */
 719
 720 /* get_arena(size): this creates custom-sized arenas
 721    TBD: export properly for hv.c: S_more_he().
 722 */
 723 void*
 724 Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
 725 {
 726     dVAR;
 727     struct arena_desc* adesc;
 728     struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 729     unsigned int curr;
 730
 731     /* shouldnt need this
 732     if (!arena_size)    arena_size = PERL_ARENA_SIZE;
 733     */
 734
 735     /* may need new arena-set to hold new arena */
 736     if (!aroot || aroot->curr >= aroot->set_size) {
 737         struct arena_set *newroot;
 738         Newxz(newroot, 1, struct arena_set);
 739         newroot->set_size = ARENAS_PER_SET;
 740         newroot->next = aroot;
 741         aroot = newroot;
 742         PL_body_arenas = (void *) newroot;
 743         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
 744     }
 745
 746     /* ok, now have arena-set with at least 1 empty/available arena-desc */
 747     curr = aroot->curr++;
 748     adesc = &(aroot->set[curr]);
 749     assert(!adesc->arena);
 750
 751     Newx(adesc->arena, arena_size, char);
 752     adesc->size = arena_size;
 753     adesc->misc = misc;
 754     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
 755                           curr, (void*)adesc->arena, (UV)arena_size));
 756
 757     return adesc->arena;
 758 }
 759
 760
 761 /* return a thing to the free list */
 762
 763 #define del_body(thing, root)                   \
 764     STMT_START {                                \
 765         void ** const thing_copy = (void **)thing;\
 766         *thing_copy = *root;                    \
 767         *root = (void*)thing_copy;              \
 768     } STMT_END
 769
 770 /*
 771
 772 =head1 SV-Body Allocation
 773
 774 Allocation of SV-bodies is similar to SV-heads, differing as follows;
 775 the allocation mechanism is used for many body types, so is somewhat
 776 more complicated, it uses arena-sets, and has no need for still-live
 777 SV detection.
 778
 779 At the outermost level, (new|del)_X*V macros return bodies of the
 780 appropriate type.  These macros call either (new|del)_body_type or
 781 (new|del)_body_allocated macro pairs, depending on specifics of the
 782 type.  Most body types use the former pair, the latter pair is used to
 783 allocate body types with "ghost fields".
 784
 785 "ghost fields" are fields that are unused in certain types, and
 786 consequently dont need to actually exist.  They are declared because
 787 they're part of a "base type", which allows use of functions as
 788 methods.  The simplest examples are AVs and HVs, 2 aggregate types
 789 which don't use the fields which support SCALAR semantics.
 790
 791 For these types, the arenas are carved up into *_allocated size
 792 chunks, we thus avoid wasted memory for those unaccessed members.
 793 When bodies are allocated, we adjust the pointer back in memory by the
 794 size of the bit not allocated, so it's as if we allocated the full
 795 structure.  (But things will all go boom if you write to the part that
 796 is "not there", because you'll be overwriting the last members of the
 797 preceding structure in memory.)
 798
 799 We calculate the correction using the STRUCT_OFFSET macro. For
 800 example, if xpv_allocated is the same structure as XPV then the two
 801 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
 802 structure is smaller (no initial NV actually allocated) then the net
 803 effect is to subtract the size of the NV from the pointer, to return a
 804 new pointer as if an initial NV were actually allocated.
 805
 806 This is the same trick as was used for NV and IV bodies. Ironically it
 807 doesn't need to be used for NV bodies any more, because NV is now at
 808 the start of the structure. IV bodies don't need it either, because
 809 they are no longer allocated.
 810
 811 In turn, the new_body_* allocators call S_new_body(), which invokes
 812 new_body_inline macro, which takes a lock, and takes a body off the
 813 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
 814 necessary to refresh an empty list.  Then the lock is released, and
 815 the body is returned.
 816
 817 S_more_bodies calls get_arena(), and carves it up into an array of N
 818 bodies, which it strings into a linked list.  It looks up arena-size
 819 and body-size from the body_details table described below, thus
 820 supporting the multiple body-types.
 821
 822 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
 823 the (new|del)_X*V macros are mapped directly to malloc/free.
 824
 825 */
 826
 827 /*
 828
 829 For each sv-type, struct body_details bodies_by_type[] carries
 830 parameters which control these aspects of SV handling:
 831
 832 Arena_size determines whether arenas are used for this body type, and if
 833 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
 834 zero, forcing individual mallocs and frees.
 835
 836 Body_size determines how big a body is, and therefore how many fit into
 837 each arena.  Offset carries the body-pointer adjustment needed for
 838 *_allocated body types, and is used in *_allocated macros.
 839
 840 But its main purpose is to parameterize info needed in
 841 Perl_sv_upgrade().  The info here dramatically simplifies the function
 842 vs the implementation in 5.8.7, making it table-driven.  All fields
 843 are used for this, except for arena_size.
 844
 845 For the sv-types that have no bodies, arenas are not used, so those
 846 PL_body_roots[sv_type] are unused, and can be overloaded.  In
 847 something of a special case, SVt_NULL is borrowed for HE arenas;
 848 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
 849 bodies_by_type[SVt_NULL] slot is not used, as the table is not
 850 available in hv.c.
 851
 852 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
 853 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
 854 just use the same allocation semantics.  At first, PTEs were also
 855 overloaded to a non-body sv-type, but this yielded hard-to-find malloc
 856 bugs, so was simplified by claiming a new slot.  This choice has no
 857 consequence at this time.
 858
 859 */
 860
 861 struct body_details {
 862     U8 body_size;       /* Size to allocate  */
 863     U8 copy;            /* Size of structure to copy (may be shorter)  */
 864     U8 offset;
 865     unsigned int type : 4;          /* We have space for a sanity check.  */
 866     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
 867     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
 868     unsigned int arena : 1;         /* Allocated from an arena */
 869     size_t arena_size;              /* Size of arena to allocate */
 870 };
 871
 872 #define HADNV FALSE
 873 #define NONV TRUE
 874
 875
 876 #ifdef PURIFY
 877 /* With -DPURFIY we allocate everything directly, and don't use arenas.
 878    This seems a rather elegant way to simplify some of the code below.  */
 879 #define HASARENA FALSE
 880 #else
 881 #define HASARENA TRUE
 882 #endif
 883 #define NOARENA FALSE
 884
 885 /* Size the arenas to exactly fit a given number of bodies.  A count
 886    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
 887    simplifying the default.  If count > 0, the arena is sized to fit
 888    only that many bodies, allowing arenas to be used for large, rare
 889    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
 890    limited by PERL_ARENA_SIZE, so we can safely oversize the
 891    declarations.
 892  */
 893 #define FIT_ARENA0(body_size)                           \
 894     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
 895 #define FIT_ARENAn(count,body_size)                     \
 896     ( count * body_size <= PERL_ARENA_SIZE)             \
 897     ? count * body_size                                 \
 898     : FIT_ARENA0 (body_size)
 899 #define FIT_ARENA(count,body_size)                      \
 900     count                                               \
 901     ? FIT_ARENAn (count, body_size)                     \
 902     : FIT_ARENA0 (body_size)
 903
 904 /* A macro to work out the offset needed to subtract from a pointer to (say)
 905
 906 typedef struct {
 907     STRLEN      xpv_cur;
 908     STRLEN      xpv_len;
 909 } xpv_allocated;
 910
 911 to make its members accessible via a pointer to (say)
 912
 913 struct xpv {
 914     NV          xnv_nv;
 915     STRLEN      xpv_cur;
 916     STRLEN      xpv_len;
 917 };
 918
 919 */
 920
 921 #define relative_STRUCT_OFFSET(longer, shorter, member) \
 922     (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
 923
 924 /* Calculate the length to copy. Specifically work out the length less any
 925    final padding the compiler needed to add.  See the comment in sv_upgrade
 926    for why copying the padding proved to be a bug.  */
 927
 928 #define copy_length(type, last_member) \
 929         STRUCT_OFFSET(type, last_member) \
 930         + sizeof (((type*)SvANY((const SV *)0))->last_member)
 931
 932 static const struct body_details bodies_by_type[] = {
 933     { sizeof(HE), 0, 0, SVt_NULL,
 934       FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
 935
 936     /* The bind placeholder pretends to be an RV for now.
 937        Also it's marked as "can't upgrade" to stop anyone using it before it's
 938        implemented.  */
 939     { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
 940
 941     /* IVs are in the head, so the allocation size is 0.
 942        However, the slot is overloaded for PTEs.  */
 943     { sizeof(struct ptr_tbl_ent), /* This is used for PTEs.  */
 944       sizeof(IV), /* This is used to copy out the IV body.  */
 945       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
 946       NOARENA /* IVS don't need an arena  */,
 947       /* But PTEs need to know the size of their arena  */
 948       FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
 949     },
 950
 951     /* 8 bytes on most ILP32 with IEEE doubles */
 952     { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
 953       FIT_ARENA(0, sizeof(NV)) },
 954
 955     /* 8 bytes on most ILP32 with IEEE doubles */
 956     { sizeof(xpv_allocated),
 957       copy_length(XPV, xpv_len)
 958       - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
 959       + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
 960       SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
 961
 962     /* 12 */
 963     { sizeof(xpviv_allocated),
 964       copy_length(XPVIV, xiv_u)
 965       - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
 966       + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
 967       SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
 968
 969     /* 20 */
 970     { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
 971       HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
 972
 973     /* 28 */
 974     { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
 975       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 976
 977     /* something big */
 978     { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated),
 979       + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur),
 980       SVt_REGEXP, FALSE, NONV, HASARENA,
 981       FIT_ARENA(0, sizeof(struct regexp_allocated))
 982     },
 983
 984     /* 48 */
 985     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
 986       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
 987
 988     /* 64 */
 989     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
 990       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
 991
 992     { sizeof(xpvav_allocated),
 993       copy_length(XPVAV, xmg_stash)
 994       - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
 995       + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
 996       SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
 997
 998     { sizeof(xpvhv_allocated),
 999       copy_length(XPVHV, xmg_stash)
1000       - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
1001       + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
1002       SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
1003
1004     /* 56 */
1005     { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
1006       + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
1007       SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
1008
1009     { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
1010       + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
1011       SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
1012
1013     /* XPVIO is 84 bytes, fits 48x */
1014     { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
1015       + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
1016       SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
1017 };
1018
1019 #define new_body_type(sv_type)          \
1020     (void *)((char *)S_new_body(aTHX_ sv_type))
1021
1022 #define del_body_type(p, sv_type)       \
1023     del_body(p, &PL_body_roots[sv_type])
1024
1025
1026 #define new_body_allocated(sv_type)             \
1027     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1028              - bodies_by_type[sv_type].offset)
1029
1030 #define del_body_allocated(p, sv_type)          \
1031     del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1032
1033
1034 #define my_safemalloc(s)        (void*)safemalloc(s)
1035 #define my_safecalloc(s)        (void*)safecalloc(s, 1)
1036 #define my_safefree(p)  safefree((char*)p)
1037
1038 #ifdef PURIFY
1039
1040 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
1041 #define del_XNV(p)      my_safefree(p)
1042
1043 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
1044 #define del_XPVNV(p)    my_safefree(p)
1045
1046 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
1047 #define del_XPVAV(p)    my_safefree(p)
1048
1049 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
1050 #define del_XPVHV(p)    my_safefree(p)
1051
1052 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
1053 #define del_XPVMG(p)    my_safefree(p)
1054
1055 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
1056 #define del_XPVGV(p)    my_safefree(p)
1057
1058 #else /* !PURIFY */
1059
1060 #define new_XNV()       new_body_type(SVt_NV)
1061 #define del_XNV(p)      del_body_type(p, SVt_NV)
1062
1063 #define new_XPVNV()     new_body_type(SVt_PVNV)
1064 #define del_XPVNV(p)    del_body_type(p, SVt_PVNV)
1065
1066 #define new_XPVAV()     new_body_allocated(SVt_PVAV)
1067 #define del_XPVAV(p)    del_body_allocated(p, SVt_PVAV)
1068
1069 #define new_XPVHV()     new_body_allocated(SVt_PVHV)
1070 #define del_XPVHV(p)    del_body_allocated(p, SVt_PVHV)
1071
1072 #define new_XPVMG()     new_body_type(SVt_PVMG)
1073 #define del_XPVMG(p)    del_body_type(p, SVt_PVMG)
1074
1075 #define new_XPVGV()     new_body_type(SVt_PVGV)
1076 #define del_XPVGV(p)    del_body_type(p, SVt_PVGV)
1077
1078 #endif /* PURIFY */
1079
1080 /* no arena for you! */
1081
1082 #define new_NOARENA(details) \
1083         my_safemalloc((details)->body_size + (details)->offset)
1084 #define new_NOARENAZ(details) \
1085         my_safecalloc((details)->body_size + (details)->offset)
1086
1087 STATIC void *
1088 S_more_bodies (pTHX_ const svtype sv_type)
1089 {
1090     dVAR;
1091     void ** const root = &PL_body_roots[sv_type];
1092     const struct body_details * const bdp = &bodies_by_type[sv_type];
1093     const size_t body_size = bdp->body_size;
1094     char *start;
1095     const char *end;
1096     const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1097 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1098     static bool done_sanity_check;
1099
1100     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1101      * variables like done_sanity_check. */
1102     if (!done_sanity_check) {
1103         unsigned int i = SVt_LAST;
1104
1105         done_sanity_check = TRUE;
1106
1107         while (i--)
1108             assert (bodies_by_type[i].type == i);
1109     }
1110 #endif
1111
1112     assert(bdp->arena_size);
1113
1114     start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1115
1116     end = start + arena_size - 2 * body_size;
1117
1118     /* computed count doesnt reflect the 1st slot reservation */
1119 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1120     DEBUG_m(PerlIO_printf(Perl_debug_log,
1121                           "arena %p end %p arena-size %d (from %d) type %d "
1122                           "size %d ct %d\n",
1123                           (void*)start, (void*)end, (int)arena_size,
1124                           (int)bdp->arena_size, sv_type, (int)body_size,
1125                           (int)arena_size / (int)body_size));
1126 #else
1127     DEBUG_m(PerlIO_printf(Perl_debug_log,
1128                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1129                           (void*)start, (void*)end,
1130                           (int)bdp->arena_size, sv_type, (int)body_size,
1131                           (int)bdp->arena_size / (int)body_size));
1132 #endif
1133     *root = (void *)start;
1134
1135     while (start <= end) {
1136         char * const next = start + body_size;
1137         *(void**) start = (void *)next;
1138         start = next;
1139     }
1140     *(void **)start = 0;
1141
1142     return *root;
1143 }
1144
1145 /* grab a new thing from the free list, allocating more if necessary.
1146    The inline version is used for speed in hot routines, and the
1147    function using it serves the rest (unless PURIFY).
1148 */
1149 #define new_body_inline(xpv, sv_type) \
1150     STMT_START { \
1151         void ** const r3wt = &PL_body_roots[sv_type]; \
1152         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1153           ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1154         *(r3wt) = *(void**)(xpv); \
1155     } STMT_END
1156
1157 #ifndef PURIFY
1158
1159 STATIC void *
1160 S_new_body(pTHX_ const svtype sv_type)
1161 {
1162     dVAR;
1163     void *xpv;
1164     new_body_inline(xpv, sv_type);
1165     return xpv;
1166 }
1167
1168 #endif
1169
1170 static const struct body_details fake_rv =
1171     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1172
1173 /*
1174 =for apidoc sv_upgrade
1175
1176 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1177 SV, then copies across as much information as possible from the old body.
1178 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1179
1180 =cut
1181 */
1182
1183 void
1184 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1185 {
1186     dVAR;
1187     void*       old_body;
1188     void*       new_body;
1189     const svtype old_type = SvTYPE(sv);
1190     const struct body_details *new_type_details;
1191     const struct body_details *old_type_details
1192         = bodies_by_type + old_type;
1193     SV *referant = NULL;
1194
1195     PERL_ARGS_ASSERT_SV_UPGRADE;
1196
1197     if (new_type != SVt_PV && SvIsCOW(sv)) {
1198         sv_force_normal_flags(sv, 0);
1199     }
1200
1201     if (old_type == new_type)
1202         return;
1203
1204     old_body = SvANY(sv);
1205
1206     /* Copying structures onto other structures that have been neatly zeroed
1207        has a subtle gotcha. Consider XPVMG
1208
1209        +------+------+------+------+------+-------+-------+
1210        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1211        +------+------+------+------+------+-------+-------+
1212        0      4      8     12     16     20      24      28
1213
1214        where NVs are aligned to 8 bytes, so that sizeof that structure is
1215        actually 32 bytes long, with 4 bytes of padding at the end:
1216
1217        +------+------+------+------+------+-------+-------+------+
1218        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1219        +------+------+------+------+------+-------+-------+------+
1220        0      4      8     12     16     20      24      28     32
1221
1222        so what happens if you allocate memory for this structure:
1223
1224        +------+------+------+------+------+-------+-------+------+------+...
1225        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1226        +------+------+------+------+------+-------+-------+------+------+...
1227        0      4      8     12     16     20      24      28     32     36
1228
1229        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1230        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1231        started out as zero once, but it's quite possible that it isn't. So now,
1232        rather than a nicely zeroed GP, you have it pointing somewhere random.
1233        Bugs ensue.
1234
1235        (In fact, GP ends up pointing at a previous GP structure, because the
1236        principle cause of the padding in XPVMG getting garbage is a copy of
1237        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1238        this happens to be moot because XPVGV has been re-ordered, with GP
1239        no longer after STASH)
1240
1241        So we are careful and work out the size of used parts of all the
1242        structures.  */
1243
1244     switch (old_type) {
1245     case SVt_NULL:
1246         break;
1247     case SVt_IV:
1248         if (SvROK(sv)) {
1249             referant = SvRV(sv);
1250             old_type_details = &fake_rv;
1251             if (new_type == SVt_NV)
1252                 new_type = SVt_PVNV;
1253         } else {
1254             if (new_type < SVt_PVIV) {
1255                 new_type = (new_type == SVt_NV)
1256                     ? SVt_PVNV : SVt_PVIV;
1257             }
1258         }
1259         break;
1260     case SVt_NV:
1261         if (new_type < SVt_PVNV) {
1262             new_type = SVt_PVNV;
1263         }
1264         break;
1265     case SVt_PV:
1266         assert(new_type > SVt_PV);
1267         assert(SVt_IV < SVt_PV);
1268         assert(SVt_NV < SVt_PV);
1269         break;
1270     case SVt_PVIV:
1271         break;
1272     case SVt_PVNV:
1273         break;
1274     case SVt_PVMG:
1275         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1276            there's no way that it can be safely upgraded, because perl.c
1277            expects to Safefree(SvANY(PL_mess_sv))  */
1278         assert(sv != PL_mess_sv);
1279         /* This flag bit is used to mean other things in other scalar types.
1280            Given that it only has meaning inside the pad, it shouldn't be set
1281            on anything that can get upgraded.  */
1282         assert(!SvPAD_TYPED(sv));
1283         break;
1284     default:
1285         if (old_type_details->cant_upgrade)
1286             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1287                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1288     }
1289
1290     if (old_type > new_type)
1291         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1292                 (int)old_type, (int)new_type);
1293
1294     new_type_details = bodies_by_type + new_type;
1295
1296     SvFLAGS(sv) &= ~SVTYPEMASK;
1297     SvFLAGS(sv) |= new_type;
1298
1299     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1300        the return statements above will have triggered.  */
1301     assert (new_type != SVt_NULL);
1302     switch (new_type) {
1303     case SVt_IV:
1304         assert(old_type == SVt_NULL);
1305         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1306         SvIV_set(sv, 0);
1307         return;
1308     case SVt_NV:
1309         assert(old_type == SVt_NULL);
1310         SvANY(sv) = new_XNV();
1311         SvNV_set(sv, 0);
1312         return;
1313     case SVt_PVHV:
1314     case SVt_PVAV:
1315         assert(new_type_details->body_size);
1316
1317 #ifndef PURIFY
1318         assert(new_type_details->arena);
1319         assert(new_type_details->arena_size);
1320         /* This points to the start of the allocated area.  */
1321         new_body_inline(new_body, new_type);
1322         Zero(new_body, new_type_details->body_size, char);
1323         new_body = ((char *)new_body) - new_type_details->offset;
1324 #else
1325         /* We always allocated the full length item with PURIFY. To do this
1326            we fake things so that arena is false for all 16 types..  */
1327         new_body = new_NOARENAZ(new_type_details);
1328 #endif
1329         SvANY(sv) = new_body;
1330         if (new_type == SVt_PVAV) {
1331             AvMAX(sv)   = -1;
1332             AvFILLp(sv) = -1;
1333             AvREAL_only(sv);
1334             if (old_type_details->body_size) {
1335                 AvALLOC(sv) = 0;
1336             } else {
1337                 /* It will have been zeroed when the new body was allocated.
1338                    Lets not write to it, in case it confuses a write-back
1339                    cache.  */
1340             }
1341         } else {
1342             assert(!SvOK(sv));
1343             SvOK_off(sv);
1344 #ifndef NODEFAULT_SHAREKEYS
1345             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1346 #endif
1347             HvMAX(sv) = 7; /* (start with 8 buckets) */
1348             if (old_type_details->body_size) {
1349                 HvFILL(sv) = 0;
1350             } else {
1351                 /* It will have been zeroed when the new body was allocated.
1352                    Lets not write to it, in case it confuses a write-back
1353                    cache.  */
1354             }
1355         }
1356
1357         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1358            The target created by newSVrv also is, and it can have magic.
1359            However, it never has SvPVX set.
1360         */
1361         if (old_type == SVt_IV) {
1362             assert(!SvROK(sv));
1363         } else if (old_type >= SVt_PV) {
1364             assert(SvPVX_const(sv) == 0);
1365         }
1366
1367         if (old_type >= SVt_PVMG) {
1368             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1369             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1370         } else {
1371             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1372         }
1373         break;
1374
1375
1376     case SVt_PVIV:
1377         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1378            no route from NV to PVIV, NOK can never be true  */
1379         assert(!SvNOKp(sv));
1380         assert(!SvNOK(sv));
1381     case SVt_PVIO:
1382     case SVt_PVFM:
1383     case SVt_PVGV:
1384     case SVt_PVCV:
1385     case SVt_PVLV:
1386     case SVt_REGEXP:
1387     case SVt_PVMG:
1388     case SVt_PVNV:
1389     case SVt_PV:
1390
1391         assert(new_type_details->body_size);
1392         /* We always allocated the full length item with PURIFY. To do this
1393            we fake things so that arena is false for all 16 types..  */
1394         if(new_type_details->arena) {
1395             /* This points to the start of the allocated area.  */
1396             new_body_inline(new_body, new_type);
1397             Zero(new_body, new_type_details->body_size, char);
1398             new_body = ((char *)new_body) - new_type_details->offset;
1399         } else {
1400             new_body = new_NOARENAZ(new_type_details);
1401         }
1402         SvANY(sv) = new_body;
1403
1404         if (old_type_details->copy) {
1405             /* There is now the potential for an upgrade from something without
1406                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1407             int offset = old_type_details->offset;
1408             int length = old_type_details->copy;
1409
1410             if (new_type_details->offset > old_type_details->offset) {
1411                 const int difference
1412                     = new_type_details->offset - old_type_details->offset;
1413                 offset += difference;
1414                 length -= difference;
1415             }
1416             assert (length >= 0);
1417
1418             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1419                  char);
1420         }
1421
1422 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1423         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1424          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1425          * NV slot, but the new one does, then we need to initialise the
1426          * freshly created NV slot with whatever the correct bit pattern is
1427          * for 0.0  */
1428         if (old_type_details->zero_nv && !new_type_details->zero_nv
1429             && !isGV_with_GP(sv))
1430             SvNV_set(sv, 0);
1431 #endif
1432
1433         if (new_type == SVt_PVIO)
1434             IoPAGE_LEN(sv) = 60;
1435         if (old_type < SVt_PV) {
1436             /* referant will be NULL unless the old type was SVt_IV emulating
1437                SVt_RV */
1438             sv->sv_u.svu_rv = referant;
1439         }
1440         break;
1441     default:
1442         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1443                    (unsigned long)new_type);
1444     }
1445
1446     if (old_type_details->arena) {
1447         /* If there was an old body, then we need to free it.
1448            Note that there is an assumption that all bodies of types that
1449            can be upgraded came from arenas. Only the more complex non-
1450            upgradable types are allowed to be directly malloc()ed.  */
1451 #ifdef PURIFY
1452         my_safefree(old_body);
1453 #else
1454         del_body((void*)((char*)old_body + old_type_details->offset),
1455                  &PL_body_roots[old_type]);
1456 #endif
1457     }
1458 }
1459
1460 /*
1461 =for apidoc sv_backoff
1462
1463 Remove any string offset. You should normally use the C<SvOOK_off> macro
1464 wrapper instead.
1465
1466 =cut
1467 */
1468
1469 int
1470 Perl_sv_backoff(pTHX_ register SV *const sv)
1471 {
1472     STRLEN delta;
1473     const char * const s = SvPVX_const(sv);
1474
1475     PERL_ARGS_ASSERT_SV_BACKOFF;
1476     PERL_UNUSED_CONTEXT;
1477
1478     assert(SvOOK(sv));
1479     assert(SvTYPE(sv) != SVt_PVHV);
1480     assert(SvTYPE(sv) != SVt_PVAV);
1481
1482     SvOOK_offset(sv, delta);
1483
1484     SvLEN_set(sv, SvLEN(sv) + delta);
1485     SvPV_set(sv, SvPVX(sv) - delta);
1486     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1487     SvFLAGS(sv) &= ~SVf_OOK;
1488     return 0;
1489 }
1490
1491 /*
1492 =for apidoc sv_grow
1493
1494 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1495 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1496 Use the C<SvGROW> wrapper instead.
1497
1498 =cut
1499 */
1500
1501 char *
1502 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1503 {
1504     register char *s;
1505
1506     PERL_ARGS_ASSERT_SV_GROW;
1507
1508     if (PL_madskills && newlen >= 0x100000) {
1509         PerlIO_printf(Perl_debug_log,
1510                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1511     }
1512 #ifdef HAS_64K_LIMIT
1513     if (newlen >= 0x10000) {
1514         PerlIO_printf(Perl_debug_log,
1515                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1516         my_exit(1);
1517     }
1518 #endif /* HAS_64K_LIMIT */
1519     if (SvROK(sv))
1520         sv_unref(sv);
1521     if (SvTYPE(sv) < SVt_PV) {
1522         sv_upgrade(sv, SVt_PV);
1523         s = SvPVX_mutable(sv);
1524     }
1525     else if (SvOOK(sv)) {       /* pv is offset? */
1526         sv_backoff(sv);
1527         s = SvPVX_mutable(sv);
1528         if (newlen > SvLEN(sv))
1529             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1530 #ifdef HAS_64K_LIMIT
1531         if (newlen >= 0x10000)
1532             newlen = 0xFFFF;
1533 #endif
1534     }
1535     else
1536         s = SvPVX_mutable(sv);
1537
1538     if (newlen > SvLEN(sv)) {           /* need more room? */
1539 #ifndef Perl_safesysmalloc_size
1540         newlen = PERL_STRLEN_ROUNDUP(newlen);
1541 #endif
1542         if (SvLEN(sv) && s) {
1543             s = (char*)saferealloc(s, newlen);
1544         }
1545         else {
1546             s = (char*)safemalloc(newlen);
1547             if (SvPVX_const(sv) && SvCUR(sv)) {
1548                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1549             }
1550         }
1551         SvPV_set(sv, s);
1552 #ifdef Perl_safesysmalloc_size
1553         /* Do this here, do it once, do it right, and then we will never get
1554            called back into sv_grow() unless there really is some growing
1555            needed.  */
1556         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1557 #else
1558         SvLEN_set(sv, newlen);
1559 #endif
1560     }
1561     return s;
1562 }
1563
1564 /*
1565 =for apidoc sv_setiv
1566
1567 Copies an integer into the given SV, upgrading first if necessary.
1568 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1569
1570 =cut
1571 */
1572
1573 void
1574 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1575 {
1576     dVAR;
1577
1578     PERL_ARGS_ASSERT_SV_SETIV;
1579
1580     SV_CHECK_THINKFIRST_COW_DROP(sv);
1581     switch (SvTYPE(sv)) {
1582     case SVt_NULL:
1583     case SVt_NV:
1584         sv_upgrade(sv, SVt_IV);
1585         break;
1586     case SVt_PV:
1587         sv_upgrade(sv, SVt_PVIV);
1588         break;
1589
1590     case SVt_PVGV:
1591         if (!isGV_with_GP(sv))
1592             break;
1593     case SVt_PVAV:
1594     case SVt_PVHV:
1595     case SVt_PVCV:
1596     case SVt_PVFM:
1597     case SVt_PVIO:
1598         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1599                    OP_DESC(PL_op));
1600     default: NOOP;
1601     }
1602     (void)SvIOK_only(sv);                       /* validate number */
1603     SvIV_set(sv, i);
1604     SvTAINT(sv);
1605 }
1606
1607 /*
1608 =for apidoc sv_setiv_mg
1609
1610 Like C<sv_setiv>, but also handles 'set' magic.
1611
1612 =cut
1613 */
1614
1615 void
1616 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1617 {
1618     PERL_ARGS_ASSERT_SV_SETIV_MG;
1619
1620     sv_setiv(sv,i);
1621     SvSETMAGIC(sv);
1622 }
1623
1624 /*
1625 =for apidoc sv_setuv
1626
1627 Copies an unsigned integer into the given SV, upgrading first if necessary.
1628 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1629
1630 =cut
1631 */
1632
1633 void
1634 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1635 {
1636     PERL_ARGS_ASSERT_SV_SETUV;
1637
1638     /* With these two if statements:
1639        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1640
1641        without
1642        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1643
1644        If you wish to remove them, please benchmark to see what the effect is
1645     */
1646     if (u <= (UV)IV_MAX) {
1647        sv_setiv(sv, (IV)u);
1648        return;
1649     }
1650     sv_setiv(sv, 0);
1651     SvIsUV_on(sv);
1652     SvUV_set(sv, u);
1653 }
1654
1655 /*
1656 =for apidoc sv_setuv_mg
1657
1658 Like C<sv_setuv>, but also handles 'set' magic.
1659
1660 =cut
1661 */
1662
1663 void
1664 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1665 {
1666     PERL_ARGS_ASSERT_SV_SETUV_MG;
1667
1668     sv_setuv(sv,u);
1669     SvSETMAGIC(sv);
1670 }
1671
1672 /*
1673 =for apidoc sv_setnv
1674
1675 Copies a double into the given SV, upgrading first if necessary.
1676 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1677
1678 =cut
1679 */
1680
1681 void
1682 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1683 {
1684     dVAR;
1685
1686     PERL_ARGS_ASSERT_SV_SETNV;
1687
1688     SV_CHECK_THINKFIRST_COW_DROP(sv);
1689     switch (SvTYPE(sv)) {
1690     case SVt_NULL:
1691     case SVt_IV:
1692         sv_upgrade(sv, SVt_NV);
1693         break;
1694     case SVt_PV:
1695     case SVt_PVIV:
1696         sv_upgrade(sv, SVt_PVNV);
1697         break;
1698
1699     case SVt_PVGV:
1700         if (!isGV_with_GP(sv))
1701             break;
1702     case SVt_PVAV:
1703     case SVt_PVHV:
1704     case SVt_PVCV:
1705     case SVt_PVFM:
1706     case SVt_PVIO:
1707         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1708                    OP_NAME(PL_op));
1709     default: NOOP;
1710     }
1711     SvNV_set(sv, num);
1712     (void)SvNOK_only(sv);                       /* validate number */
1713     SvTAINT(sv);
1714 }
1715
1716 /*
1717 =for apidoc sv_setnv_mg
1718
1719 Like C<sv_setnv>, but also handles 'set' magic.
1720
1721 =cut
1722 */
1723
1724 void
1725 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1726 {
1727     PERL_ARGS_ASSERT_SV_SETNV_MG;
1728
1729     sv_setnv(sv,num);
1730     SvSETMAGIC(sv);
1731 }
1732
1733 /* Print an "isn't numeric" warning, using a cleaned-up,
1734  * printable version of the offending string
1735  */
1736
1737 STATIC void
1738 S_not_a_number(pTHX_ SV *const sv)
1739 {
1740      dVAR;
1741      SV *dsv;
1742      char tmpbuf[64];
1743      const char *pv;
1744
1745      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1746
1747      if (DO_UTF8(sv)) {
1748           dsv = newSVpvs_flags("", SVs_TEMP);
1749           pv = sv_uni_display(dsv, sv, 10, 0);
1750      } else {
1751           char *d = tmpbuf;
1752           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1753           /* each *s can expand to 4 chars + "...\0",
1754              i.e. need room for 8 chars */
1755
1756           const char *s = SvPVX_const(sv);
1757           const char * const end = s + SvCUR(sv);
1758           for ( ; s < end && d < limit; s++ ) {
1759                int ch = *s & 0xFF;
1760                if (ch & 128 && !isPRINT_LC(ch)) {
1761                     *d++ = 'M';
1762                     *d++ = '-';
1763                     ch &= 127;
1764                }
1765                if (ch == '\n') {
1766                     *d++ = '\\';
1767                     *d++ = 'n';
1768                }
1769                else if (ch == '\r') {
1770                     *d++ = '\\';
1771                     *d++ = 'r';
1772                }
1773                else if (ch == '\f') {
1774                     *d++ = '\\';
1775                     *d++ = 'f';
1776                }
1777                else if (ch == '\\') {
1778                     *d++ = '\\';
1779                     *d++ = '\\';
1780                }
1781                else if (ch == '\0') {
1782                     *d++ = '\\';
1783                     *d++ = '0';
1784                }
1785                else if (isPRINT_LC(ch))
1786                     *d++ = ch;
1787                else {
1788                     *d++ = '^';
1789                     *d++ = toCTRL(ch);
1790                }
1791           }
1792           if (s < end) {
1793                *d++ = '.';
1794                *d++ = '.';
1795                *d++ = '.';
1796           }
1797           *d = '\0';
1798           pv = tmpbuf;
1799     }
1800
1801     if (PL_op)
1802         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1803                     "Argument \"%s\" isn't numeric in %s", pv,
1804                     OP_DESC(PL_op));
1805     else
1806         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1807                     "Argument \"%s\" isn't numeric", pv);
1808 }
1809
1810 /*
1811 =for apidoc looks_like_number
1812
1813 Test if the content of an SV looks like a number (or is a number).
1814 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1815 non-numeric warning), even if your atof() doesn't grok them.
1816
1817 =cut
1818 */
1819
1820 I32
1821 Perl_looks_like_number(pTHX_ SV *const sv)
1822 {
1823     register const char *sbegin;
1824     STRLEN len;
1825
1826     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1827
1828     if (SvPOK(sv)) {
1829         sbegin = SvPVX_const(sv);
1830         len = SvCUR(sv);
1831     }
1832     else if (SvPOKp(sv))
1833         sbegin = SvPV_const(sv, len);
1834     else
1835         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1836     return grok_number(sbegin, len, NULL);
1837 }
1838
1839 STATIC bool
1840 S_glob_2number(pTHX_ GV * const gv)
1841 {
1842     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1843     SV *const buffer = sv_newmortal();
1844
1845     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1846
1847     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1848        is on.  */
1849     SvFAKE_off(gv);
1850     gv_efullname3(buffer, gv, "*");
1851     SvFLAGS(gv) |= wasfake;
1852
1853     /* We know that all GVs stringify to something that is not-a-number,
1854         so no need to test that.  */
1855     if (ckWARN(WARN_NUMERIC))
1856         not_a_number(buffer);
1857     /* We just want something true to return, so that S_sv_2iuv_common
1858         can tail call us and return true.  */
1859     return TRUE;
1860 }
1861
1862 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1863    until proven guilty, assume that things are not that bad... */
1864
1865 /*
1866    NV_PRESERVES_UV:
1867
1868    As 64 bit platforms often have an NV that doesn't preserve all bits of
1869    an IV (an assumption perl has been based on to date) it becomes necessary
1870    to remove the assumption that the NV always carries enough precision to
1871    recreate the IV whenever needed, and that the NV is the canonical form.
1872    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1873    precision as a side effect of conversion (which would lead to insanity
1874    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1875    1) to distinguish between IV/UV/NV slots that have cached a valid
1876       conversion where precision was lost and IV/UV/NV slots that have a
1877       valid conversion which has lost no precision
1878    2) to ensure that if a numeric conversion to one form is requested that
1879       would lose precision, the precise conversion (or differently
1880       imprecise conversion) is also performed and cached, to prevent
1881       requests for different numeric formats on the same SV causing
1882       lossy conversion chains. (lossless conversion chains are perfectly
1883       acceptable (still))
1884
1885
1886    flags are used:
1887    SvIOKp is true if the IV slot contains a valid value
1888    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1889    SvNOKp is true if the NV slot contains a valid value
1890    SvNOK  is true only if the NV value is accurate
1891
1892    so
1893    while converting from PV to NV, check to see if converting that NV to an
1894    IV(or UV) would lose accuracy over a direct conversion from PV to
1895    IV(or UV). If it would, cache both conversions, return NV, but mark
1896    SV as IOK NOKp (ie not NOK).
1897
1898    While converting from PV to IV, check to see if converting that IV to an
1899    NV would lose accuracy over a direct conversion from PV to NV. If it
1900    would, cache both conversions, flag similarly.
1901
1902    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1903    correctly because if IV & NV were set NV *always* overruled.
1904    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1905    changes - now IV and NV together means that the two are interchangeable:
1906    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1907
1908    The benefit of this is that operations such as pp_add know that if
1909    SvIOK is true for both left and right operands, then integer addition
1910    can be used instead of floating point (for cases where the result won't
1911    overflow). Before, floating point was always used, which could lead to
1912    loss of precision compared with integer addition.
1913
1914    * making IV and NV equal status should make maths accurate on 64 bit
1915      platforms
1916    * may speed up maths somewhat if pp_add and friends start to use
1917      integers when possible instead of fp. (Hopefully the overhead in
1918      looking for SvIOK and checking for overflow will not outweigh the
1919      fp to integer speedup)
1920    * will slow down integer operations (callers of SvIV) on "inaccurate"
1921      values, as the change from SvIOK to SvIOKp will cause a call into
1922      sv_2iv each time rather than a macro access direct to the IV slot
1923    * should speed up number->string conversion on integers as IV is
1924      favoured when IV and NV are equally accurate
1925
1926    ####################################################################
1927    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1928    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1929    On the other hand, SvUOK is true iff UV.
1930    ####################################################################
1931
1932    Your mileage will vary depending your CPU's relative fp to integer
1933    performance ratio.
1934 */
1935
1936 #ifndef NV_PRESERVES_UV
1937 #  define IS_NUMBER_UNDERFLOW_IV 1
1938 #  define IS_NUMBER_UNDERFLOW_UV 2
1939 #  define IS_NUMBER_IV_AND_UV    2
1940 #  define IS_NUMBER_OVERFLOW_IV  4
1941 #  define IS_NUMBER_OVERFLOW_UV  5
1942
1943 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1944
1945 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1946 STATIC int
1947 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1948 #  ifdef DEBUGGING
1949                        , I32 numtype
1950 #  endif
1951                        )
1952 {
1953     dVAR;
1954
1955     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1956
1957     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1958     if (SvNVX(sv) < (NV)IV_MIN) {
1959         (void)SvIOKp_on(sv);
1960         (void)SvNOK_on(sv);
1961         SvIV_set(sv, IV_MIN);
1962         return IS_NUMBER_UNDERFLOW_IV;
1963     }
1964     if (SvNVX(sv) > (NV)UV_MAX) {
1965         (void)SvIOKp_on(sv);
1966         (void)SvNOK_on(sv);
1967         SvIsUV_on(sv);
1968         SvUV_set(sv, UV_MAX);
1969         return IS_NUMBER_OVERFLOW_UV;
1970     }
1971     (void)SvIOKp_on(sv);
1972     (void)SvNOK_on(sv);
1973     /* Can't use strtol etc to convert this string.  (See truth table in
1974        sv_2iv  */
1975     if (SvNVX(sv) <= (UV)IV_MAX) {
1976         SvIV_set(sv, I_V(SvNVX(sv)));
1977         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1978             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1979         } else {
1980             /* Integer is imprecise. NOK, IOKp */
1981         }
1982         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1983     }
1984     SvIsUV_on(sv);
1985     SvUV_set(sv, U_V(SvNVX(sv)));
1986     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1987         if (SvUVX(sv) == UV_MAX) {
1988             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1989                possibly be preserved by NV. Hence, it must be overflow.
1990                NOK, IOKp */
1991             return IS_NUMBER_OVERFLOW_UV;
1992         }
1993         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1994     } else {
1995         /* Integer is imprecise. NOK, IOKp */
1996     }
1997     return IS_NUMBER_OVERFLOW_IV;
1998 }
1999 #endif /* !NV_PRESERVES_UV*/
2000
2001 STATIC bool
2002 S_sv_2iuv_common(pTHX_ SV *const sv)
2003 {
2004     dVAR;
2005
2006     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2007
2008     if (SvNOKp(sv)) {
2009         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2010          * without also getting a cached IV/UV from it at the same time
2011          * (ie PV->NV conversion should detect loss of accuracy and cache
2012          * IV or UV at same time to avoid this. */
2013         /* IV-over-UV optimisation - choose to cache IV if possible */
2014
2015         if (SvTYPE(sv) == SVt_NV)
2016             sv_upgrade(sv, SVt_PVNV);
2017
2018         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2019         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2020            certainly cast into the IV range at IV_MAX, whereas the correct
2021            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2022            cases go to UV */
2023 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2024         if (Perl_isnan(SvNVX(sv))) {
2025             SvUV_set(sv, 0);
2026             SvIsUV_on(sv);
2027             return FALSE;
2028         }
2029 #endif
2030         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2031             SvIV_set(sv, I_V(SvNVX(sv)));
2032             if (SvNVX(sv) == (NV) SvIVX(sv)
2033 #ifndef NV_PRESERVES_UV
2034                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2035                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2036                 /* Don't flag it as "accurately an integer" if the number
2037                    came from a (by definition imprecise) NV operation, and
2038                    we're outside the range of NV integer precision */
2039 #endif
2040                 ) {
2041                 if (SvNOK(sv))
2042                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2043                 else {
2044                     /* scalar has trailing garbage, eg "42a" */
2045                 }
2046                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2047                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2048                                       PTR2UV(sv),
2049                                       SvNVX(sv),
2050                                       SvIVX(sv)));
2051
2052             } else {
2053                 /* IV not precise.  No need to convert from PV, as NV
2054                    conversion would already have cached IV if it detected
2055                    that PV->IV would be better than PV->NV->IV
2056                    flags already correct - don't set public IOK.  */
2057                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2058                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2059                                       PTR2UV(sv),
2060                                       SvNVX(sv),
2061                                       SvIVX(sv)));
2062             }
2063             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2064                but the cast (NV)IV_MIN rounds to a the value less (more
2065                negative) than IV_MIN which happens to be equal to SvNVX ??
2066                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2067                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2068                (NV)UVX == NVX are both true, but the values differ. :-(
2069                Hopefully for 2s complement IV_MIN is something like
2070                0x8000000000000000 which will be exact. NWC */
2071         }
2072         else {
2073             SvUV_set(sv, U_V(SvNVX(sv)));
2074             if (
2075                 (SvNVX(sv) == (NV) SvUVX(sv))
2076 #ifndef  NV_PRESERVES_UV
2077                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2078                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2079                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2080                 /* Don't flag it as "accurately an integer" if the number
2081                    came from a (by definition imprecise) NV operation, and
2082                    we're outside the range of NV integer precision */
2083 #endif
2084                 && SvNOK(sv)
2085                 )
2086                 SvIOK_on(sv);
2087             SvIsUV_on(sv);
2088             DEBUG_c(PerlIO_printf(Perl_debug_log,
2089                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2090                                   PTR2UV(sv),
2091                                   SvUVX(sv),
2092                                   SvUVX(sv)));
2093         }
2094     }
2095     else if (SvPOKp(sv) && SvLEN(sv)) {
2096         UV value;
2097         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2098         /* We want to avoid a possible problem when we cache an IV/ a UV which
2099            may be later translated to an NV, and the resulting NV is not
2100            the same as the direct translation of the initial string
2101            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2102            be careful to ensure that the value with the .456 is around if the
2103            NV value is requested in the future).
2104
2105            This means that if we cache such an IV/a UV, we need to cache the
2106            NV as well.  Moreover, we trade speed for space, and do not
2107            cache the NV if we are sure it's not needed.
2108          */
2109
2110         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2111         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2112              == IS_NUMBER_IN_UV) {
2113             /* It's definitely an integer, only upgrade to PVIV */
2114             if (SvTYPE(sv) < SVt_PVIV)
2115                 sv_upgrade(sv, SVt_PVIV);
2116             (void)SvIOK_on(sv);
2117         } else if (SvTYPE(sv) < SVt_PVNV)
2118             sv_upgrade(sv, SVt_PVNV);
2119
2120         /* If NVs preserve UVs then we only use the UV value if we know that
2121            we aren't going to call atof() below. If NVs don't preserve UVs
2122            then the value returned may have more precision than atof() will
2123            return, even though value isn't perfectly accurate.  */
2124         if ((numtype & (IS_NUMBER_IN_UV
2125 #ifdef NV_PRESERVES_UV
2126                         | IS_NUMBER_NOT_INT
2127 #endif
2128             )) == IS_NUMBER_IN_UV) {
2129             /* This won't turn off the public IOK flag if it was set above  */
2130             (void)SvIOKp_on(sv);
2131
2132             if (!(numtype & IS_NUMBER_NEG)) {
2133                 /* positive */;
2134                 if (value <= (UV)IV_MAX) {
2135                     SvIV_set(sv, (IV)value);
2136                 } else {
2137                     /* it didn't overflow, and it was positive. */
2138                     SvUV_set(sv, value);
2139                     SvIsUV_on(sv);
2140                 }
2141             } else {
2142                 /* 2s complement assumption  */
2143                 if (value <= (UV)IV_MIN) {
2144                     SvIV_set(sv, -(IV)value);
2145                 } else {
2146                     /* Too negative for an IV.  This is a double upgrade, but
2147                        I'm assuming it will be rare.  */
2148                     if (SvTYPE(sv) < SVt_PVNV)
2149                         sv_upgrade(sv, SVt_PVNV);
2150                     SvNOK_on(sv);
2151                     SvIOK_off(sv);
2152                     SvIOKp_on(sv);
2153                     SvNV_set(sv, -(NV)value);
2154                     SvIV_set(sv, IV_MIN);
2155                 }
2156             }
2157         }
2158         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2159            will be in the previous block to set the IV slot, and the next
2160            block to set the NV slot.  So no else here.  */
2161
2162         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2163             != IS_NUMBER_IN_UV) {
2164             /* It wasn't an (integer that doesn't overflow the UV). */
2165             SvNV_set(sv, Atof(SvPVX_const(sv)));
2166
2167             if (! numtype && ckWARN(WARN_NUMERIC))
2168                 not_a_number(sv);
2169
2170 #if defined(USE_LONG_DOUBLE)
2171             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2172                                   PTR2UV(sv), SvNVX(sv)));
2173 #else
2174             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2175                                   PTR2UV(sv), SvNVX(sv)));
2176 #endif
2177
2178 #ifdef NV_PRESERVES_UV
2179             (void)SvIOKp_on(sv);
2180             (void)SvNOK_on(sv);
2181             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2182                 SvIV_set(sv, I_V(SvNVX(sv)));
2183                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2184                     SvIOK_on(sv);
2185                 } else {
2186                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2187                 }
2188                 /* UV will not work better than IV */
2189             } else {
2190                 if (SvNVX(sv) > (NV)UV_MAX) {
2191                     SvIsUV_on(sv);
2192                     /* Integer is inaccurate. NOK, IOKp, is UV */
2193                     SvUV_set(sv, UV_MAX);
2194                 } else {
2195                     SvUV_set(sv, U_V(SvNVX(sv)));
2196                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2197                        NV preservse UV so can do correct comparison.  */
2198                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2199                         SvIOK_on(sv);
2200                     } else {
2201                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2202                     }
2203                 }
2204                 SvIsUV_on(sv);
2205             }
2206 #else /* NV_PRESERVES_UV */
2207             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2208                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2209                 /* The IV/UV slot will have been set from value returned by
2210                    grok_number above.  The NV slot has just been set using
2211                    Atof.  */
2212                 SvNOK_on(sv);
2213                 assert (SvIOKp(sv));
2214             } else {
2215                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2216                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2217                     /* Small enough to preserve all bits. */
2218                     (void)SvIOKp_on(sv);
2219                     SvNOK_on(sv);
2220                     SvIV_set(sv, I_V(SvNVX(sv)));
2221                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2222                         SvIOK_on(sv);
2223                     /* Assumption: first non-preserved integer is < IV_MAX,
2224                        this NV is in the preserved range, therefore: */
2225                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2226                           < (UV)IV_MAX)) {
2227                         Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2228                     }
2229                 } else {
2230                     /* IN_UV NOT_INT
2231                          0      0       already failed to read UV.
2232                          0      1       already failed to read UV.
2233                          1      0       you won't get here in this case. IV/UV
2234                                         slot set, public IOK, Atof() unneeded.
2235                          1      1       already read UV.
2236                        so there's no point in sv_2iuv_non_preserve() attempting
2237                        to use atol, strtol, strtoul etc.  */
2238 #  ifdef DEBUGGING
2239                     sv_2iuv_non_preserve (sv, numtype);
2240 #  else
2241                     sv_2iuv_non_preserve (sv);
2242 #  endif
2243                 }
2244             }
2245 #endif /* NV_PRESERVES_UV */
2246         /* It might be more code efficient to go through the entire logic above
2247            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2248            gets complex and potentially buggy, so more programmer efficient
2249            to do it this way, by turning off the public flags:  */
2250         if (!numtype)
2251             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2252         }
2253     }
2254     else  {
2255         if (isGV_with_GP(sv))
2256             return glob_2number(MUTABLE_GV(sv));
2257
2258         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2259             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2260                 report_uninit(sv);
2261         }
2262         if (SvTYPE(sv) < SVt_IV)
2263             /* Typically the caller expects that sv_any is not NULL now.  */
2264             sv_upgrade(sv, SVt_IV);
2265         /* Return 0 from the caller.  */
2266         return TRUE;
2267     }
2268     return FALSE;
2269 }
2270
2271 /*
2272 =for apidoc sv_2iv_flags
2273
2274 Return the integer value of an SV, doing any necessary string
2275 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2276 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2277
2278 =cut
2279 */
2280
2281 IV
2282 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2283 {
2284     dVAR;
2285     if (!sv)
2286         return 0;
2287     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2288         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2289            cache IVs just in case. In practice it seems that they never
2290            actually anywhere accessible by user Perl code, let alone get used
2291            in anything other than a string context.  */
2292         if (flags & SV_GMAGIC)
2293             mg_get(sv);
2294         if (SvIOKp(sv))
2295             return SvIVX(sv);
2296         if (SvNOKp(sv)) {
2297             return I_V(SvNVX(sv));
2298         }
2299         if (SvPOKp(sv) && SvLEN(sv)) {
2300             UV value;
2301             const int numtype
2302                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2303
2304             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2305                 == IS_NUMBER_IN_UV) {
2306                 /* It's definitely an integer */
2307                 if (numtype & IS_NUMBER_NEG) {
2308                     if (value < (UV)IV_MIN)
2309                         return -(IV)value;
2310                 } else {
2311                     if (value < (UV)IV_MAX)
2312                         return (IV)value;
2313                 }
2314             }
2315             if (!numtype) {
2316                 if (ckWARN(WARN_NUMERIC))
2317                     not_a_number(sv);
2318             }
2319             return I_V(Atof(SvPVX_const(sv)));
2320         }
2321         if (SvROK(sv)) {
2322             goto return_rok;
2323         }
2324         assert(SvTYPE(sv) >= SVt_PVMG);
2325         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2326     } else if (SvTHINKFIRST(sv)) {
2327         if (SvROK(sv)) {
2328         return_rok:
2329             if (SvAMAGIC(sv)) {
2330                 SV * const tmpstr=AMG_CALLun(sv,numer);
2331                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2332                     return SvIV(tmpstr);
2333                 }
2334             }
2335             return PTR2IV(SvRV(sv));
2336         }
2337         if (SvIsCOW(sv)) {
2338             sv_force_normal_flags(sv, 0);
2339         }
2340         if (SvREADONLY(sv) && !SvOK(sv)) {
2341             if (ckWARN(WARN_UNINITIALIZED))
2342                 report_uninit(sv);
2343             return 0;
2344         }
2345     }
2346     if (!SvIOKp(sv)) {
2347         if (S_sv_2iuv_common(aTHX_ sv))
2348             return 0;
2349     }
2350     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2351         PTR2UV(sv),SvIVX(sv)));
2352     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2353 }
2354
2355 /*
2356 =for apidoc sv_2uv_flags
2357
2358 Return the unsigned integer value of an SV, doing any necessary string
2359 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2360 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2361
2362 =cut
2363 */
2364
2365 UV
2366 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2367 {
2368     dVAR;
2369     if (!sv)
2370         return 0;
2371     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2372         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2373            cache IVs just in case.  */
2374         if (flags & SV_GMAGIC)
2375             mg_get(sv);
2376         if (SvIOKp(sv))
2377             return SvUVX(sv);
2378         if (SvNOKp(sv))
2379             return U_V(SvNVX(sv));
2380         if (SvPOKp(sv) && SvLEN(sv)) {
2381             UV value;
2382             const int numtype
2383                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2384
2385             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2386                 == IS_NUMBER_IN_UV) {
2387                 /* It's definitely an integer */
2388                 if (!(numtype & IS_NUMBER_NEG))
2389                     return value;
2390             }
2391             if (!numtype) {
2392                 if (ckWARN(WARN_NUMERIC))
2393                     not_a_number(sv);
2394             }
2395             return U_V(Atof(SvPVX_const(sv)));
2396         }
2397         if (SvROK(sv)) {
2398             goto return_rok;
2399         }
2400         assert(SvTYPE(sv) >= SVt_PVMG);
2401         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2402     } else if (SvTHINKFIRST(sv)) {
2403         if (SvROK(sv)) {
2404         return_rok:
2405             if (SvAMAGIC(sv)) {
2406                 SV *const tmpstr = AMG_CALLun(sv,numer);
2407                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2408                     return SvUV(tmpstr);
2409                 }
2410             }
2411             return PTR2UV(SvRV(sv));
2412         }
2413         if (SvIsCOW(sv)) {
2414             sv_force_normal_flags(sv, 0);
2415         }
2416         if (SvREADONLY(sv) && !SvOK(sv)) {
2417             if (ckWARN(WARN_UNINITIALIZED))
2418                 report_uninit(sv);
2419             return 0;
2420         }
2421     }
2422     if (!SvIOKp(sv)) {
2423         if (S_sv_2iuv_common(aTHX_ sv))
2424             return 0;
2425     }
2426
2427     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2428                           PTR2UV(sv),SvUVX(sv)));
2429     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2430 }
2431
2432 /*
2433 =for apidoc sv_2nv
2434
2435 Return the num value of an SV, doing any necessary string or integer
2436 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2437 macros.
2438
2439 =cut
2440 */
2441
2442 NV
2443 Perl_sv_2nv(pTHX_ register SV *const sv)
2444 {
2445     dVAR;
2446     if (!sv)
2447         return 0.0;
2448     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2449         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2450            cache IVs just in case.  */
2451         mg_get(sv);
2452         if (SvNOKp(sv))
2453             return SvNVX(sv);
2454         if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2455             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2456                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2457                 not_a_number(sv);
2458             return Atof(SvPVX_const(sv));
2459         }
2460         if (SvIOKp(sv)) {
2461             if (SvIsUV(sv))
2462                 return (NV)SvUVX(sv);
2463             else
2464                 return (NV)SvIVX(sv);
2465         }
2466         if (SvROK(sv)) {
2467             goto return_rok;
2468         }
2469         assert(SvTYPE(sv) >= SVt_PVMG);
2470         /* This falls through to the report_uninit near the end of the
2471            function. */
2472     } else if (SvTHINKFIRST(sv)) {
2473         if (SvROK(sv)) {
2474         return_rok:
2475             if (SvAMAGIC(sv)) {
2476                 SV *const tmpstr = AMG_CALLun(sv,numer);
2477                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2478                     return SvNV(tmpstr);
2479                 }
2480             }
2481             return PTR2NV(SvRV(sv));
2482         }
2483         if (SvIsCOW(sv)) {
2484             sv_force_normal_flags(sv, 0);
2485         }
2486         if (SvREADONLY(sv) && !SvOK(sv)) {
2487             if (ckWARN(WARN_UNINITIALIZED))
2488                 report_uninit(sv);
2489             return 0.0;
2490         }
2491     }
2492     if (SvTYPE(sv) < SVt_NV) {
2493         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2494         sv_upgrade(sv, SVt_NV);
2495 #ifdef USE_LONG_DOUBLE
2496         DEBUG_c({
2497             STORE_NUMERIC_LOCAL_SET_STANDARD();
2498             PerlIO_printf(Perl_debug_log,
2499                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2500                           PTR2UV(sv), SvNVX(sv));
2501             RESTORE_NUMERIC_LOCAL();
2502         });
2503 #else
2504         DEBUG_c({
2505             STORE_NUMERIC_LOCAL_SET_STANDARD();
2506             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2507                           PTR2UV(sv), SvNVX(sv));
2508             RESTORE_NUMERIC_LOCAL();
2509         });
2510 #endif
2511     }
2512     else if (SvTYPE(sv) < SVt_PVNV)
2513         sv_upgrade(sv, SVt_PVNV);
2514     if (SvNOKp(sv)) {
2515         return SvNVX(sv);
2516     }
2517     if (SvIOKp(sv)) {
2518         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2519 #ifdef NV_PRESERVES_UV
2520         if (SvIOK(sv))
2521             SvNOK_on(sv);
2522         else
2523             SvNOKp_on(sv);
2524 #else
2525         /* Only set the public NV OK flag if this NV preserves the IV  */
2526         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2527         if (SvIOK(sv) &&
2528             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2529                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2530             SvNOK_on(sv);
2531         else
2532             SvNOKp_on(sv);
2533 #endif
2534     }
2535     else if (SvPOKp(sv) && SvLEN(sv)) {
2536         UV value;
2537         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2538         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2539             not_a_number(sv);
2540 #ifdef NV_PRESERVES_UV
2541         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2542             == IS_NUMBER_IN_UV) {
2543             /* It's definitely an integer */
2544             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2545         } else
2546             SvNV_set(sv, Atof(SvPVX_const(sv)));
2547         if (numtype)
2548             SvNOK_on(sv);
2549         else
2550             SvNOKp_on(sv);
2551 #else
2552         SvNV_set(sv, Atof(SvPVX_const(sv)));
2553         /* Only set the public NV OK flag if this NV preserves the value in
2554            the PV at least as well as an IV/UV would.
2555            Not sure how to do this 100% reliably. */
2556         /* if that shift count is out of range then Configure's test is
2557            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2558            UV_BITS */
2559         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2560             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2561             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2562         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2563             /* Can't use strtol etc to convert this string, so don't try.
2564                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2565             SvNOK_on(sv);
2566         } else {
2567             /* value has been set.  It may not be precise.  */
2568             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2569                 /* 2s complement assumption for (UV)IV_MIN  */
2570                 SvNOK_on(sv); /* Integer is too negative.  */
2571             } else {
2572                 SvNOKp_on(sv);
2573                 SvIOKp_on(sv);
2574
2575                 if (numtype & IS_NUMBER_NEG) {
2576                     SvIV_set(sv, -(IV)value);
2577                 } else if (value <= (UV)IV_MAX) {
2578                     SvIV_set(sv, (IV)value);
2579                 } else {
2580                     SvUV_set(sv, value);
2581                     SvIsUV_on(sv);
2582                 }
2583
2584                 if (numtype & IS_NUMBER_NOT_INT) {
2585                     /* I believe that even if the original PV had decimals,
2586                        they are lost beyond the limit of the FP precision.
2587                        However, neither is canonical, so both only get p
2588                        flags.  NWC, 2000/11/25 */
2589                     /* Both already have p flags, so do nothing */
2590                 } else {
2591                     const NV nv = SvNVX(sv);
2592                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2593                         if (SvIVX(sv) == I_V(nv)) {
2594                             SvNOK_on(sv);
2595                         } else {
2596                             /* It had no "." so it must be integer.  */
2597                         }
2598                         SvIOK_on(sv);
2599                     } else {
2600                         /* between IV_MAX and NV(UV_MAX).
2601                            Could be slightly > UV_MAX */
2602
2603                         if (numtype & IS_NUMBER_NOT_INT) {
2604                             /* UV and NV both imprecise.  */
2605                         } else {
2606                             const UV nv_as_uv = U_V(nv);
2607
2608                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2609                                 SvNOK_on(sv);
2610                             }
2611                             SvIOK_on(sv);
2612                         }
2613                     }
2614                 }
2615             }
2616         }
2617         /* It might be more code efficient to go through the entire logic above
2618            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2619            gets complex and potentially buggy, so more programmer efficient
2620            to do it this way, by turning off the public flags:  */
2621         if (!numtype)
2622             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2623 #endif /* NV_PRESERVES_UV */
2624     }
2625     else  {
2626         if (isGV_with_GP(sv)) {
2627             glob_2number(MUTABLE_GV(sv));
2628             return 0.0;
2629         }
2630
2631         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2632             report_uninit(sv);
2633         assert (SvTYPE(sv) >= SVt_NV);
2634         /* Typically the caller expects that sv_any is not NULL now.  */
2635         /* XXX Ilya implies that this is a bug in callers that assume this
2636            and ideally should be fixed.  */
2637         return 0.0;
2638     }
2639 #if defined(USE_LONG_DOUBLE)
2640     DEBUG_c({
2641         STORE_NUMERIC_LOCAL_SET_STANDARD();
2642         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2643                       PTR2UV(sv), SvNVX(sv));
2644         RESTORE_NUMERIC_LOCAL();
2645     });
2646 #else
2647     DEBUG_c({
2648         STORE_NUMERIC_LOCAL_SET_STANDARD();
2649         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2650                       PTR2UV(sv), SvNVX(sv));
2651         RESTORE_NUMERIC_LOCAL();
2652     });
2653 #endif
2654     return SvNVX(sv);
2655 }
2656
2657 /*
2658 =for apidoc sv_2num
2659
2660 Return an SV with the numeric value of the source SV, doing any necessary
2661 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2662 access this function.
2663
2664 =cut
2665 */
2666
2667 SV *
2668 Perl_sv_2num(pTHX_ register SV *const sv)
2669 {
2670     PERL_ARGS_ASSERT_SV_2NUM;
2671
2672     if (!SvROK(sv))
2673         return sv;
2674     if (SvAMAGIC(sv)) {
2675         SV * const tmpsv = AMG_CALLun(sv,numer);
2676         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2677             return sv_2num(tmpsv);
2678     }
2679     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2680 }
2681
2682 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2683  * UV as a string towards the end of buf, and return pointers to start and
2684  * end of it.
2685  *
2686  * We assume that buf is at least TYPE_CHARS(UV) long.
2687  */
2688
2689 static char *
2690 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2691 {
2692     char *ptr = buf + TYPE_CHARS(UV);
2693     char * const ebuf = ptr;
2694     int sign;
2695
2696     PERL_ARGS_ASSERT_UIV_2BUF;
2697
2698     if (is_uv)
2699         sign = 0;
2700     else if (iv >= 0) {
2701         uv = iv;
2702         sign = 0;
2703     } else {
2704         uv = -iv;
2705         sign = 1;
2706     }
2707     do {
2708         *--ptr = '0' + (char)(uv % 10);
2709     } while (uv /= 10);
2710     if (sign)
2711         *--ptr = '-';
2712     *peob = ebuf;
2713     return ptr;
2714 }
2715
2716 /*
2717 =for apidoc sv_2pv_flags
2718
2719 Returns a pointer to the string value of an SV, and sets *lp to its length.
2720 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2721 if necessary.
2722 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2723 usually end up here too.
2724
2725 =cut
2726 */
2727
2728 char *
2729 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2730 {
2731     dVAR;
2732     register char *s;
2733
2734     if (!sv) {
2735         if (lp)
2736             *lp = 0;
2737         return (char *)"";
2738     }
2739     if (SvGMAGICAL(sv)) {
2740         if (flags & SV_GMAGIC)
2741             mg_get(sv);
2742         if (SvPOKp(sv)) {
2743             if (lp)
2744                 *lp = SvCUR(sv);
2745             if (flags & SV_MUTABLE_RETURN)
2746                 return SvPVX_mutable(sv);
2747             if (flags & SV_CONST_RETURN)
2748                 return (char *)SvPVX_const(sv);
2749             return SvPVX(sv);
2750         }
2751         if (SvIOKp(sv) || SvNOKp(sv)) {
2752             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2753             STRLEN len;
2754
2755             if (SvIOKp(sv)) {
2756                 len = SvIsUV(sv)
2757                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2758                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2759             } else {
2760                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2761                 len = strlen(tbuf);
2762             }
2763             assert(!SvROK(sv));
2764             {
2765                 dVAR;
2766
2767 #ifdef FIXNEGATIVEZERO
2768                 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2769                     tbuf[0] = '0';
2770                     tbuf[1] = 0;
2771                     len = 1;
2772                 }
2773 #endif
2774                 SvUPGRADE(sv, SVt_PV);
2775                 if (lp)
2776                     *lp = len;
2777                 s = SvGROW_mutable(sv, len + 1);
2778                 SvCUR_set(sv, len);
2779                 SvPOKp_on(sv);
2780                 return (char*)memcpy(s, tbuf, len + 1);
2781             }
2782         }
2783         if (SvROK(sv)) {
2784             goto return_rok;
2785         }
2786         assert(SvTYPE(sv) >= SVt_PVMG);
2787         /* This falls through to the report_uninit near the end of the
2788            function. */
2789     } else if (SvTHINKFIRST(sv)) {
2790         if (SvROK(sv)) {
2791         return_rok:
2792             if (SvAMAGIC(sv)) {
2793                 SV *const tmpstr = AMG_CALLun(sv,string);
2794                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2795                     /* Unwrap this:  */
2796                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2797                      */
2798
2799                     char *pv;
2800                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2801                         if (flags & SV_CONST_RETURN) {
2802                             pv = (char *) SvPVX_const(tmpstr);
2803                         } else {
2804                             pv = (flags & SV_MUTABLE_RETURN)
2805                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2806                         }
2807                         if (lp)
2808                             *lp = SvCUR(tmpstr);
2809                     } else {
2810                         pv = sv_2pv_flags(tmpstr, lp, flags);
2811                     }
2812                     if (SvUTF8(tmpstr))
2813                         SvUTF8_on(sv);
2814                     else
2815                         SvUTF8_off(sv);
2816                     return pv;
2817                 }
2818             }
2819             {
2820                 STRLEN len;
2821                 char *retval;
2822                 char *buffer;
2823                 SV *const referent = SvRV(sv);
2824
2825                 if (!referent) {
2826                     len = 7;
2827                     retval = buffer = savepvn("NULLREF", len);
2828                 } else if (SvTYPE(referent) == SVt_REGEXP) {
2829                     REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2830                     I32 seen_evals = 0;
2831
2832                     assert(re);
2833
2834                     /* If the regex is UTF-8 we want the containing scalar to
2835                        have an UTF-8 flag too */
2836                     if (RX_UTF8(re))
2837                         SvUTF8_on(sv);
2838                     else
2839                         SvUTF8_off(sv);
2840
2841                     if ((seen_evals = RX_SEEN_EVALS(re)))
2842                         PL_reginterp_cnt += seen_evals;
2843
2844                     if (lp)
2845                         *lp = RX_WRAPLEN(re);
2846
2847                     return RX_WRAPPED(re);
2848                 } else {
2849                     const char *const typestr = sv_reftype(referent, 0);
2850                     const STRLEN typelen = strlen(typestr);
2851                     UV addr = PTR2UV(referent);
2852                     const char *stashname = NULL;
2853                     STRLEN stashnamelen = 0; /* hush, gcc */
2854                     const char *buffer_end;
2855
2856                     if (SvOBJECT(referent)) {
2857                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2858
2859                         if (name) {
2860                             stashname = HEK_KEY(name);
2861                             stashnamelen = HEK_LEN(name);
2862
2863                             if (HEK_UTF8(name)) {
2864                                 SvUTF8_on(sv);
2865                             } else {
2866                                 SvUTF8_off(sv);
2867                             }
2868                         } else {
2869                             stashname = "__ANON__";
2870                             stashnamelen = 8;
2871                         }
2872                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2873                             + 2 * sizeof(UV) + 2 /* )\0 */;
2874                     } else {
2875                         len = typelen + 3 /* (0x */
2876                             + 2 * sizeof(UV) + 2 /* )\0 */;
2877                     }
2878
2879                     Newx(buffer, len, char);
2880                     buffer_end = retval = buffer + len;
2881
2882                     /* Working backwards  */
2883                     *--retval = '\0';
2884                     *--retval = ')';
2885                     do {
2886                         *--retval = PL_hexdigit[addr & 15];
2887                     } while (addr >>= 4);
2888                     *--retval = 'x';
2889                     *--retval = '0';
2890                     *--retval = '(';
2891
2892                     retval -= typelen;
2893                     memcpy(retval, typestr, typelen);
2894
2895                     if (stashname) {
2896                         *--retval = '=';
2897                         retval -= stashnamelen;
2898                         memcpy(retval, stashname, stashnamelen);
2899                     }
2900                     /* retval may not neccesarily have reached the start of the
2901                        buffer here.  */
2902                     assert (retval >= buffer);
2903
2904                     len = buffer_end - retval - 1; /* -1 for that \0  */
2905                 }
2906                 if (lp)
2907                     *lp = len;
2908                 SAVEFREEPV(buffer);
2909                 return retval;
2910             }
2911         }
2912         if (SvREADONLY(sv) && !SvOK(sv)) {
2913             if (lp)
2914                 *lp = 0;
2915             if (flags & SV_UNDEF_RETURNS_NULL)
2916                 return NULL;
2917             if (ckWARN(WARN_UNINITIALIZED))
2918                 report_uninit(sv);
2919             return (char *)"";
2920         }
2921     }
2922     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2923         /* I'm assuming that if both IV and NV are equally valid then
2924            converting the IV is going to be more efficient */
2925         const U32 isUIOK = SvIsUV(sv);
2926         char buf[TYPE_CHARS(UV)];
2927         char *ebuf, *ptr;
2928         STRLEN len;
2929
2930         if (SvTYPE(sv) < SVt_PVIV)
2931             sv_upgrade(sv, SVt_PVIV);
2932         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2933         len = ebuf - ptr;
2934         /* inlined from sv_setpvn */
2935         s = SvGROW_mutable(sv, len + 1);
2936         Move(ptr, s, len, char);
2937         s += len;
2938         *s = '\0';
2939     }
2940     else if (SvNOKp(sv)) {
2941         dSAVE_ERRNO;
2942         if (SvTYPE(sv) < SVt_PVNV)
2943             sv_upgrade(sv, SVt_PVNV);
2944         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2945         s = SvGROW_mutable(sv, NV_DIG + 20);
2946         /* some Xenix systems wipe out errno here */
2947 #ifdef apollo
2948         if (SvNVX(sv) == 0.0)
2949             my_strlcpy(s, "0", SvLEN(sv));
2950         else
2951 #endif /*apollo*/
2952         {
2953             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2954         }
2955         RESTORE_ERRNO;
2956 #ifdef FIXNEGATIVEZERO
2957         if (*s == '-' && s[1] == '0' && !s[2]) {
2958             s[0] = '0';
2959             s[1] = 0;
2960         }
2961 #endif
2962         while (*s) s++;
2963 #ifdef hcx
2964         if (s[-1] == '.')
2965             *--s = '\0';
2966 #endif
2967     }
2968     else {
2969         if (isGV_with_GP(sv)) {
2970             GV *const gv = MUTABLE_GV(sv);
2971             const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2972             SV *const buffer = sv_newmortal();
2973
2974             /* FAKE globs can get coerced, so need to turn this off temporarily
2975                if it is on.  */
2976             SvFAKE_off(gv);
2977             gv_efullname3(buffer, gv, "*");
2978             SvFLAGS(gv) |= wasfake;
2979
2980             assert(SvPOK(buffer));
2981             if (lp) {
2982                 *lp = SvCUR(buffer);
2983             }
2984             return SvPVX(buffer);
2985         }
2986
2987         if (lp)
2988             *lp = 0;
2989         if (flags & SV_UNDEF_RETURNS_NULL)
2990             return NULL;
2991         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2992             report_uninit(sv);
2993         if (SvTYPE(sv) < SVt_PV)
2994             /* Typically the caller expects that sv_any is not NULL now.  */
2995             sv_upgrade(sv, SVt_PV);
2996         return (char *)"";
2997     }
2998     {
2999         const STRLEN len = s - SvPVX_const(sv);
3000         if (lp)
3001             *lp = len;
3002         SvCUR_set(sv, len);
3003     }
3004     SvPOK_on(sv);
3005     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3006                           PTR2UV(sv),SvPVX_const(sv)));
3007     if (flags & SV_CONST_RETURN)
3008         return (char *)SvPVX_const(sv);
3009     if (flags & SV_MUTABLE_RETURN)
3010         return SvPVX_mutable(sv);
3011     return SvPVX(sv);
3012 }
3013
3014 /*
3015 =for apidoc sv_copypv
3016
3017 Copies a stringified representation of the source SV into the
3018 destination SV.  Automatically performs any necessary mg_get and
3019 coercion of numeric values into strings.  Guaranteed to preserve
3020 UTF8 flag even from overloaded objects.  Similar in nature to
3021 sv_2pv[_flags] but operates directly on an SV instead of just the
3022 string.  Mostly uses sv_2pv_flags to do its work, except when that
3023 would lose the UTF-8'ness of the PV.
3024
3025 =cut
3026 */
3027
3028 void
3029 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3030 {
3031     STRLEN len;
3032     const char * const s = SvPV_const(ssv,len);
3033
3034     PERL_ARGS_ASSERT_SV_COPYPV;
3035
3036     sv_setpvn(dsv,s,len);
3037     if (SvUTF8(ssv))
3038         SvUTF8_on(dsv);
3039     else
3040         SvUTF8_off(dsv);
3041 }
3042
3043 /*
3044 =for apidoc sv_2pvbyte
3045
3046 Return a pointer to the byte-encoded representation of the SV, and set *lp
3047 to its length.  May cause the SV to be downgraded from UTF-8 as a
3048 side-effect.
3049
3050 Usually accessed via the C<SvPVbyte> macro.
3051
3052 =cut
3053 */
3054
3055 char *
3056 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3057 {
3058     PERL_ARGS_ASSERT_SV_2PVBYTE;
3059
3060     sv_utf8_downgrade(sv,0);
3061     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3062 }
3063
3064 /*
3065 =for apidoc sv_2pvutf8
3066
3067 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3068 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3069
3070 Usually accessed via the C<SvPVutf8> macro.
3071
3072 =cut
3073 */
3074
3075 char *
3076 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3077 {
3078     PERL_ARGS_ASSERT_SV_2PVUTF8;
3079
3080     sv_utf8_upgrade(sv);
3081     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3082 }
3083
3084
3085 /*
3086 =for apidoc sv_2bool
3087
3088 This function is only called on magical items, and is only used by
3089 sv_true() or its macro equivalent.
3090
3091 =cut
3092 */
3093
3094 bool
3095 Perl_sv_2bool(pTHX_ register SV *const sv)
3096 {
3097     dVAR;
3098
3099     PERL_ARGS_ASSERT_SV_2BOOL;
3100
3101     SvGETMAGIC(sv);
3102
3103     if (!SvOK(sv))
3104         return 0;
3105     if (SvROK(sv)) {
3106         if (SvAMAGIC(sv)) {
3107             SV * const tmpsv = AMG_CALLun(sv,bool_);
3108             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3109                 return (bool)SvTRUE(tmpsv);
3110         }
3111         return SvRV(sv) != 0;
3112     }
3113     if (SvPOKp(sv)) {
3114         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3115         if (Xpvtmp &&
3116                 (*sv->sv_u.svu_pv > '0' ||
3117                 Xpvtmp->xpv_cur > 1 ||
3118                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3119             return 1;
3120         else
3121             return 0;
3122     }
3123     else {
3124         if (SvIOKp(sv))
3125             return SvIVX(sv) != 0;
3126         else {
3127             if (SvNOKp(sv))
3128                 return SvNVX(sv) != 0.0;
3129             else {
3130                 if (isGV_with_GP(sv))
3131                     return TRUE;
3132                 else
3133                     return FALSE;
3134             }
3135         }
3136     }
3137 }
3138
3139 /*
3140 =for apidoc sv_utf8_upgrade
3141
3142 Converts the PV of an SV to its UTF-8-encoded form.
3143 Forces the SV to string form if it is not already.
3144 Will C<mg_get> on C<sv> if appropriate.
3145 Always sets the SvUTF8 flag to avoid future validity checks even
3146 if the whole string is the same in UTF-8 as not.
3147 Returns the number of bytes in the converted string
3148
3149 This is not as a general purpose byte encoding to Unicode interface:
3150 use the Encode extension for that.
3151
3152 =for apidoc sv_utf8_upgrade_nomg
3153
3154 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3155
3156 =for apidoc sv_utf8_upgrade_flags
3157
3158 Converts the PV of an SV to its UTF-8-encoded form.
3159 Forces the SV to string form if it is not already.
3160 Always sets the SvUTF8 flag to avoid future validity checks even
3161 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3162 will C<mg_get> on C<sv> if appropriate, else not.
3163 Returns the number of bytes in the converted string
3164 C<sv_utf8_upgrade> and
3165 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3166
3167 This is not as a general purpose byte encoding to Unicode interface:
3168 use the Encode extension for that.
3169
3170 =cut
3171
3172 The grow version is currently not externally documented.  It adds a parameter,
3173 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3174 have free after it upon return.  This allows the caller to reserve extra space
3175 that it intends to fill, to avoid extra grows.
3176
3177 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3178 which can be used to tell this function to not first check to see if there are
3179 any characters that are different in UTF-8 (variant characters) which would
3180 force it to allocate a new string to sv, but to assume there are.  Typically
3181 this flag is used by a routine that has already parsed the string to find that
3182 there are such characters, and passes this information on so that the work
3183 doesn't have to be repeated.
3184
3185 (One might think that the calling routine could pass in the position of the
3186 first such variant, so it wouldn't have to be found again.  But that is not the
3187 case, because typically when the caller is likely to use this flag, it won't be
3188 calling this routine unless it finds something that won't fit into a byte.
3189 Otherwise it tries to not upgrade and just use bytes.  But some things that
3190 do fit into a byte are variants in utf8, and the caller may not have been
3191 keeping track of these.)
3192
3193 If the routine itself changes the string, it adds a trailing NUL.  Such a NUL
3194 isn't guaranteed due to having other routines do the work in some input cases,
3195 or if the input is already flagged as being in utf8.
3196
3197 The speed of this could perhaps be improved for many cases if someone wanted to
3198 write a fast function that counts the number of variant characters in a string,
3199 especially if it could return the position of the first one.
3200
3201 */
3202
3203 STRLEN
3204 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3205 {
3206     dVAR;
3207
3208     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3209
3210     if (sv == &PL_sv_undef)
3211         return 0;
3212     if (!SvPOK(sv)) {
3213         STRLEN len = 0;
3214         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3215             (void) sv_2pv_flags(sv,&len, flags);
3216             if (SvUTF8(sv)) {
3217                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3218                 return len;
3219             }
3220         } else {
3221             (void) SvPV_force(sv,len);
3222         }
3223     }
3224
3225     if (SvUTF8(sv)) {
3226         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3227         return SvCUR(sv);
3228     }
3229
3230     if (SvIsCOW(sv)) {
3231         sv_force_normal_flags(sv, 0);
3232     }
3233
3234     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3235         sv_recode_to_utf8(sv, PL_encoding);
3236         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3237         return SvCUR(sv);
3238     }
3239
3240     if (SvCUR(sv) > 0) { /* 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         return SvCUR(sv);
3270
3271 must_be_utf8:
3272
3273         /* Here, the string should be converted to utf8, either because of an
3274          * input flag (two_byte_count = 0), or because a character that
3275          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3276          * the beginning of the string (if we didn't examine anything), or to
3277          * the first variant.  In either case, everything from s to t - 1 will
3278          * occupy only 1 byte each on output.
3279          *
3280          * There are two main ways to convert.  One is to create a new string
3281          * and go through the input starting from the beginning, appending each
3282          * converted value onto the new string as we go along.  It's probably
3283          * best to allocate enough space in the string for the worst possible
3284          * case rather than possibly running out of space and having to
3285          * reallocate and then copy what we've done so far.  Since everything
3286          * from s to t - 1 is invariant, the destination can be initialized
3287          * with these using a fast memory copy
3288          *
3289          * The other way is to figure out exactly how big the string should be
3290          * by parsing the entire input.  Then you don't have to make it big
3291          * enough to handle the worst possible case, and more importantly, if
3292          * the string you already have is large enough, you don't have to
3293          * allocate a new string, you can copy the last character in the input
3294          * string to the final position(s) that will be occupied by the
3295          * converted string and go backwards, stopping at t, since everything
3296          * before that is invariant.
3297          *
3298          * There are advantages and disadvantages to each method.
3299          *
3300          * In the first method, we can allocate a new string, do the memory
3301          * copy from the s to t - 1, and then proceed through the rest of the
3302          * string byte-by-byte.
3303          *
3304          * In the second method, we proceed through the rest of the input
3305          * string just calculating how big the converted string will be.  Then
3306          * there are two cases:
3307          *  1)  if the string has enough extra space to handle the converted
3308          *      value.  We go backwards through the string, converting until we
3309          *      get to the position we are at now, and then stop.  If this
3310          *      position is far enough along in the string, this method is
3311          *      faster than the other method.  If the memory copy were the same
3312          *      speed as the byte-by-byte loop, that position would be about
3313          *      half-way, as at the half-way mark, parsing to the end and back
3314          *      is one complete string's parse, the same amount as starting
3315          *      over and going all the way through.  Actually, it would be
3316          *      somewhat less than half-way, as it's faster to just count bytes
3317          *      than to also copy, and we don't have the overhead of allocating
3318          *      a new string, changing the scalar to use it, and freeing the
3319          *      existing one.  But if the memory copy is fast, the break-even
3320          *      point is somewhere after half way.  The counting loop could be
3321          *      sped up by vectorization, etc, to move the break-even point
3322          *      further towards the beginning.
3323          *  2)  if the string doesn't have enough space to handle the converted
3324          *      value.  A new string will have to be allocated, and one might
3325          *      as well, given that, start from the beginning doing the first
3326          *      method.  We've spent extra time parsing the string and in
3327          *      exchange all we've gotten is that we know precisely how big to
3328          *      make the new one.  Perl is more optimized for time than space,
3329          *      so this case is a loser.
3330          * So what I've decided to do is not use the 2nd method unless it is
3331          * guaranteed that a new string won't have to be allocated, assuming
3332          * the worst case.  I also decided not to put any more conditions on it
3333          * than this, for now.  It seems likely that, since the worst case is
3334          * twice as big as the unknown portion of the string (plus 1), we won't
3335          * be guaranteed enough space, causing us to go to the first method,
3336          * unless the string is short, or the first variant character is near
3337          * the end of it.  In either of these cases, it seems best to use the
3338          * 2nd method.  The only circumstance I can think of where this would
3339          * be really slower is if the string had once had much more data in it
3340          * than it does now, but there is still a substantial amount in it  */
3341
3342         {
3343             STRLEN invariant_head = t - s;
3344             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3345             if (SvLEN(sv) < size) {
3346
3347                 /* Here, have decided to allocate a new string */
3348
3349                 U8 *dst;
3350                 U8 *d;
3351
3352                 Newx(dst, size, U8);
3353
3354                 /* If no known invariants at the beginning of the input string,
3355                  * set so starts from there.  Otherwise, can use memory copy to
3356                  * get up to where we are now, and then start from here */
3357
3358                 if (invariant_head <= 0) {
3359                     d = dst;
3360                 } else {
3361                     Copy(s, dst, invariant_head, char);
3362                     d = dst + invariant_head;
3363                 }
3364
3365                 while (t < e) {
3366                     const UV uv = NATIVE8_TO_UNI(*t++);
3367                     if (UNI_IS_INVARIANT(uv))
3368                         *d++ = (U8)UNI_TO_NATIVE(uv);
3369                     else {
3370                         *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3371                         *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3372                     }
3373                 }
3374                 *d = '\0';
3375                 SvPV_free(sv); /* No longer using pre-existing string */
3376                 SvPV_set(sv, (char*)dst);
3377                 SvCUR_set(sv, d - dst);
3378                 SvLEN_set(sv, size);
3379             } else {
3380
3381                 /* Here, have decided to get the exact size of the string.
3382                  * Currently this happens only when we know that there is
3383                  * guaranteed enough space to fit the converted string, so
3384                  * don't have to worry about growing.  If two_byte_count is 0,
3385                  * then t points to the first byte of the string which hasn't
3386                  * been examined yet.  Otherwise two_byte_count is 1, and t
3387                  * points to the first byte in the string that will expand to
3388                  * two.  Depending on this, start examining at t or 1 after t.
3389                  * */
3390
3391                 U8 *d = t + two_byte_count;
3392
3393
3394                 /* Count up the remaining bytes that expand to two */
3395
3396                 while (d < e) {
3397                     const U8 chr = *d++;
3398                     if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3399                 }
3400
3401                 /* The string will expand by just the number of bytes that
3402                  * occupy two positions.  But we are one afterwards because of
3403                  * the increment just above.  This is the place to put the
3404                  * trailing NUL, and to set the length before we decrement */
3405
3406                 d += two_byte_count;
3407                 SvCUR_set(sv, d - s);
3408                 *d-- = '\0';
3409
3410
3411                 /* Having decremented d, it points to the position to put the
3412                  * very last byte of the expanded string.  Go backwards through
3413                  * the string, copying and expanding as we go, stopping when we
3414                  * get to the part that is invariant the rest of the way down */
3415
3416                 e--;
3417                 while (e >= t) {
3418                     const U8 ch = NATIVE8_TO_UNI(*e--);
3419                     if (UNI_IS_INVARIANT(ch)) {
3420                         *d-- = UNI_TO_NATIVE(ch);
3421                     } else {
3422                         *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3423                         *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3424                     }
3425                 }
3426             }
3427         }
3428     }
3429
3430     /* Mark as UTF-8 even if no variant - saves scanning loop */
3431     SvUTF8_on(sv);
3432     return SvCUR(sv);
3433 }
3434
3435 /*
3436 =for apidoc sv_utf8_downgrade
3437
3438 Attempts to convert the PV of an SV from characters to bytes.
3439 If the PV contains a character that cannot fit
3440 in a byte, this conversion will fail;
3441 in this case, either returns false or, if C<fail_ok> is not
3442 true, croaks.
3443
3444 This is not as a general purpose Unicode to byte encoding interface:
3445 use the Encode extension for that.
3446
3447 =cut
3448 */
3449
3450 bool
3451 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3452 {
3453     dVAR;
3454
3455     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3456
3457     if (SvPOKp(sv) && SvUTF8(sv)) {
3458         if (SvCUR(sv)) {
3459             U8 *s;
3460             STRLEN len;
3461
3462             if (SvIsCOW(sv)) {
3463                 sv_force_normal_flags(sv, 0);
3464             }
3465             s = (U8 *) SvPV(sv, len);
3466             if (!utf8_to_bytes(s, &len)) {
3467                 if (fail_ok)
3468                     return FALSE;
3469                 else {
3470                     if (PL_op)
3471                         Perl_croak(aTHX_ "Wide character in %s",
3472                                    OP_DESC(PL_op));
3473                     else
3474                         Perl_croak(aTHX_ "Wide character");
3475                 }
3476             }
3477             SvCUR_set(sv, len);
3478         }
3479     }
3480     SvUTF8_off(sv);
3481     return TRUE;
3482 }
3483
3484 /*
3485 =for apidoc sv_utf8_encode
3486
3487 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3488 flag off so that it looks like octets again.
3489
3490 =cut
3491 */
3492
3493 void
3494 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3495 {
3496     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3497
3498     if (SvIsCOW(sv)) {
3499         sv_force_normal_flags(sv, 0);
3500     }
3501     if (SvREADONLY(sv)) {
3502         Perl_croak(aTHX_ "%s", PL_no_modify);
3503     }
3504     (void) sv_utf8_upgrade(sv);
3505     SvUTF8_off(sv);
3506 }
3507
3508 /*
3509 =for apidoc sv_utf8_decode
3510
3511 If the PV of the SV is an octet sequence in UTF-8
3512 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3513 so that it looks like a character. If the PV contains only single-byte
3514 characters, the C<SvUTF8> flag stays being off.
3515 Scans PV for validity and returns false if the PV is invalid UTF-8.
3516
3517 =cut
3518 */
3519
3520 bool
3521 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3522 {
3523     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3524
3525     if (SvPOKp(sv)) {
3526         const U8 *c;
3527         const U8 *e;
3528
3529         /* The octets may have got themselves encoded - get them back as
3530          * bytes
3531          */
3532         if (!sv_utf8_downgrade(sv, TRUE))
3533             return FALSE;
3534
3535         /* it is actually just a matter of turning the utf8 flag on, but
3536          * we want to make sure everything inside is valid utf8 first.
3537          */
3538         c = (const U8 *) SvPVX_const(sv);
3539         if (!is_utf8_string(c, SvCUR(sv)+1))
3540             return FALSE;
3541         e = (const U8 *) SvEND(sv);
3542         while (c < e) {
3543             const U8 ch = *c++;
3544             if (!UTF8_IS_INVARIANT(ch)) {
3545                 SvUTF8_on(sv);
3546                 break;
3547             }
3548         }
3549     }
3550     return TRUE;
3551 }
3552
3553 /*
3554 =for apidoc sv_setsv
3555
3556 Copies the contents of the source SV C<ssv> into the destination SV
3557 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3558 function if the source SV needs to be reused. Does not handle 'set' magic.
3559 Loosely speaking, it performs a copy-by-value, obliterating any previous
3560 content of the destination.
3561
3562 You probably want to use one of the assortment of wrappers, such as
3563 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3564 C<SvSetMagicSV_nosteal>.
3565
3566 =for apidoc sv_setsv_flags
3567
3568 Copies the contents of the source SV C<ssv> into the destination SV
3569 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3570 function if the source SV needs to be reused. Does not handle 'set' magic.
3571 Loosely speaking, it performs a copy-by-value, obliterating any previous
3572 content of the destination.
3573 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3574 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3575 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3576 and C<sv_setsv_nomg> are implemented in terms of this function.
3577
3578 You probably want to use one of the assortment of wrappers, such as
3579 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3580 C<SvSetMagicSV_nosteal>.
3581
3582 This is the primary function for copying scalars, and most other
3583 copy-ish functions and macros use this underneath.
3584
3585 =cut
3586 */
3587
3588 static void
3589 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3590 {
3591     I32 mro_changes = 0; /* 1 = method, 2 = isa */
3592
3593     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3594
3595     if (dtype != SVt_PVGV) {
3596         const char * const name = GvNAME(sstr);
3597         const STRLEN len = GvNAMELEN(sstr);
3598         {
3599             if (dtype >= SVt_PV) {
3600                 SvPV_free(dstr);
3601                 SvPV_set(dstr, 0);
3602                 SvLEN_set(dstr, 0);
3603                 SvCUR_set(dstr, 0);
3604             }
3605             SvUPGRADE(dstr, SVt_PVGV);
3606             (void)SvOK_off(dstr);
3607             /* FIXME - why are we doing this, then turning it off and on again
3608                below?  */
3609             isGV_with_GP_on(dstr);
3610         }
3611         GvSTASH(dstr) = GvSTASH(sstr);
3612         if (GvSTASH(dstr))
3613             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3614         gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3615         SvFAKE_on(dstr);        /* can coerce to non-glob */
3616     }
3617
3618     if(GvGP(MUTABLE_GV(sstr))) {
3619         /* If source has method cache entry, clear it */
3620         if(GvCVGEN(sstr)) {
3621             SvREFCNT_dec(GvCV(sstr));
3622             GvCV(sstr) = NULL;
3623             GvCVGEN(sstr) = 0;
3624         }
3625         /* If source has a real method, then a method is
3626            going to change */
3627         else if(GvCV((const GV *)sstr)) {
3628             mro_changes = 1;
3629         }
3630     }
3631
3632     /* If dest already had a real method, that's a change as well */
3633     if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3634         mro_changes = 1;
3635     }
3636
3637     if(strEQ(GvNAME((const GV *)dstr),"ISA"))
3638         mro_changes = 2;
3639
3640     gp_free(MUTABLE_GV(dstr));
3641     isGV_with_GP_off(dstr);
3642     (void)SvOK_off(dstr);
3643     isGV_with_GP_on(dstr);
3644     GvINTRO_off(dstr);          /* one-shot flag */
3645     GvGP(dstr) = gp_ref(GvGP(sstr));
3646     if (SvTAINTED(sstr))
3647         SvTAINT(dstr);
3648     if (GvIMPORTED(dstr) != GVf_IMPORTED
3649         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3650         {
3651             GvIMPORTED_on(dstr);
3652         }
3653     GvMULTI_on(dstr);
3654     if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3655     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3656     return;
3657 }
3658
3659 static void
3660 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3661 {
3662     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3663     SV *dref = NULL;
3664     const int intro = GvINTRO(dstr);
3665     SV **location;
3666     U8 import_flag = 0;
3667     const U32 stype = SvTYPE(sref);
3668
3669     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3670
3671     if (intro) {
3672         GvINTRO_off(dstr);      /* one-shot flag */
3673         GvLINE(dstr) = CopLINE(PL_curcop);
3674         GvEGV(dstr) = MUTABLE_GV(dstr);
3675     }
3676     GvMULTI_on(dstr);
3677     switch (stype) {
3678     case SVt_PVCV:
3679         location = (SV **) &GvCV(dstr);
3680         import_flag = GVf_IMPORTED_CV;
3681         goto common;
3682     case SVt_PVHV:
3683         location = (SV **) &GvHV(dstr);
3684         import_flag = GVf_IMPORTED_HV;
3685         goto common;
3686     case SVt_PVAV:
3687         location = (SV **) &GvAV(dstr);
3688         import_flag = GVf_IMPORTED_AV;
3689         goto common;
3690     case SVt_PVIO:
3691         location = (SV **) &GvIOp(dstr);
3692         goto common;
3693     case SVt_PVFM:
3694         location = (SV **) &GvFORM(dstr);
3695     default:
3696         location = &GvSV(dstr);
3697         import_flag = GVf_IMPORTED_SV;
3698     common:
3699         if (intro) {
3700             if (stype == SVt_PVCV) {
3701                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3702                 if (GvCVGEN(dstr)) {
3703                     SvREFCNT_dec(GvCV(dstr));
3704                     GvCV(dstr) = NULL;
3705                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3706                 }
3707             }
3708             SAVEGENERICSV(*location);
3709         }
3710         else
3711             dref = *location;
3712         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3713             CV* const cv = MUTABLE_CV(*location);
3714             if (cv) {
3715                 if (!GvCVGEN((const GV *)dstr) &&
3716                     (CvROOT(cv) || CvXSUB(cv)))
3717                     {
3718                         /* Redefining a sub - warning is mandatory if
3719                            it was a const and its value changed. */
3720                         if (CvCONST(cv) && CvCONST((const CV *)sref)
3721                             && cv_const_sv(cv)
3722                             == cv_const_sv((const CV *)sref)) {
3723                             NOOP;
3724                             /* They are 2 constant subroutines generated from
3725                                the same constant. This probably means that
3726                                they are really the "same" proxy subroutine
3727                                instantiated in 2 places. Most likely this is
3728                                when a constant is exported twice.  Don't warn.
3729                             */
3730                         }
3731                         else if (ckWARN(WARN_REDEFINE)
3732                                  || (CvCONST(cv)
3733                                      && (!CvCONST((const CV *)sref)
3734                                          || sv_cmp(cv_const_sv(cv),
3735                                                    cv_const_sv((const CV *)
3736                                                                sref))))) {
3737                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3738                                         (const char *)
3739                                         (CvCONST(cv)
3740                                          ? "Constant subroutine %s::%s redefined"
3741                                          : "Subroutine %s::%s redefined"),
3742                                         HvNAME_get(GvSTASH((const GV *)dstr)),
3743                                         GvENAME(MUTABLE_GV(dstr)));
3744                         }
3745                     }
3746                 if (!intro)
3747                     cv_ckproto_len(cv, (const GV *)dstr,
3748                                    SvPOK(sref) ? SvPVX_const(sref) : NULL,
3749                                    SvPOK(sref) ? SvCUR(sref) : 0);
3750             }
3751             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3752             GvASSUMECV_on(dstr);
3753             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3754         }
3755         *location = sref;
3756         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3757             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3758             GvFLAGS(dstr) |= import_flag;
3759         }
3760         break;
3761     }
3762     SvREFCNT_dec(dref);
3763     if (SvTAINTED(sstr))
3764         SvTAINT(dstr);
3765     return;
3766 }
3767
3768 void
3769 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3770 {
3771     dVAR;
3772     register U32 sflags;
3773     register int dtype;
3774     register svtype stype;
3775
3776     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3777
3778     if (sstr == dstr)
3779         return;
3780
3781     if (SvIS_FREED(dstr)) {
3782         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3783                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3784     }
3785     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3786     if (!sstr)
3787         sstr = &PL_sv_undef;
3788     if (SvIS_FREED(sstr)) {
3789         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3790                    (void*)sstr, (void*)dstr);
3791     }
3792     stype = SvTYPE(sstr);
3793     dtype = SvTYPE(dstr);
3794
3795     (void)SvAMAGIC_off(dstr);
3796     if ( SvVOK(dstr) )
3797     {
3798         /* need to nuke the magic */
3799         mg_free(dstr);
3800     }
3801
3802     /* There's a lot of redundancy below but we're going for speed here */
3803
3804     switch (stype) {
3805     case SVt_NULL:
3806       undef_sstr:
3807         if (dtype != SVt_PVGV) {
3808             (void)SvOK_off(dstr);
3809             return;
3810         }
3811         break;
3812     case SVt_IV:
3813         if (SvIOK(sstr)) {
3814             switch (dtype) {
3815             case SVt_NULL:
3816                 sv_upgrade(dstr, SVt_IV);
3817                 break;
3818             case SVt_NV:
3819             case SVt_PV:
3820                 sv_upgrade(dstr, SVt_PVIV);
3821                 break;
3822             case SVt_PVGV:
3823                 goto end_of_first_switch;
3824             }
3825             (void)SvIOK_only(dstr);
3826             SvIV_set(dstr,  SvIVX(sstr));
3827             if (SvIsUV(sstr))
3828                 SvIsUV_on(dstr);
3829             /* SvTAINTED can only be true if the SV has taint magic, which in
3830                turn means that the SV type is PVMG (or greater). This is the
3831                case statement for SVt_IV, so this cannot be true (whatever gcov
3832                may say).  */
3833             assert(!SvTAINTED(sstr));
3834             return;
3835         }
3836         if (!SvROK(sstr))
3837             goto undef_sstr;
3838         if (dtype < SVt_PV && dtype != SVt_IV)
3839             sv_upgrade(dstr, SVt_IV);
3840         break;
3841
3842     case SVt_NV:
3843         if (SvNOK(sstr)) {
3844             switch (dtype) {
3845             case SVt_NULL:
3846             case SVt_IV:
3847                 sv_upgrade(dstr, SVt_NV);
3848                 break;
3849             case SVt_PV:
3850             case SVt_PVIV:
3851                 sv_upgrade(dstr, SVt_PVNV);
3852                 break;
3853             case SVt_PVGV:
3854                 goto end_of_first_switch;
3855             }
3856             SvNV_set(dstr, SvNVX(sstr));
3857             (void)SvNOK_only(dstr);
3858             /* SvTAINTED can only be true if the SV has taint magic, which in
3859                turn means that the SV type is PVMG (or greater). This is the
3860                case statement for SVt_NV, so this cannot be true (whatever gcov
3861                may say).  */
3862             assert(!SvTAINTED(sstr));
3863             return;
3864         }
3865         goto undef_sstr;
3866
3867     case SVt_PVFM:
3868 #ifdef PERL_OLD_COPY_ON_WRITE
3869         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3870             if (dtype < SVt_PVIV)
3871                 sv_upgrade(dstr, SVt_PVIV);
3872             break;
3873         }
3874         /* Fall through */
3875 #endif
3876     case SVt_REGEXP:
3877     case SVt_PV:
3878         if (dtype < SVt_PV)
3879             sv_upgrade(dstr, SVt_PV);
3880         break;
3881     case SVt_PVIV:
3882         if (dtype < SVt_PVIV)
3883             sv_upgrade(dstr, SVt_PVIV);
3884         break;
3885     case SVt_PVNV:
3886         if (dtype < SVt_PVNV)
3887             sv_upgrade(dstr, SVt_PVNV);
3888         break;
3889     default:
3890         {
3891         const char * const type = sv_reftype(sstr,0);
3892         if (PL_op)
3893             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3894         else
3895             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3896         }
3897         break;
3898
3899         /* case SVt_BIND: */
3900     case SVt_PVLV:
3901     case SVt_PVGV:
3902         if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3903             glob_assign_glob(dstr, sstr, dtype);
3904             return;
3905         }
3906         /* SvVALID means that this PVGV is playing at being an FBM.  */
3907         /*FALLTHROUGH*/
3908
3909     case SVt_PVMG:
3910         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3911             mg_get(sstr);
3912             if (SvTYPE(sstr) != stype) {
3913                 stype = SvTYPE(sstr);
3914                 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3915                     glob_assign_glob(dstr, sstr, dtype);
3916                     return;
3917                 }
3918             }
3919         }
3920         if (stype == SVt_PVLV)
3921             SvUPGRADE(dstr, SVt_PVNV);
3922         else
3923             SvUPGRADE(dstr, (svtype)stype);
3924     }
3925  end_of_first_switch:
3926
3927     /* dstr may have been upgraded.  */
3928     dtype = SvTYPE(dstr);
3929     sflags = SvFLAGS(sstr);
3930
3931     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3932         /* Assigning to a subroutine sets the prototype.  */
3933         if (SvOK(sstr)) {
3934             STRLEN len;
3935             const char *const ptr = SvPV_const(sstr, len);
3936
3937             SvGROW(dstr, len + 1);
3938             Copy(ptr, SvPVX(dstr), len + 1, char);
3939             SvCUR_set(dstr, len);
3940             SvPOK_only(dstr);
3941             SvFLAGS(dstr) |= sflags & SVf_UTF8;
3942         } else {
3943             SvOK_off(dstr);
3944         }
3945     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3946         const char * const type = sv_reftype(dstr,0);
3947         if (PL_op)
3948             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3949         else
3950             Perl_croak(aTHX_ "Cannot copy to %s", type);
3951     } else if (sflags & SVf_ROK) {
3952         if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3953             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3954             sstr = SvRV(sstr);
3955             if (sstr == dstr) {
3956                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3957                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3958                 {
3959                     GvIMPORTED_on(dstr);
3960                 }
3961                 GvMULTI_on(dstr);
3962                 return;
3963             }
3964             glob_assign_glob(dstr, sstr, dtype);
3965             return;
3966         }
3967
3968         if (dtype >= SVt_PV) {
3969             if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3970                 glob_assign_ref(dstr, sstr);
3971                 return;
3972             }
3973             if (SvPVX_const(dstr)) {
3974                 SvPV_free(dstr);
3975                 SvLEN_set(dstr, 0);
3976                 SvCUR_set(dstr, 0);
3977             }
3978         }
3979         (void)SvOK_off(dstr);
3980         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3981         SvFLAGS(dstr) |= sflags & SVf_ROK;
3982         assert(!(sflags & SVp_NOK));
3983         assert(!(sflags & SVp_IOK));
3984         assert(!(sflags & SVf_NOK));
3985         assert(!(sflags & SVf_IOK));
3986     }
3987     else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3988         if (!(sflags & SVf_OK)) {
3989             if (ckWARN(WARN_MISC))
3990                 Perl_warner(aTHX_ packWARN(WARN_MISC),
3991                             "Undefined value assigned to typeglob");
3992         }
3993         else {
3994             GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3995             if (dstr != (const SV *)gv) {
3996                 if (GvGP(dstr))
3997                     gp_free(MUTABLE_GV(dstr));
3998                 GvGP(dstr) = gp_ref(GvGP(gv));
3999             }
4000         }
4001     }
4002     else if (sflags & SVp_POK) {
4003         bool isSwipe = 0;
4004
4005         /*
4006          * Check to see if we can just swipe the string.  If so, it's a
4007          * possible small lose on short strings, but a big win on long ones.
4008          * It might even be a win on short strings if SvPVX_const(dstr)
4009          * has to be allocated and SvPVX_const(sstr) has to be freed.
4010          * Likewise if we can set up COW rather than doing an actual copy, we
4011          * drop to the else clause, as the swipe code and the COW setup code
4012          * have much in common.
4013          */
4014
4015         /* Whichever path we take through the next code, we want this true,
4016            and doing it now facilitates the COW check.  */
4017         (void)SvPOK_only(dstr);
4018
4019         if (
4020             /* If we're already COW then this clause is not true, and if COW
4021                is allowed then we drop down to the else and make dest COW
4022                with us.  If caller hasn't said that we're allowed to COW
4023                shared hash keys then we don't do the COW setup, even if the
4024                source scalar is a shared hash key scalar.  */
4025             (((flags & SV_COW_SHARED_HASH_KEYS)
4026                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4027                : 1 /* If making a COW copy is forbidden then the behaviour we
4028                        desire is as if the source SV isn't actually already
4029                        COW, even if it is.  So we act as if the source flags
4030                        are not COW, rather than actually testing them.  */
4031               )
4032 #ifndef PERL_OLD_COPY_ON_WRITE
4033              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4034                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4035                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4036                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4037                 but in turn, it's somewhat dead code, never expected to go
4038                 live, but more kept as a placeholder on how to do it better
4039                 in a newer implementation.  */
4040              /* If we are COW and dstr is a suitable target then we drop down
4041                 into the else and make dest a COW of us.  */
4042              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4043 #endif
4044              )
4045             &&
4046             !(isSwipe =
4047                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4048                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4049                  (!(flags & SV_NOSTEAL)) &&
4050                                         /* and we're allowed to steal temps */
4051                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4052                  SvLEN(sstr)    &&        /* and really is a string */
4053                                 /* and won't be needed again, potentially */
4054               !(PL_op && PL_op->op_type == OP_AASSIGN))
4055 #ifdef PERL_OLD_COPY_ON_WRITE
4056             && ((flags & SV_COW_SHARED_HASH_KEYS)
4057                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4058                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4059                      && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4060                 : 1)
4061 #endif
4062             ) {
4063             /* Failed the swipe test, and it's not a shared hash key either.
4064                Have to copy the string.  */
4065             STRLEN len = SvCUR(sstr);
4066             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4067             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4068             SvCUR_set(dstr, len);
4069             *SvEND(dstr) = '\0';
4070         } else {
4071             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4072                be true in here.  */
4073             /* Either it's a shared hash key, or it's suitable for
4074                copy-on-write or we can swipe the string.  */
4075             if (DEBUG_C_TEST) {
4076                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4077                 sv_dump(sstr);
4078                 sv_dump(dstr);
4079             }
4080 #ifdef PERL_OLD_COPY_ON_WRITE
4081             if (!isSwipe) {
4082                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4083                     != (SVf_FAKE | SVf_READONLY)) {
4084                     SvREADONLY_on(sstr);
4085                     SvFAKE_on(sstr);
4086                     /* Make the source SV into a loop of 1.
4087                        (about to become 2) */
4088                     SV_COW_NEXT_SV_SET(sstr, sstr);
4089                 }
4090             }
4091 #endif
4092             /* Initial code is common.  */
4093             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4094                 SvPV_free(dstr);
4095             }
4096
4097             if (!isSwipe) {
4098                 /* making another shared SV.  */
4099                 STRLEN cur = SvCUR(sstr);
4100                 STRLEN len = SvLEN(sstr);
4101 #ifdef PERL_OLD_COPY_ON_WRITE
4102                 if (len) {
4103                     assert (SvTYPE(dstr) >= SVt_PVIV);
4104                     /* SvIsCOW_normal */
4105                     /* splice us in between source and next-after-source.  */
4106                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4107                     SV_COW_NEXT_SV_SET(sstr, dstr);
4108                     SvPV_set(dstr, SvPVX_mutable(sstr));
4109                 } else
4110 #endif
4111                 {
4112                     /* SvIsCOW_shared_hash */
4113                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4114                                           "Copy on write: Sharing hash\n"));
4115
4116                     assert (SvTYPE(dstr) >= SVt_PV);
4117                     SvPV_set(dstr,
4118                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4119                 }
4120                 SvLEN_set(dstr, len);
4121                 SvCUR_set(dstr, cur);
4122                 SvREADONLY_on(dstr);
4123                 SvFAKE_on(dstr);
4124             }
4125             else
4126                 {       /* Passes the swipe test.  */
4127                 SvPV_set(dstr, SvPVX_mutable(sstr));
4128                 SvLEN_set(dstr, SvLEN(sstr));
4129                 SvCUR_set(dstr, SvCUR(sstr));
4130
4131                 SvTEMP_off(dstr);
4132                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4133                 SvPV_set(sstr, NULL);
4134                 SvLEN_set(sstr, 0);
4135                 SvCUR_set(sstr, 0);
4136                 SvTEMP_off(sstr);
4137             }
4138         }
4139         if (sflags & SVp_NOK) {
4140             SvNV_set(dstr, SvNVX(sstr));
4141         }
4142         if (sflags & SVp_IOK) {
4143             SvIV_set(dstr, SvIVX(sstr));
4144             /* Must do this otherwise some other overloaded use of 0x80000000
4145                gets confused. I guess SVpbm_VALID */
4146             if (sflags & SVf_IVisUV)
4147                 SvIsUV_on(dstr);
4148         }
4149         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4150         {
4151             const MAGIC * const smg = SvVSTRING_mg(sstr);
4152             if (smg) {
4153                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4154                          smg->mg_ptr, smg->mg_len);
4155                 SvRMAGICAL_on(dstr);
4156             }
4157         }
4158     }
4159     else if (sflags & (SVp_IOK|SVp_NOK)) {
4160         (void)SvOK_off(dstr);
4161         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4162         if (sflags & SVp_IOK) {
4163             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4164             SvIV_set(dstr, SvIVX(sstr));
4165         }
4166         if (sflags & SVp_NOK) {
4167             SvNV_set(dstr, SvNVX(sstr));
4168         }
4169     }
4170     else {
4171         if (isGV_with_GP(sstr)) {
4172             /* This stringification rule for globs is spread in 3 places.
4173                This feels bad. FIXME.  */
4174             const U32 wasfake = sflags & SVf_FAKE;
4175
4176             /* FAKE globs can get coerced, so need to turn this off
4177                temporarily if it is on.  */
4178             SvFAKE_off(sstr);
4179             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4180             SvFLAGS(sstr) |= wasfake;
4181         }
4182         else
4183             (void)SvOK_off(dstr);
4184     }
4185     if (SvTAINTED(sstr))
4186         SvTAINT(dstr);
4187 }
4188
4189 /*
4190 =for apidoc sv_setsv_mg
4191
4192 Like C<sv_setsv>, but also handles 'set' magic.
4193
4194 =cut
4195 */
4196
4197 void
4198 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4199 {
4200     PERL_ARGS_ASSERT_SV_SETSV_MG;
4201
4202     sv_setsv(dstr,sstr);
4203     SvSETMAGIC(dstr);
4204 }
4205
4206 #ifdef PERL_OLD_COPY_ON_WRITE
4207 SV *
4208 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4209 {
4210     STRLEN cur = SvCUR(sstr);
4211     STRLEN len = SvLEN(sstr);
4212     register char *new_pv;
4213
4214     PERL_ARGS_ASSERT_SV_SETSV_COW;
4215
4216     if (DEBUG_C_TEST) {
4217         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4218                       (void*)sstr, (void*)dstr);
4219         sv_dump(sstr);
4220         if (dstr)
4221                     sv_dump(dstr);
4222     }
4223
4224     if (dstr) {
4225         if (SvTHINKFIRST(dstr))
4226             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4227         else if (SvPVX_const(dstr))
4228             Safefree(SvPVX_const(dstr));
4229     }
4230     else
4231         new_SV(dstr);
4232     SvUPGRADE(dstr, SVt_PVIV);
4233
4234     assert (SvPOK(sstr));
4235     assert (SvPOKp(sstr));
4236     assert (!SvIOK(sstr));
4237     assert (!SvIOKp(sstr));
4238     assert (!SvNOK(sstr));
4239     assert (!SvNOKp(sstr));
4240
4241     if (SvIsCOW(sstr)) {
4242
4243         if (SvLEN(sstr) == 0) {
4244             /* source is a COW shared hash key.  */
4245             DEBUG_C(PerlIO_printf(Perl_debug_log,
4246                                   "Fast copy on write: Sharing hash\n"));
4247             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4248             goto common_exit;
4249         }
4250         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4251     } else {
4252         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4253         SvUPGRADE(sstr, SVt_PVIV);
4254         SvREADONLY_on(sstr);
4255         SvFAKE_on(sstr);
4256         DEBUG_C(PerlIO_printf(Perl_debug_log,
4257                               "Fast copy on write: Converting sstr to COW\n"));
4258         SV_COW_NEXT_SV_SET(dstr, sstr);
4259     }
4260     SV_COW_NEXT_SV_SET(sstr, dstr);
4261     new_pv = SvPVX_mutable(sstr);
4262
4263   common_exit:
4264     SvPV_set(dstr, new_pv);
4265     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4266     if (SvUTF8(sstr))
4267         SvUTF8_on(dstr);
4268     SvLEN_set(dstr, len);
4269     SvCUR_set(dstr, cur);
4270     if (DEBUG_C_TEST) {
4271         sv_dump(dstr);
4272     }
4273     return dstr;
4274 }
4275 #endif
4276
4277 /*
4278 =for apidoc sv_setpvn
4279
4280 Copies a string into an SV.  The C<len> parameter indicates the number of
4281 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4282 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4283
4284 =cut
4285 */
4286
4287 void
4288 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4289 {
4290     dVAR;
4291     register char *dptr;
4292
4293     PERL_ARGS_ASSERT_SV_SETPVN;
4294
4295     SV_CHECK_THINKFIRST_COW_DROP(sv);
4296     if (!ptr) {
4297         (void)SvOK_off(sv);
4298         return;
4299     }
4300     else {
4301         /* len is STRLEN which is unsigned, need to copy to signed */
4302         const IV iv = len;
4303         if (iv < 0)
4304             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4305     }
4306     SvUPGRADE(sv, SVt_PV);
4307
4308     dptr = SvGROW(sv, len + 1);
4309     Move(ptr,dptr,len,char);
4310     dptr[len] = '\0';
4311     SvCUR_set(sv, len);
4312     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4313     SvTAINT(sv);
4314 }
4315
4316 /*
4317 =for apidoc sv_setpvn_mg
4318
4319 Like C<sv_setpvn>, but also handles 'set' magic.
4320
4321 =cut
4322 */
4323
4324 void
4325 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4326 {
4327     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4328
4329     sv_setpvn(sv,ptr,len);
4330     SvSETMAGIC(sv);
4331 }
4332
4333 /*
4334 =for apidoc sv_setpv
4335
4336 Copies a string into an SV.  The string must be null-terminated.  Does not
4337 handle 'set' magic.  See C<sv_setpv_mg>.
4338
4339 =cut
4340 */
4341
4342 void
4343 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4344 {
4345     dVAR;
4346     register STRLEN len;
4347
4348     PERL_ARGS_ASSERT_SV_SETPV;
4349
4350     SV_CHECK_THINKFIRST_COW_DROP(sv);
4351     if (!ptr) {
4352         (void)SvOK_off(sv);
4353         return;
4354     }
4355     len = strlen(ptr);
4356     SvUPGRADE(sv, SVt_PV);
4357
4358     SvGROW(sv, len + 1);
4359     Move(ptr,SvPVX(sv),len+1,char);
4360     SvCUR_set(sv, len);
4361     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4362     SvTAINT(sv);
4363 }
4364
4365 /*
4366 =for apidoc sv_setpv_mg
4367
4368 Like C<sv_setpv>, but also handles 'set' magic.
4369
4370 =cut
4371 */
4372
4373 void
4374 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4375 {
4376     PERL_ARGS_ASSERT_SV_SETPV_MG;
4377
4378     sv_setpv(sv,ptr);
4379     SvSETMAGIC(sv);
4380 }
4381
4382 /*
4383 =for apidoc sv_usepvn_flags
4384
4385 Tells an SV to use C<ptr> to find its string value.  Normally the
4386 string is stored inside the SV but sv_usepvn allows the SV to use an
4387 outside string.  The C<ptr> should point to memory that was allocated
4388 by C<malloc>.  The string length, C<len>, must be supplied.  By default
4389 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4390 so that pointer should not be freed or used by the programmer after
4391 giving it to sv_usepvn, and neither should any pointers from "behind"
4392 that pointer (e.g. ptr + 1) be used.
4393
4394 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4395 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4396 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4397 C<len>, and already meets the requirements for storing in C<SvPVX>)
4398
4399 =cut
4400 */
4401
4402 void
4403 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4404 {
4405     dVAR;
4406     STRLEN allocate;
4407
4408     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4409
4410     SV_CHECK_THINKFIRST_COW_DROP(sv);
4411     SvUPGRADE(sv, SVt_PV);
4412     if (!ptr) {
4413         (void)SvOK_off(sv);
4414         if (flags & SV_SMAGIC)
4415             SvSETMAGIC(sv);
4416         return;
4417     }
4418     if (SvPVX_const(sv))
4419         SvPV_free(sv);
4420
4421 #ifdef DEBUGGING
4422     if (flags & SV_HAS_TRAILING_NUL)
4423         assert(ptr[len] == '\0');
4424 #endif
4425
4426     allocate = (flags & SV_HAS_TRAILING_NUL)
4427         ? len + 1 :
4428 #ifdef Perl_safesysmalloc_size
4429         len + 1;
4430 #else
4431         PERL_STRLEN_ROUNDUP(len + 1);
4432 #endif
4433     if (flags & SV_HAS_TRAILING_NUL) {
4434         /* It's long enough - do nothing.
4435            Specfically Perl_newCONSTSUB is relying on this.  */
4436     } else {
4437 #ifdef DEBUGGING
4438         /* Force a move to shake out bugs in callers.  */
4439         char *new_ptr = (char*)safemalloc(allocate);
4440         Copy(ptr, new_ptr, len, char);
4441         PoisonFree(ptr,len,char);
4442         Safefree(ptr);
4443         ptr = new_ptr;
4444 #else
4445         ptr = (char*) saferealloc (ptr, allocate);
4446 #endif
4447     }
4448 #ifdef Perl_safesysmalloc_size
4449     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4450 #else
4451     SvLEN_set(sv, allocate);
4452 #endif
4453     SvCUR_set(sv, len);
4454     SvPV_set(sv, ptr);
4455     if (!(flags & SV_HAS_TRAILING_NUL)) {
4456         ptr[len] = '\0';
4457     }
4458     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4459     SvTAINT(sv);
4460     if (flags & SV_SMAGIC)
4461         SvSETMAGIC(sv);
4462 }
4463
4464 #ifdef PERL_OLD_COPY_ON_WRITE
4465 /* Need to do this *after* making the SV normal, as we need the buffer
4466    pointer to remain valid until after we've copied it.  If we let go too early,
4467    another thread could invalidate it by unsharing last of the same hash key
4468    (which it can do by means other than releasing copy-on-write Svs)
4469    or by changing the other copy-on-write SVs in the loop.  */
4470 STATIC void
4471 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4472 {
4473     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4474
4475     { /* this SV was SvIsCOW_normal(sv) */
4476          /* we need to find the SV pointing to us.  */
4477         SV *current = SV_COW_NEXT_SV(after);
4478
4479         if (current == sv) {
4480             /* The SV we point to points back to us (there were only two of us
4481                in the loop.)
4482                Hence other SV is no longer copy on write either.  */
4483             SvFAKE_off(after);
4484             SvREADONLY_off(after);
4485         } else {
4486             /* We need to follow the pointers around the loop.  */
4487             SV *next;
4488             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4489                 assert (next);
4490                 current = next;
4491                  /* don't loop forever if the structure is bust, and we have
4492                     a pointer into a closed loop.  */
4493                 assert (current != after);
4494                 assert (SvPVX_const(current) == pvx);
4495             }
4496             /* Make the SV before us point to the SV after us.  */
4497             SV_COW_NEXT_SV_SET(current, after);
4498         }
4499     }
4500 }
4501 #endif
4502 /*
4503 =for apidoc sv_force_normal_flags
4504
4505 Undo various types of fakery on an SV: if the PV is a shared string, make
4506 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4507 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4508 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4509 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4510 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4511 set to some other value.) In addition, the C<flags> parameter gets passed to
4512 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4513 with flags set to 0.
4514
4515 =cut
4516 */
4517
4518 void
4519 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4520 {
4521     dVAR;
4522
4523     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4524
4525 #ifdef PERL_OLD_COPY_ON_WRITE
4526     if (SvREADONLY(sv)) {
4527         if (SvFAKE(sv)) {
4528             const char * const pvx = SvPVX_const(sv);
4529             const STRLEN len = SvLEN(sv);
4530             const STRLEN cur = SvCUR(sv);
4531             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4532                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4533                we'll fail an assertion.  */
4534             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4535
4536             if (DEBUG_C_TEST) {
4537                 PerlIO_printf(Perl_debug_log,
4538                               "Copy on write: Force normal %ld\n",
4539                               (long) flags);
4540                 sv_dump(sv);
4541             }
4542             SvFAKE_off(sv);
4543             SvREADONLY_off(sv);
4544             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4545             SvPV_set(sv, NULL);
4546             SvLEN_set(sv, 0);
4547             if (flags & SV_COW_DROP_PV) {
4548                 /* OK, so we don't need to copy our buffer.  */
4549                 SvPOK_off(sv);
4550             } else {
4551                 SvGROW(sv, cur + 1);
4552                 Move(pvx,SvPVX(sv),cur,char);
4553                 SvCUR_set(sv, cur);
4554                 *SvEND(sv) = '\0';
4555             }
4556             if (len) {
4557                 sv_release_COW(sv, pvx, next);
4558             } else {
4559                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4560             }
4561             if (DEBUG_C_TEST) {
4562                 sv_dump(sv);
4563             }
4564         }
4565         else if (IN_PERL_RUNTIME)
4566             Perl_croak(aTHX_ "%s", PL_no_modify);
4567     }
4568 #else
4569     if (SvREADONLY(sv)) {
4570         if (SvFAKE(sv)) {
4571             const char * const pvx = SvPVX_const(sv);
4572             const STRLEN len = SvCUR(sv);
4573             SvFAKE_off(sv);
4574             SvREADONLY_off(sv);
4575             SvPV_set(sv, NULL);
4576             SvLEN_set(sv, 0);
4577             SvGROW(sv, len + 1);
4578             Move(pvx,SvPVX(sv),len,char);
4579             *SvEND(sv) = '\0';
4580             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4581         }
4582         else if (IN_PERL_RUNTIME)
4583             Perl_croak(aTHX_ "%s", PL_no_modify);
4584     }
4585 #endif
4586     if (SvROK(sv))
4587         sv_unref_flags(sv, flags);
4588     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4589         sv_unglob(sv);
4590 }
4591
4592 /*
4593 =for apidoc sv_chop
4594
4595 Efficient removal of characters from the beginning of the string buffer.
4596 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4597 the string buffer.  The C<ptr> becomes the first character of the adjusted
4598 string. Uses the "OOK hack".
4599 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4600 refer to the same chunk of data.
4601
4602 =cut
4603 */
4604
4605 void
4606 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4607 {
4608     STRLEN delta;
4609     STRLEN old_delta;
4610     U8 *p;
4611 #ifdef DEBUGGING
4612     const U8 *real_start;
4613 #endif
4614     STRLEN max_delta;
4615
4616     PERL_ARGS_ASSERT_SV_CHOP;
4617
4618     if (!ptr || !SvPOKp(sv))
4619         return;
4620     delta = ptr - SvPVX_const(sv);
4621     if (!delta) {
4622         /* Nothing to do.  */
4623         return;
4624     }
4625     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4626        nothing uses the value of ptr any more.  */
4627     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4628     if (ptr <= SvPVX_const(sv))
4629         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4630                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4631     SV_CHECK_THINKFIRST(sv);
4632     if (delta > max_delta)
4633         Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4634                    SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4635                    SvPVX_const(sv) + max_delta);
4636
4637     if (!SvOOK(sv)) {
4638         if (!SvLEN(sv)) { /* make copy of shared string */
4639             const char *pvx = SvPVX_const(sv);
4640             const STRLEN len = SvCUR(sv);
4641             SvGROW(sv, len + 1);
4642             Move(pvx,SvPVX(sv),len,char);
4643             *SvEND(sv) = '\0';
4644         }
4645         SvFLAGS(sv) |= SVf_OOK;
4646         old_delta = 0;
4647     } else {
4648         SvOOK_offset(sv, old_delta);
4649     }
4650     SvLEN_set(sv, SvLEN(sv) - delta);
4651     SvCUR_set(sv, SvCUR(sv) - delta);
4652     SvPV_set(sv, SvPVX(sv) + delta);
4653
4654     p = (U8 *)SvPVX_const(sv);
4655
4656     delta += old_delta;
4657
4658 #ifdef DEBUGGING
4659     real_start = p - delta;
4660 #endif
4661
4662     assert(delta);
4663     if (delta < 0x100) {
4664         *--p = (U8) delta;
4665     } else {
4666         *--p = 0;
4667         p -= sizeof(STRLEN);
4668         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4669     }
4670
4671 #ifdef DEBUGGING
4672     /* Fill the preceding buffer with sentinals to verify that no-one is
4673        using it.  */
4674     while (p > real_start) {
4675         --p;
4676         *p = (U8)PTR2UV(p);
4677     }
4678 #endif
4679 }
4680
4681 /*
4682 =for apidoc sv_catpvn
4683
4684 Concatenates the string onto the end of the string which is in the SV.  The
4685 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4686 status set, then the bytes appended should be valid UTF-8.
4687 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4688
4689 =for apidoc sv_catpvn_flags
4690
4691 Concatenates the string onto the end of the string which is in the SV.  The
4692 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4693 status set, then the bytes appended should be valid UTF-8.
4694 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4695 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4696 in terms of this function.
4697
4698 =cut
4699 */
4700
4701 void
4702 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4703 {
4704     dVAR;
4705     STRLEN dlen;
4706     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4707
4708     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4709
4710     SvGROW(dsv, dlen + slen + 1);
4711     if (sstr == dstr)
4712         sstr = SvPVX_const(dsv);
4713     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4714     SvCUR_set(dsv, SvCUR(dsv) + slen);
4715     *SvEND(dsv) = '\0';
4716     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4717     SvTAINT(dsv);
4718     if (flags & SV_SMAGIC)
4719         SvSETMAGIC(dsv);
4720 }
4721
4722 /*
4723 =for apidoc sv_catsv
4724
4725 Concatenates the string from SV C<ssv> onto the end of the string in
4726 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4727 not 'set' magic.  See C<sv_catsv_mg>.
4728
4729 =for apidoc sv_catsv_flags
4730
4731 Concatenates the string from SV C<ssv> onto the end of the string in
4732 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4733 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4734 and C<sv_catsv_nomg> are implemented in terms of this function.
4735
4736 =cut */
4737
4738 void
4739 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4740 {
4741     dVAR;
4742
4743     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4744
4745    if (ssv) {
4746         STRLEN slen;
4747         const char *spv = SvPV_const(ssv, slen);
4748         if (spv) {
4749             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4750                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4751                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4752                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4753                 dsv->sv_flags doesn't have that bit set.
4754                 Andy Dougherty  12 Oct 2001
4755             */
4756             const I32 sutf8 = DO_UTF8(ssv);
4757             I32 dutf8;
4758
4759             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4760                 mg_get(dsv);
4761             dutf8 = DO_UTF8(dsv);
4762
4763             if (dutf8 != sutf8) {
4764                 if (dutf8) {
4765                     /* Not modifying source SV, so taking a temporary copy. */
4766                     SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4767
4768                     sv_utf8_upgrade(csv);
4769                     spv = SvPV_const(csv, slen);
4770                 }
4771                 else
4772                     /* Leave enough space for the cat that's about to happen */
4773                     sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4774             }
4775             sv_catpvn_nomg(dsv, spv, slen);
4776         }
4777     }
4778     if (flags & SV_SMAGIC)
4779         SvSETMAGIC(dsv);
4780 }
4781
4782 /*
4783 =for apidoc sv_catpv
4784
4785 Concatenates the string onto the end of the string which is in the SV.
4786 If the SV has the UTF-8 status set, then the bytes appended should be
4787 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4788
4789 =cut */
4790
4791 void
4792 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4793 {
4794     dVAR;
4795     register STRLEN len;
4796     STRLEN tlen;
4797     char *junk;
4798
4799     PERL_ARGS_ASSERT_SV_CATPV;
4800
4801     if (!ptr)
4802         return;
4803     junk = SvPV_force(sv, tlen);
4804     len = strlen(ptr);
4805     SvGROW(sv, tlen + len + 1);
4806     if (ptr == junk)
4807         ptr = SvPVX_const(sv);
4808     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4809     SvCUR_set(sv, SvCUR(sv) + len);
4810     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4811     SvTAINT(sv);
4812 }
4813
4814 /*
4815 =for apidoc sv_catpv_mg
4816
4817 Like C<sv_catpv>, but also handles 'set' magic.
4818
4819 =cut
4820 */
4821
4822 void
4823 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4824 {
4825     PERL_ARGS_ASSERT_SV_CATPV_MG;
4826
4827     sv_catpv(sv,ptr);
4828     SvSETMAGIC(sv);
4829 }
4830
4831 /*
4832 =for apidoc newSV
4833
4834 Creates a new SV.  A non-zero C<len> parameter indicates the number of
4835 bytes of preallocated string space the SV should have.  An extra byte for a
4836 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
4837 space is allocated.)  The reference count for the new SV is set to 1.
4838
4839 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4840 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4841 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4842 L<perlhack/PERL_MEM_LOG>).  The older API is still there for use in XS
4843 modules supporting older perls.
4844
4845 =cut
4846 */
4847
4848 SV *
4849 Perl_newSV(pTHX_ const STRLEN len)
4850 {
4851     dVAR;
4852     register SV *sv;
4853
4854     new_SV(sv);
4855     if (len) {
4856         sv_upgrade(sv, SVt_PV);
4857         SvGROW(sv, len + 1);
4858     }
4859     return sv;
4860 }
4861 /*
4862 =for apidoc sv_magicext
4863
4864 Adds magic to an SV, upgrading it if necessary. Applies the
4865 supplied vtable and returns a pointer to the magic added.
4866
4867 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4868 In particular, you can add magic to SvREADONLY SVs, and add more than
4869 one instance of the same 'how'.
4870
4871 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4872 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4873 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4874 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4875
4876 (This is now used as a subroutine by C<sv_magic>.)
4877
4878 =cut
4879 */
4880 MAGIC *
4881 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4882                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4883 {
4884     dVAR;
4885     MAGIC* mg;
4886
4887     PERL_ARGS_ASSERT_SV_MAGICEXT;
4888
4889     SvUPGRADE(sv, SVt_PVMG);
4890     Newxz(mg, 1, MAGIC);
4891     mg->mg_moremagic = SvMAGIC(sv);
4892     SvMAGIC_set(sv, mg);
4893
4894     /* Sometimes a magic contains a reference loop, where the sv and
4895        object refer to each other.  To prevent a reference loop that
4896        would prevent such objects being freed, we look for such loops
4897        and if we find one we avoid incrementing the object refcount.
4898
4899        Note we cannot do this to avoid self-tie loops as intervening RV must
4900        have its REFCNT incremented to keep it in existence.
4901
4902     */
4903     if (!obj || obj == sv ||
4904         how == PERL_MAGIC_arylen ||
4905         how == PERL_MAGIC_symtab ||
4906         (SvTYPE(obj) == SVt_PVGV &&
4907             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4908              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4909              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4910     {
4911         mg->mg_obj = obj;
4912     }
4913     else {
4914         mg->mg_obj = SvREFCNT_inc_simple(obj);
4915         mg->mg_flags |= MGf_REFCOUNTED;
4916     }
4917
4918     /* Normal self-ties simply pass a null object, and instead of
4919        using mg_obj directly, use the SvTIED_obj macro to produce a
4920        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4921        with an RV obj pointing to the glob containing the PVIO.  In
4922        this case, to avoid a reference loop, we need to weaken the
4923        reference.
4924     */
4925
4926     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4927         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
4928     {
4929       sv_rvweaken(obj);
4930     }
4931
4932     mg->mg_type = how;
4933     mg->mg_len = namlen;
4934     if (name) {
4935         if (namlen > 0)
4936             mg->mg_ptr = savepvn(name, namlen);
4937         else if (namlen == HEf_SVKEY) {
4938             /* Yes, this is casting away const. This is only for the case of
4939                HEf_SVKEY. I think we need to document this abberation of the
4940                constness of the API, rather than making name non-const, as
4941                that change propagating outwards a long way.  */
4942             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
4943         } else
4944             mg->mg_ptr = (char *) name;
4945     }
4946     mg->mg_virtual = (MGVTBL *) vtable;
4947
4948     mg_magical(sv);
4949     if (SvGMAGICAL(sv))
4950         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4951     return mg;
4952 }
4953
4954 /*
4955 =for apidoc sv_magic
4956
4957 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4958 then adds a new magic item of type C<how> to the head of the magic list.
4959
4960 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4961 handling of the C<name> and C<namlen> arguments.
4962
4963 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4964 to add more than one instance of the same 'how'.
4965
4966 =cut
4967 */
4968
4969 void
4970 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
4971              const char *const name, const I32 namlen)
4972 {
4973     dVAR;
4974     const MGVTBL *vtable;
4975     MAGIC* mg;
4976
4977     PERL_ARGS_ASSERT_SV_MAGIC;
4978
4979 #ifdef PERL_OLD_COPY_ON_WRITE
4980     if (SvIsCOW(sv))
4981         sv_force_normal_flags(sv, 0);
4982 #endif
4983     if (SvREADONLY(sv)) {
4984         if (
4985             /* its okay to attach magic to shared strings; the subsequent
4986              * upgrade to PVMG will unshare the string */
4987             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4988
4989             && IN_PERL_RUNTIME
4990             && how != PERL_MAGIC_regex_global
4991             && how != PERL_MAGIC_bm
4992             && how != PERL_MAGIC_fm
4993             && how != PERL_MAGIC_sv
4994             && how != PERL_MAGIC_backref
4995            )
4996         {
4997             Perl_croak(aTHX_ "%s", PL_no_modify);
4998         }
4999     }
5000     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5001         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5002             /* sv_magic() refuses to add a magic of the same 'how' as an
5003                existing one
5004              */
5005             if (how == PERL_MAGIC_taint) {
5006                 mg->mg_len |= 1;
5007                 /* Any scalar which already had taint magic on which someone
5008                    (erroneously?) did SvIOK_on() or similar will now be
5009                    incorrectly sporting public "OK" flags.  */
5010                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5011             }
5012             return;
5013         }
5014     }
5015
5016     switch (how) {
5017     case PERL_MAGIC_sv:
5018         vtable = &PL_vtbl_sv;
5019         break;
5020     case PERL_MAGIC_overload:
5021         vtable = &PL_vtbl_amagic;
5022         break;
5023     case PERL_MAGIC_overload_elem:
5024         vtable = &PL_vtbl_amagicelem;
5025         break;
5026     case PERL_MAGIC_overload_table:
5027         vtable = &PL_vtbl_ovrld;
5028         break;
5029     case PERL_MAGIC_bm:
5030         vtable = &PL_vtbl_bm;
5031         break;
5032     case PERL_MAGIC_regdata:
5033         vtable = &PL_vtbl_regdata;
5034         break;
5035     case PERL_MAGIC_regdatum:
5036         vtable = &PL_vtbl_regdatum;
5037         break;
5038     case PERL_MAGIC_env:
5039         vtable = &PL_vtbl_env;
5040         break;
5041     case PERL_MAGIC_fm:
5042         vtable = &PL_vtbl_fm;
5043         break;
5044     case PERL_MAGIC_envelem:
5045         vtable = &PL_vtbl_envelem;
5046         break;
5047     case PERL_MAGIC_regex_global:
5048         vtable = &PL_vtbl_mglob;
5049         break;
5050     case PERL_MAGIC_isa:
5051         vtable = &PL_vtbl_isa;
5052         break;
5053     case PERL_MAGIC_isaelem:
5054         vtable = &PL_vtbl_isaelem;
5055         break;
5056     case PERL_MAGIC_nkeys:
5057         vtable = &PL_vtbl_nkeys;
5058         break;
5059     case PERL_MAGIC_dbfile:
5060         vtable = NULL;
5061         break;
5062     case PERL_MAGIC_dbline:
5063         vtable = &PL_vtbl_dbline;
5064         break;
5065 #ifdef USE_LOCALE_COLLATE
5066     case PERL_MAGIC_collxfrm:
5067         vtable = &PL_vtbl_collxfrm;
5068         break;
5069 #endif /* USE_LOCALE_COLLATE */
5070     case PERL_MAGIC_tied:
5071         vtable = &PL_vtbl_pack;
5072         break;
5073     case PERL_MAGIC_tiedelem:
5074     case PERL_MAGIC_tiedscalar:
5075         vtable = &PL_vtbl_packelem;
5076         break;
5077     case PERL_MAGIC_qr:
5078         vtable = &PL_vtbl_regexp;
5079         break;
5080     case PERL_MAGIC_hints:
5081         /* As this vtable is all NULL, we can reuse it.  */
5082     case PERL_MAGIC_sig:
5083         vtable = &PL_vtbl_sig;
5084         break;
5085     case PERL_MAGIC_sigelem:
5086         vtable = &PL_vtbl_sigelem;
5087         break;
5088     case PERL_MAGIC_taint:
5089         vtable = &PL_vtbl_taint;
5090         break;
5091     case PERL_MAGIC_uvar:
5092         vtable = &PL_vtbl_uvar;
5093         break;
5094     case PERL_MAGIC_vec:
5095         vtable = &PL_vtbl_vec;
5096         break;
5097     case PERL_MAGIC_arylen_p:
5098     case PERL_MAGIC_rhash:
5099     case PERL_MAGIC_symtab:
5100     case PERL_MAGIC_vstring:
5101         vtable = NULL;
5102         break;
5103     case PERL_MAGIC_utf8:
5104         vtable = &PL_vtbl_utf8;
5105         break;
5106     case PERL_MAGIC_substr:
5107         vtable = &PL_vtbl_substr;
5108         break;
5109     case PERL_MAGIC_defelem:
5110         vtable = &PL_vtbl_defelem;
5111         break;
5112     case PERL_MAGIC_arylen:
5113         vtable = &PL_vtbl_arylen;
5114         break;
5115     case PERL_MAGIC_pos:
5116         vtable = &PL_vtbl_pos;
5117         break;
5118     case PERL_MAGIC_backref:
5119         vtable = &PL_vtbl_backref;
5120         break;
5121     case PERL_MAGIC_hintselem:
5122         vtable = &PL_vtbl_hintselem;
5123         break;
5124     case PERL_MAGIC_ext:
5125         /* Reserved for use by extensions not perl internals.           */
5126         /* Useful for attaching extension internal data to perl vars.   */
5127         /* Note that multiple extensions may clash if magical scalars   */
5128         /* etc holding private data from one are passed to another.     */
5129         vtable = NULL;
5130         break;
5131     default:
5132         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5133     }
5134
5135     /* Rest of work is done else where */
5136     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5137
5138     switch (how) {
5139     case PERL_MAGIC_taint:
5140         mg->mg_len = 1;
5141         break;
5142     case PERL_MAGIC_ext:
5143     case PERL_MAGIC_dbfile:
5144         SvRMAGICAL_on(sv);
5145         break;
5146     }
5147 }
5148
5149 /*
5150 =for apidoc sv_unmagic
5151
5152 Removes all magic of type C<type> from an SV.
5153
5154 =cut
5155 */
5156
5157 int
5158 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5159 {
5160     MAGIC* mg;
5161     MAGIC** mgp;
5162
5163     PERL_ARGS_ASSERT_SV_UNMAGIC;
5164
5165     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5166         return 0;
5167     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5168     for (mg = *mgp; mg; mg = *mgp) {
5169         if (mg->mg_type == type) {
5170             const MGVTBL* const vtbl = mg->mg_virtual;
5171             *mgp = mg->mg_moremagic;
5172             if (vtbl && vtbl->svt_free)
5173                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5174             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5175                 if (mg->mg_len > 0)
5176                     Safefree(mg->mg_ptr);
5177                 else if (mg->mg_len == HEf_SVKEY)
5178                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5179                 else if (mg->mg_type == PERL_MAGIC_utf8)
5180                     Safefree(mg->mg_ptr);
5181             }
5182             if (mg->mg_flags & MGf_REFCOUNTED)
5183                 SvREFCNT_dec(mg->mg_obj);
5184             Safefree(mg);
5185         }
5186         else
5187             mgp = &mg->mg_moremagic;
5188     }
5189     if (!SvMAGIC(sv)) {
5190         SvMAGICAL_off(sv);
5191         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5192         SvMAGIC_set(sv, NULL);
5193     }
5194
5195     return 0;
5196 }
5197
5198 /*
5199 =for apidoc sv_rvweaken
5200
5201 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5202 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5203 push a back-reference to this RV onto the array of backreferences
5204 associated with that magic. If the RV is magical, set magic will be
5205 called after the RV is cleared.
5206
5207 =cut
5208 */
5209
5210 SV *
5211 Perl_sv_rvweaken(pTHX_ SV *const sv)
5212 {
5213     SV *tsv;
5214
5215     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5216
5217     if (!SvOK(sv))  /* let undefs pass */
5218         return sv;
5219     if (!SvROK(sv))
5220         Perl_croak(aTHX_ "Can't weaken a nonreference");
5221     else if (SvWEAKREF(sv)) {
5222         if (ckWARN(WARN_MISC))
5223             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5224         return sv;
5225     }
5226     tsv = SvRV(sv);
5227     Perl_sv_add_backref(aTHX_ tsv, sv);
5228     SvWEAKREF_on(sv);
5229     SvREFCNT_dec(tsv);
5230     return sv;
5231 }
5232
5233 /* Give tsv backref magic if it hasn't already got it, then push a
5234  * back-reference to sv onto the array associated with the backref magic.
5235  */
5236
5237 /* A discussion about the backreferences array and its refcount:
5238  *
5239  * The AV holding the backreferences is pointed to either as the mg_obj of
5240  * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5241  * structure, from the xhv_backreferences field. (A HV without hv_aux will
5242  * have the standard magic instead.) The array is created with a refcount
5243  * of 2. This means that if during global destruction the array gets
5244  * picked on first to have its refcount decremented by the random zapper,
5245  * it won't actually be freed, meaning it's still theere for when its
5246  * parent gets freed.
5247  * When the parent SV is freed, in the case of magic, the magic is freed,
5248  * Perl_magic_killbackrefs is called which decrements one refcount, then
5249  * mg_obj is freed which kills the second count.
5250  * In the vase of a HV being freed, one ref is removed by
5251  * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5252  * calls.
5253  */
5254
5255 void
5256 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5257 {
5258     dVAR;
5259     AV *av;
5260
5261     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5262
5263     if (SvTYPE(tsv) == SVt_PVHV) {
5264         AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5265
5266         av = *avp;
5267         if (!av) {
5268             /* There is no AV in the offical place - try a fixup.  */
5269             MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5270
5271             if (mg) {
5272                 /* Aha. They've got it stowed in magic.  Bring it back.  */
5273                 av = MUTABLE_AV(mg->mg_obj);
5274                 /* Stop mg_free decreasing the refernce count.  */
5275                 mg->mg_obj = NULL;
5276                 /* Stop mg_free even calling the destructor, given that
5277                    there's no AV to free up.  */
5278                 mg->mg_virtual = 0;
5279                 sv_unmagic(tsv, PERL_MAGIC_backref);
5280             } else {
5281                 av = newAV();
5282                 AvREAL_off(av);
5283                 SvREFCNT_inc_simple_void(av); /* see discussion above */
5284             }
5285             *avp = av;
5286         }
5287     } else {
5288         const MAGIC *const mg
5289             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5290         if (mg)
5291             av = MUTABLE_AV(mg->mg_obj);
5292         else {
5293             av = newAV();
5294             AvREAL_off(av);
5295             sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
5296             /* av now has a refcnt of 2; see discussion above */
5297         }
5298     }
5299     if (AvFILLp(av) >= AvMAX(av)) {
5300         av_extend(av, AvFILLp(av)+1);
5301     }
5302     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5303 }
5304
5305 /* delete a back-reference to ourselves from the backref magic associated
5306  * with the SV we point to.
5307  */
5308
5309 STATIC void
5310 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5311 {
5312     dVAR;
5313     AV *av = NULL;
5314     SV **svp;
5315     I32 i;
5316
5317     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5318
5319     if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5320         av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5321         /* We mustn't attempt to "fix up" the hash here by moving the
5322            backreference array back to the hv_aux structure, as that is stored
5323            in the main HvARRAY(), and hfreentries assumes that no-one
5324            reallocates HvARRAY() while it is running.  */
5325     }
5326     if (!av) {
5327         const MAGIC *const mg
5328             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5329         if (mg)
5330             av = MUTABLE_AV(mg->mg_obj);
5331     }
5332
5333     if (!av)
5334         Perl_croak(aTHX_ "panic: del_backref");
5335
5336     assert(!SvIS_FREED(av));
5337
5338     svp = AvARRAY(av);
5339     /* We shouldn't be in here more than once, but for paranoia reasons lets
5340        not assume this.  */
5341     for (i = AvFILLp(av); i >= 0; i--) {
5342         if (svp[i] == sv) {
5343             const SSize_t fill = AvFILLp(av);
5344             if (i != fill) {
5345                 /* We weren't the last entry.
5346                    An unordered list has this property that you can take the
5347                    last element off the end to fill the hole, and it's still
5348                    an unordered list :-)
5349                 */
5350                 svp[i] = svp[fill];
5351             }
5352             svp[fill] = NULL;
5353             AvFILLp(av) = fill - 1;
5354         }
5355     }
5356 }
5357
5358 int
5359 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5360 {
5361     SV **svp = AvARRAY(av);
5362
5363     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5364     PERL_UNUSED_ARG(sv);
5365
5366     assert(!svp || !SvIS_FREED(av));
5367     if (svp) {
5368         SV *const *const last = svp + AvFILLp(av);
5369
5370         while (svp <= last) {
5371             if (*svp) {
5372                 SV *const referrer = *svp;
5373                 if (SvWEAKREF(referrer)) {
5374                     /* XXX Should we check that it hasn't changed? */
5375                     SvRV_set(referrer, 0);
5376                     SvOK_off(referrer);
5377                     SvWEAKREF_off(referrer);
5378                     SvSETMAGIC(referrer);
5379                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5380                            SvTYPE(referrer) == SVt_PVLV) {
5381                     /* You lookin' at me?  */
5382                     assert(GvSTASH(referrer));
5383                     assert(GvSTASH(referrer) == (const HV *)sv);
5384                     GvSTASH(referrer) = 0;
5385                 } else {
5386                     Perl_croak(aTHX_
5387                                "panic: magic_killbackrefs (flags=%"UVxf")",
5388                                (UV)SvFLAGS(referrer));
5389                 }
5390
5391                 *svp = NULL;
5392             }
5393             svp++;
5394         }
5395     }
5396     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5397     return 0;
5398 }
5399
5400 /*
5401 =for apidoc sv_insert
5402
5403 Inserts a string at the specified offset/length within the SV. Similar to
5404 the Perl substr() function. Handles get magic.
5405
5406 =for apidoc sv_insert_flags
5407
5408 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5409
5410 =cut
5411 */
5412
5413 void
5414 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5415 {
5416     dVAR;
5417     register char *big;
5418     register char *mid;
5419     register char *midend;
5420     register char *bigend;
5421     register I32 i;
5422     STRLEN curlen;
5423
5424     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5425
5426     if (!bigstr)
5427         Perl_croak(aTHX_ "Can't modify non-existent substring");
5428     SvPV_force_flags(bigstr, curlen, flags);
5429     (void)SvPOK_only_UTF8(bigstr);
5430     if (offset + len > curlen) {
5431         SvGROW(bigstr, offset+len+1);
5432         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5433         SvCUR_set(bigstr, offset+len);
5434     }
5435
5436     SvTAINT(bigstr);
5437     i = littlelen - len;
5438     if (i > 0) {                        /* string might grow */
5439         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5440         mid = big + offset + len;
5441         midend = bigend = big + SvCUR(bigstr);
5442         bigend += i;
5443         *bigend = '\0';
5444         while (midend > mid)            /* shove everything down */
5445             *--bigend = *--midend;
5446         Move(little,big+offset,littlelen,char);
5447         SvCUR_set(bigstr, SvCUR(bigstr) + i);
5448         SvSETMAGIC(bigstr);
5449         return;
5450     }
5451     else if (i == 0) {
5452         Move(little,SvPVX(bigstr)+offset,len,char);
5453         SvSETMAGIC(bigstr);
5454         return;
5455     }
5456
5457     big = SvPVX(bigstr);
5458     mid = big + offset;
5459     midend = mid + len;
5460     bigend = big + SvCUR(bigstr);
5461
5462     if (midend > bigend)
5463         Perl_croak(aTHX_ "panic: sv_insert");
5464
5465     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5466         if (littlelen) {
5467             Move(little, mid, littlelen,char);
5468             mid += littlelen;
5469         }
5470         i = bigend - midend;
5471         if (i > 0) {
5472             Move(midend, mid, i,char);
5473             mid += i;
5474         }
5475         *mid = '\0';
5476         SvCUR_set(bigstr, mid - big);
5477     }
5478     else if ((i = mid - big)) { /* faster from front */
5479         midend -= littlelen;
5480         mid = midend;
5481         Move(big, midend - i, i, char);
5482         sv_chop(bigstr,midend-i);
5483         if (littlelen)
5484             Move(little, mid, littlelen,char);
5485     }
5486     else if (littlelen) {
5487         midend -= littlelen;
5488         sv_chop(bigstr,midend);
5489         Move(little,midend,littlelen,char);
5490     }
5491     else {
5492         sv_chop(bigstr,midend);
5493     }
5494     SvSETMAGIC(bigstr);
5495 }
5496
5497 /*
5498 =for apidoc sv_replace
5499
5500 Make the first argument a copy of the second, then delete the original.
5501 The target SV physically takes over ownership of the body of the source SV
5502 and inherits its flags; however, the target keeps any magic it owns,
5503 and any magic in the source is discarded.
5504 Note that this is a rather specialist SV copying operation; most of the
5505 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5506
5507 =cut
5508 */
5509
5510 void
5511 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5512 {
5513     dVAR;
5514     const U32 refcnt = SvREFCNT(sv);
5515
5516     PERL_ARGS_ASSERT_SV_REPLACE;
5517
5518     SV_CHECK_THINKFIRST_COW_DROP(sv);
5519     if (SvREFCNT(nsv) != 1) {
5520         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5521                    UVuf " != 1)", (UV) SvREFCNT(nsv));
5522     }
5523     if (SvMAGICAL(sv)) {
5524         if (SvMAGICAL(nsv))
5525             mg_free(nsv);
5526         else
5527             sv_upgrade(nsv, SVt_PVMG);
5528         SvMAGIC_set(nsv, SvMAGIC(sv));
5529         SvFLAGS(nsv) |= SvMAGICAL(sv);
5530         SvMAGICAL_off(sv);
5531         SvMAGIC_set(sv, NULL);
5532     }
5533     SvREFCNT(sv) = 0;
5534     sv_clear(sv);
5535     assert(!SvREFCNT(sv));
5536 #ifdef DEBUG_LEAKING_SCALARS
5537     sv->sv_flags  = nsv->sv_flags;
5538     sv->sv_any    = nsv->sv_any;
5539     sv->sv_refcnt = nsv->sv_refcnt;
5540     sv->sv_u      = nsv->sv_u;
5541 #else
5542     StructCopy(nsv,sv,SV);
5543 #endif
5544     if(SvTYPE(sv) == SVt_IV) {
5545         SvANY(sv)
5546             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5547     }
5548
5549
5550 #ifdef PERL_OLD_COPY_ON_WRITE
5551     if (SvIsCOW_normal(nsv)) {
5552         /* We need to follow the pointers around the loop to make the
5553            previous SV point to sv, rather than nsv.  */
5554         SV *next;
5555         SV *current = nsv;
5556         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5557             assert(next);
5558             current = next;
5559             assert(SvPVX_const(current) == SvPVX_const(nsv));
5560         }
5561         /* Make the SV before us point to the SV after us.  */
5562         if (DEBUG_C_TEST) {
5563             PerlIO_printf(Perl_debug_log, "previous is\n");
5564             sv_dump(current);
5565             PerlIO_printf(Perl_debug_log,
5566                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5567                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5568         }
5569         SV_COW_NEXT_SV_SET(current, sv);
5570     }
5571 #endif
5572     SvREFCNT(sv) = refcnt;
5573     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5574     SvREFCNT(nsv) = 0;
5575     del_SV(nsv);
5576 }
5577
5578 /*
5579 =for apidoc sv_clear
5580
5581 Clear an SV: call any destructors, free up any memory used by the body,
5582 and free the body itself. The SV's head is I<not> freed, although
5583 its type is set to all 1's so that it won't inadvertently be assumed
5584 to be live during global destruction etc.
5585 This function should only be called when REFCNT is zero. Most of the time
5586 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5587 instead.
5588
5589 =cut
5590 */
5591
5592 void
5593 Perl_sv_clear(pTHX_ register SV *const sv)
5594 {
5595     dVAR;
5596     const U32 type = SvTYPE(sv);
5597     const struct body_details *const sv_type_details
5598         = bodies_by_type + type;
5599     HV *stash;
5600
5601     PERL_ARGS_ASSERT_SV_CLEAR;
5602     assert(SvREFCNT(sv) == 0);
5603     assert(SvTYPE(sv) != SVTYPEMASK);
5604
5605     if (type <= SVt_IV) {
5606         /* See the comment in sv.h about the collusion between this early
5607            return and the overloading of the NULL and IV slots in the size
5608            table.  */
5609         if (SvROK(sv)) {
5610             SV * const target = SvRV(sv);
5611             if (SvWEAKREF(sv))
5612                 sv_del_backref(target, sv);
5613             else
5614                 SvREFCNT_dec(target);
5615         }
5616         SvFLAGS(sv) &= SVf_BREAK;
5617         SvFLAGS(sv) |= SVTYPEMASK;
5618         return;
5619     }
5620
5621     if (SvOBJECT(sv)) {
5622         if (PL_defstash &&      /* Still have a symbol table? */
5623             SvDESTROYABLE(sv))
5624         {
5625             dSP;
5626             HV* stash;
5627             do {
5628                 CV* destructor;
5629                 stash = SvSTASH(sv);
5630                 destructor = StashHANDLER(stash,DESTROY);
5631                 if (destructor
5632                         /* A constant subroutine can have no side effects, so
5633                            don't bother calling it.  */
5634                         && !CvCONST(destructor)
5635                         /* Don't bother calling an empty destructor */
5636                         && (CvISXSUB(destructor)
5637                         || CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))
5638                 {
5639                     SV* const tmpref = newRV(sv);
5640                     SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
5641                     ENTER;
5642                     PUSHSTACKi(PERLSI_DESTROY);
5643                     EXTEND(SP, 2);
5644                     PUSHMARK(SP);
5645                     PUSHs(tmpref);
5646                     PUTBACK;
5647                     call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5648
5649
5650                     POPSTACK;
5651                     SPAGAIN;
5652                     LEAVE;
5653                     if(SvREFCNT(tmpref) < 2) {
5654                         /* tmpref is not kept alive! */
5655                         SvREFCNT(sv)--;
5656                         SvRV_set(tmpref, NULL);
5657                         SvROK_off(tmpref);
5658                     }
5659                     SvREFCNT_dec(tmpref);
5660                 }
5661             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5662
5663
5664             if (SvREFCNT(sv)) {
5665                 if (PL_in_clean_objs)
5666                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5667                           HvNAME_get(stash));
5668                 /* DESTROY gave object new lease on life */
5669                 return;
5670             }
5671         }
5672
5673         if (SvOBJECT(sv)) {
5674             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
5675             SvOBJECT_off(sv);   /* Curse the object. */
5676             if (type != SVt_PVIO)
5677                 --PL_sv_objcount;       /* XXX Might want something more general */
5678         }
5679     }
5680     if (type >= SVt_PVMG) {
5681         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5682             SvREFCNT_dec(SvOURSTASH(sv));
5683         } else if (SvMAGIC(sv))
5684             mg_free(sv);
5685         if (type == SVt_PVMG && SvPAD_TYPED(sv))
5686             SvREFCNT_dec(SvSTASH(sv));
5687     }
5688     switch (type) {
5689         /* case SVt_BIND: */
5690     case SVt_PVIO:
5691         if (IoIFP(sv) &&
5692             IoIFP(sv) != PerlIO_stdin() &&
5693             IoIFP(sv) != PerlIO_stdout() &&
5694             IoIFP(sv) != PerlIO_stderr())
5695         {
5696             io_close(MUTABLE_IO(sv), FALSE);
5697         }
5698         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5699             PerlDir_close(IoDIRP(sv));
5700         IoDIRP(sv) = (DIR*)NULL;
5701         Safefree(IoTOP_NAME(sv));
5702         Safefree(IoFMT_NAME(sv));
5703         Safefree(IoBOTTOM_NAME(sv));
5704         goto freescalar;
5705     case SVt_REGEXP:
5706         /* FIXME for plugins */
5707         pregfree2((REGEXP*) sv);
5708         goto freescalar;
5709     case SVt_PVCV:
5710     case SVt_PVFM:
5711         cv_undef(MUTABLE_CV(sv));
5712         goto freescalar;
5713     case SVt_PVHV:
5714         if (PL_last_swash_hv == (const HV *)sv) {
5715             PL_last_swash_hv = NULL;
5716         }
5717         Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5718         hv_undef(MUTABLE_HV(sv));
5719         break;
5720     case SVt_PVAV:
5721         if (PL_comppad == MUTABLE_AV(sv)) {
5722             PL_comppad = NULL;
5723             PL_curpad = NULL;
5724         }
5725         av_undef(MUTABLE_AV(sv));
5726         break;
5727     case SVt_PVLV:
5728         if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5729             SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5730             HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5731             PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5732         }
5733         else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
5734             SvREFCNT_dec(LvTARG(sv));
5735     case SVt_PVGV:
5736         if (isGV_with_GP(sv)) {
5737             if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5738                && HvNAME_get(stash))
5739                 mro_method_changed_in(stash);
5740             gp_free(MUTABLE_GV(sv));
5741             if (GvNAME_HEK(sv))
5742                 unshare_hek(GvNAME_HEK(sv));
5743             /* If we're in a stash, we don't own a reference to it. However it does
5744                have a back reference to us, which needs to be cleared.  */
5745             if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5746                     sv_del_backref(MUTABLE_SV(stash), sv);
5747         }
5748         /* FIXME. There are probably more unreferenced pointers to SVs in the
5749            interpreter struct that we should check and tidy in a similar
5750            fashion to this:  */
5751         if ((const GV *)sv == PL_last_in_gv)
5752             PL_last_in_gv = NULL;
5753     case SVt_PVMG:
5754     case SVt_PVNV:
5755     case SVt_PVIV:
5756     case SVt_PV:
5757       freescalar:
5758         /* Don't bother with SvOOK_off(sv); as we're only going to free it.  */
5759         if (SvOOK(sv)) {
5760             STRLEN offset;
5761             SvOOK_offset(sv, offset);
5762             SvPV_set(sv, SvPVX_mutable(sv) - offset);
5763             /* Don't even bother with turning off the OOK flag.  */
5764         }
5765         if (SvROK(sv)) {
5766             SV * const target = SvRV(sv);
5767             if (SvWEAKREF(sv))
5768                 sv_del_backref(target, sv);
5769             else
5770                 SvREFCNT_dec(target);
5771         }
5772 #ifdef PERL_OLD_COPY_ON_WRITE
5773         else if (SvPVX_const(sv)) {
5774             if (SvIsCOW(sv)) {
5775                 if (DEBUG_C_TEST) {
5776                     PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5777                     sv_dump(sv);
5778                 }
5779                 if (SvLEN(sv)) {
5780                     sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5781                 } else {
5782                     unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5783                 }
5784
5785                 SvFAKE_off(sv);
5786             } else if (SvLEN(sv)) {
5787                 Safefree(SvPVX_const(sv));
5788             }
5789         }
5790 #else
5791         else if (SvPVX_const(sv) && SvLEN(sv))
5792             Safefree(SvPVX_mutable(sv));
5793         else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5794             unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5795             SvFAKE_off(sv);
5796         }
5797 #endif
5798         break;
5799     case SVt_NV:
5800         break;
5801     }
5802
5803     SvFLAGS(sv) &= SVf_BREAK;
5804     SvFLAGS(sv) |= SVTYPEMASK;
5805
5806     if (sv_type_details->arena) {
5807         del_body(((char *)SvANY(sv) + sv_type_details->offset),
5808                  &PL_body_roots[type]);
5809     }
5810     else if (sv_type_details->body_size) {
5811         my_safefree(SvANY(sv));
5812     }
5813 }
5814
5815 /*
5816 =for apidoc sv_newref
5817
5818 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5819 instead.
5820
5821 =cut
5822 */
5823
5824 SV *
5825 Perl_sv_newref(pTHX_ SV *const sv)
5826 {
5827     PERL_UNUSED_CONTEXT;
5828     if (sv)
5829         (SvREFCNT(sv))++;
5830     return sv;
5831 }
5832
5833 /*
5834 =for apidoc sv_free
5835
5836 Decrement an SV's reference count, and if it drops to zero, call
5837 C<sv_clear> to invoke destructors and free up any memory used by
5838 the body; finally, deallocate the SV's head itself.
5839 Normally called via a wrapper macro C<SvREFCNT_dec>.
5840
5841 =cut
5842 */
5843
5844 void
5845 Perl_sv_free(pTHX_ SV *const sv)
5846 {
5847     dVAR;
5848     if (!sv)
5849         return;
5850     if (SvREFCNT(sv) == 0) {
5851         if (SvFLAGS(sv) & SVf_BREAK)
5852             /* this SV's refcnt has been artificially decremented to
5853              * trigger cleanup */
5854             return;
5855         if (PL_in_clean_all) /* All is fair */
5856             return;
5857         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5858             /* make sure SvREFCNT(sv)==0 happens very seldom */
5859             SvREFCNT(sv) = (~(U32)0)/2;
5860             return;
5861         }
5862         if (ckWARN_d(WARN_INTERNAL)) {
5863 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5864             Perl_dump_sv_child(aTHX_ sv);
5865 #else
5866   #ifdef DEBUG_LEAKING_SCALARS
5867             sv_dump(sv);
5868   #endif
5869 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5870             if (PL_warnhook == PERL_WARNHOOK_FATAL
5871                 || ckDEAD(packWARN(WARN_INTERNAL))) {
5872                 /* Don't let Perl_warner cause us to escape our fate:  */
5873                 abort();
5874             }
5875 #endif
5876             /* This may not return:  */
5877             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5878                         "Attempt to free unreferenced scalar: SV 0x%"UVxf
5879                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5880 #endif
5881         }
5882 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5883         abort();
5884 #endif
5885         return;
5886     }
5887     if (--(SvREFCNT(sv)) > 0)
5888         return;
5889     Perl_sv_free2(aTHX_ sv);
5890 }
5891
5892 void
5893 Perl_sv_free2(pTHX_ SV *const sv)
5894 {
5895     dVAR;
5896
5897     PERL_ARGS_ASSERT_SV_FREE2;
5898
5899 #ifdef DEBUGGING
5900     if (SvTEMP(sv)) {
5901         if (ckWARN_d(WARN_DEBUGGING))
5902             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5903                         "Attempt to free temp prematurely: SV 0x%"UVxf
5904                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5905         return;
5906     }
5907 #endif
5908     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5909         /* make sure SvREFCNT(sv)==0 happens very seldom */
5910         SvREFCNT(sv) = (~(U32)0)/2;
5911         return;
5912     }
5913     sv_clear(sv);
5914     if (! SvREFCNT(sv))
5915         del_SV(sv);
5916 }
5917
5918 /*
5919 =for apidoc sv_len
5920
5921 Returns the length of the string in the SV. Handles magic and type
5922 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5923
5924 =cut
5925 */
5926
5927 STRLEN
5928 Perl_sv_len(pTHX_ register SV *const sv)
5929 {
5930     STRLEN len;
5931
5932     if (!sv)
5933         return 0;
5934
5935     if (SvGMAGICAL(sv))
5936         len = mg_length(sv);
5937     else
5938         (void)SvPV_const(sv, len);
5939     return len;
5940 }
5941
5942 /*
5943 =for apidoc sv_len_utf8
5944
5945 Returns the number of characters in the string in an SV, counting wide
5946 UTF-8 bytes as a single character. Handles magic and type coercion.
5947
5948 =cut
5949 */
5950
5951 /*
5952  * The length is cached in PERL_MAGIC_utf8, in the mg_len field.  Also the
5953  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
5954  * (Note that the mg_len is not the length of the mg_ptr field.
5955  * This allows the cache to store the character length of the string without
5956  * needing to malloc() extra storage to attach to the mg_ptr.)
5957  *
5958  */
5959
5960 STRLEN
5961 Perl_sv_len_utf8(pTHX_ register SV *const sv)
5962 {
5963     if (!sv)
5964         return 0;
5965
5966     if (SvGMAGICAL(sv))
5967         return mg_length(sv);
5968     else
5969     {
5970         STRLEN len;
5971         const U8 *s = (U8*)SvPV_const(sv, len);
5972
5973         if (PL_utf8cache) {
5974             STRLEN ulen;
5975             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
5976
5977             if (mg && mg->mg_len != -1) {
5978                 ulen = mg->mg_len;
5979                 if (PL_utf8cache < 0) {
5980                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
5981                     if (real != ulen) {
5982                         /* Need to turn the assertions off otherwise we may
5983                            recurse infinitely while printing error messages.
5984                         */
5985                         SAVEI8(PL_utf8cache);
5986                         PL_utf8cache = 0;
5987                         Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
5988                                    " real %"UVuf" for %"SVf,
5989                                    (UV) ulen, (UV) real, SVfARG(sv));
5990                     }
5991                 }
5992             }
5993             else {
5994                 ulen = Perl_utf8_length(aTHX_ s, s + len);
5995                 if (!SvREADONLY(sv)) {
5996                     if (!mg) {
5997                         mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
5998                                          &PL_vtbl_utf8, 0, 0);
5999                     }
6000                     assert(mg);
6001                     mg->mg_len = ulen;
6002                 }
6003             }
6004             return ulen;
6005         }
6006         return Perl_utf8_length(aTHX_ s, s + len);
6007     }
6008 }
6009
6010 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6011    offset.  */
6012 static STRLEN
6013 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6014                       STRLEN uoffset)
6015 {
6016     const U8 *s = start;
6017
6018     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6019
6020     while (s < send && uoffset--)
6021         s += UTF8SKIP(s);
6022     if (s > send) {
6023         /* This is the existing behaviour. Possibly it should be a croak, as
6024            it's actually a bounds error  */
6025         s = send;
6026     }
6027     return s - start;
6028 }
6029
6030 /* Given the length of the string in both bytes and UTF-8 characters, decide
6031    whether to walk forwards or backwards to find the byte corresponding to
6032    the passed in UTF-8 offset.  */
6033 static STRLEN
6034 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6035                       const STRLEN uoffset, const STRLEN uend)
6036 {
6037     STRLEN backw = uend - uoffset;
6038
6039     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6040
6041     if (uoffset < 2 * backw) {
6042         /* The assumption is that going forwards is twice the speed of going
6043            forward (that's where the 2 * backw comes from).
6044            (The real figure of course depends on the UTF-8 data.)  */
6045         return sv_pos_u2b_forwards(start, send, uoffset);
6046     }
6047
6048     while (backw--) {
6049         send--;
6050         while (UTF8_IS_CONTINUATION(*send))
6051             send--;
6052     }
6053     return send - start;
6054 }
6055
6056 /* For the string representation of the given scalar, find the byte
6057    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
6058    give another position in the string, *before* the sought offset, which
6059    (which is always true, as 0, 0 is a valid pair of positions), which should
6060    help reduce the amount of linear searching.
6061    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6062    will be used to reduce the amount of linear searching. The cache will be
6063    created if necessary, and the found value offered to it for update.  */
6064 static STRLEN
6065 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6066                     const U8 *const send, const STRLEN uoffset,
6067                     STRLEN uoffset0, STRLEN boffset0)
6068 {
6069     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
6070     bool found = FALSE;
6071
6072     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6073
6074     assert (uoffset >= uoffset0);
6075
6076     if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6077         && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6078         if ((*mgp)->mg_ptr) {
6079             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6080             if (cache[0] == uoffset) {
6081                 /* An exact match. */
6082                 return cache[1];
6083             }
6084             if (cache[2] == uoffset) {
6085                 /* An exact match. */
6086                 return cache[3];
6087             }
6088
6089             if (cache[0] < uoffset) {
6090                 /* The cache already knows part of the way.   */
6091                 if (cache[0] > uoffset0) {
6092                     /* The cache knows more than the passed in pair  */
6093                     uoffset0 = cache[0];
6094                     boffset0 = cache[1];
6095                 }
6096                 if ((*mgp)->mg_len != -1) {
6097                     /* And we know the end too.  */
6098                     boffset = boffset0
6099                         + sv_pos_u2b_midway(start + boffset0, send,
6100                                               uoffset - uoffset0,
6101                                               (*mgp)->mg_len - uoffset0);
6102                 } else {
6103                     boffset = boffset0
6104                         + sv_pos_u2b_forwards(start + boffset0,
6105                                                 send, uoffset - uoffset0);
6106                 }
6107             }
6108             else if (cache[2] < uoffset) {
6109                 /* We're between the two cache entries.  */
6110                 if (cache[2] > uoffset0) {
6111                     /* and the cache knows more than the passed in pair  */
6112                     uoffset0 = cache[2];
6113                     boffset0 = cache[3];
6114                 }
6115
6116                 boffset = boffset0
6117                     + sv_pos_u2b_midway(start + boffset0,
6118                                           start + cache[1],
6119                                           uoffset - uoffset0,
6120                                           cache[0] - uoffset0);
6121             } else {
6122                 boffset = boffset0
6123                     + sv_pos_u2b_midway(start + boffset0,
6124                                           start + cache[3],
6125                                           uoffset - uoffset0,
6126                                           cache[2] - uoffset0);
6127             }
6128             found = TRUE;
6129         }
6130         else if ((*mgp)->mg_len != -1) {
6131             /* If we can take advantage of a passed in offset, do so.  */
6132             /* In fact, offset0 is either 0, or less than offset, so don't
6133                need to worry about the other possibility.  */
6134             boffset = boffset0
6135                 + sv_pos_u2b_midway(start + boffset0, send,
6136                                       uoffset - uoffset0,
6137                                       (*mgp)->mg_len - uoffset0);
6138             found = TRUE;
6139         }
6140     }
6141
6142     if (!found || PL_utf8cache < 0) {
6143         const STRLEN real_boffset
6144             = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6145                                                send, uoffset - uoffset0);
6146
6147         if (found && PL_utf8cache < 0) {
6148             if (real_boffset != boffset) {
6149                 /* Need to turn the assertions off otherwise we may recurse
6150                    infinitely while printing error messages.  */
6151                 SAVEI8(PL_utf8cache);
6152                 PL_utf8cache = 0;
6153                 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
6154                            " real %"UVuf" for %"SVf,
6155                            (UV) boffset, (UV) real_boffset, SVfARG(sv));
6156             }
6157         }
6158         boffset = real_boffset;
6159     }
6160
6161     if (PL_utf8cache)
6162         utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6163     return boffset;
6164 }
6165
6166
6167 /*
6168 =for apidoc sv_pos_u2b
6169
6170 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6171 the start of the string, to a count of the equivalent number of bytes; if
6172 lenp is non-zero, it does the same to lenp, but this time starting from
6173 the offset, rather than from the start of the string. Handles magic and
6174 type coercion.
6175
6176 =cut
6177 */
6178
6179 /*
6180  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6181  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6182  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6183  *
6184  */
6185
6186 void
6187 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6188 {
6189     const U8 *start;
6190     STRLEN len;
6191
6192     PERL_ARGS_ASSERT_SV_POS_U2B;
6193
6194     if (!sv)
6195         return;
6196
6197     start = (U8*)SvPV_const(sv, len);
6198     if (len) {
6199         STRLEN uoffset = (STRLEN) *offsetp;
6200         const U8 * const send = start + len;
6201         MAGIC *mg = NULL;
6202         const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
6203                                              uoffset, 0, 0);
6204
6205         *offsetp = (I32) boffset;
6206
6207         if (lenp) {
6208             /* Convert the relative offset to absolute.  */
6209             const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
6210             const STRLEN boffset2
6211                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6212                                       uoffset, boffset) - boffset;
6213
6214             *lenp = boffset2;
6215         }
6216     }
6217     else {
6218          *offsetp = 0;
6219          if (lenp)
6220               *lenp = 0;
6221     }
6222
6223     return;
6224 }
6225
6226 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6227    byte length pairing. The (byte) length of the total SV is passed in too,
6228    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6229    may not have updated SvCUR, so we can't rely on reading it directly.
6230
6231    The proffered utf8/byte length pairing isn't used if the cache already has
6232    two pairs, and swapping either for the proffered pair would increase the
6233    RMS of the intervals between known byte offsets.
6234
6235    The cache itself consists of 4 STRLEN values
6236    0: larger UTF-8 offset
6237    1: corresponding byte offset
6238    2: smaller UTF-8 offset
6239    3: corresponding byte offset
6240
6241    Unused cache pairs have the value 0, 0.
6242    Keeping the cache "backwards" means that the invariant of
6243    cache[0] >= cache[2] is maintained even with empty slots, which means that
6244    the code that uses it doesn't need to worry if only 1 entry has actually
6245    been set to non-zero.  It also makes the "position beyond the end of the
6246    cache" logic much simpler, as the first slot is always the one to start
6247    from.
6248 */
6249 static void
6250 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6251                            const STRLEN utf8, const STRLEN blen)
6252 {
6253     STRLEN *cache;
6254
6255     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6256
6257     if (SvREADONLY(sv))
6258         return;
6259
6260     if (!*mgp) {
6261         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6262                            0);
6263         (*mgp)->mg_len = -1;
6264     }
6265     assert(*mgp);
6266
6267     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6268         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6269         (*mgp)->mg_ptr = (char *) cache;
6270     }
6271     assert(cache);
6272
6273     if (PL_utf8cache < 0) {
6274         const U8 *start = (const U8 *) SvPVX_const(sv);
6275         const STRLEN realutf8 = utf8_length(start, start + byte);
6276
6277         if (realutf8 != utf8) {
6278             /* Need to turn the assertions off otherwise we may recurse
6279                infinitely while printing error messages.  */
6280             SAVEI8(PL_utf8cache);
6281             PL_utf8cache = 0;
6282             Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6283                        " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6284         }
6285     }
6286
6287     /* Cache is held with the later position first, to simplify the code
6288        that deals with unbounded ends.  */
6289
6290     ASSERT_UTF8_CACHE(cache);
6291     if (cache[1] == 0) {
6292         /* Cache is totally empty  */
6293         cache[0] = utf8;
6294         cache[1] = byte;
6295     } else if (cache[3] == 0) {
6296         if (byte > cache[1]) {
6297             /* New one is larger, so goes first.  */
6298             cache[2] = cache[0];
6299             cache[3] = cache[1];
6300             cache[0] = utf8;
6301             cache[1] = byte;
6302         } else {
6303             cache[2] = utf8;
6304             cache[3] = byte;
6305         }
6306     } else {
6307 #define THREEWAY_SQUARE(a,b,c,d) \
6308             ((float)((d) - (c))) * ((float)((d) - (c))) \
6309             + ((float)((c) - (b))) * ((float)((c) - (b))) \
6310                + ((float)((b) - (a))) * ((float)((b) - (a)))
6311
6312         /* Cache has 2 slots in use, and we know three potential pairs.
6313            Keep the two that give the lowest RMS distance. Do the
6314            calcualation in bytes simply because we always know the byte
6315            length.  squareroot has the same ordering as the positive value,
6316            so don't bother with the actual square root.  */
6317         const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6318         if (byte > cache[1]) {
6319             /* New position is after the existing pair of pairs.  */
6320             const float keep_earlier
6321                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6322             const float keep_later
6323                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6324
6325             if (keep_later < keep_earlier) {
6326                 if (keep_later < existing) {
6327                     cache[2] = cache[0];
6328                     cache[3] = cache[1];
6329                     cache[0] = utf8;
6330                     cache[1] = byte;
6331                 }
6332             }
6333             else {
6334                 if (keep_earlier < existing) {
6335                     cache[0] = utf8;
6336                     cache[1] = byte;
6337                 }
6338             }
6339         }
6340         else if (byte > cache[3]) {
6341             /* New position is between the existing pair of pairs.  */
6342             const float keep_earlier
6343                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6344             const float keep_later
6345                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6346
6347             if (keep_later < keep_earlier) {
6348                 if (keep_later < existing) {
6349                     cache[2] = utf8;
6350                     cache[3] = byte;
6351                 }
6352             }
6353             else {
6354                 if (keep_earlier < existing) {
6355                     cache[0] = utf8;
6356                     cache[1] = byte;
6357                 }
6358             }
6359         }
6360         else {
6361             /* New position is before the existing pair of pairs.  */
6362             const float keep_earlier
6363                 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6364             const float keep_later
6365                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6366
6367             if (keep_later < keep_earlier) {
6368                 if (keep_later < existing) {
6369                     cache[2] = utf8;
6370                     cache[3] = byte;
6371                 }
6372             }
6373             else {
6374                 if (keep_earlier < existing) {
6375                     cache[0] = cache[2];
6376                     cache[1] = cache[3];
6377                     cache[2] = utf8;
6378                     cache[3] = byte;
6379                 }
6380             }
6381         }
6382     }
6383     ASSERT_UTF8_CACHE(cache);
6384 }
6385
6386 /* We already know all of the way, now we may be able to walk back.  The same
6387    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6388    backward is half the speed of walking forward. */
6389 static STRLEN
6390 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6391                     const U8 *end, STRLEN endu)
6392 {
6393     const STRLEN forw = target - s;
6394     STRLEN backw = end - target;
6395
6396     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6397
6398     if (forw < 2 * backw) {
6399         return utf8_length(s, target);
6400     }
6401
6402     while (end > target) {
6403         end--;
6404         while (UTF8_IS_CONTINUATION(*end)) {
6405             end--;
6406         }
6407         endu--;
6408     }
6409     return endu;
6410 }
6411
6412 /*
6413 =for apidoc sv_pos_b2u
6414
6415 Converts the value pointed to by offsetp from a count of bytes from the
6416 start of the string, to a count of the equivalent number of UTF-8 chars.
6417 Handles magic and type coercion.
6418
6419 =cut
6420 */
6421
6422 /*
6423  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6424  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6425  * byte offsets.
6426  *
6427  */
6428 void
6429 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6430 {
6431     const U8* s;
6432     const STRLEN byte = *offsetp;
6433     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
6434     STRLEN blen;
6435     MAGIC* mg = NULL;
6436     const U8* send;
6437     bool found = FALSE;
6438
6439     PERL_ARGS_ASSERT_SV_POS_B2U;
6440
6441     if (!sv)
6442         return;
6443
6444     s = (const U8*)SvPV_const(sv, blen);
6445
6446     if (blen < byte)
6447         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6448
6449     send = s + byte;
6450
6451     if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6452         && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
6453         if (mg->mg_ptr) {
6454             STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6455             if (cache[1] == byte) {
6456                 /* An exact match. */
6457                 *offsetp = cache[0];
6458                 return;
6459             }
6460             if (cache[3] == byte) {
6461                 /* An exact match. */
6462                 *offsetp = cache[2];
6463                 return;
6464             }
6465
6466             if (cache[1] < byte) {
6467                 /* We already know part of the way. */
6468                 if (mg->mg_len != -1) {
6469                     /* Actually, we know the end too.  */
6470                     len = cache[0]
6471                         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6472                                               s + blen, mg->mg_len - cache[0]);
6473                 } else {
6474                     len = cache[0] + utf8_length(s + cache[1], send);
6475                 }
6476             }
6477             else if (cache[3] < byte) {
6478                 /* We're between the two cached pairs, so we do the calculation
6479                    offset by the byte/utf-8 positions for the earlier pair,
6480                    then add the utf-8 characters from the string start to
6481                    there.  */
6482                 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6483                                           s + cache[1], cache[0] - cache[2])
6484                     + cache[2];
6485
6486             }
6487             else { /* cache[3] > byte */
6488                 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6489                                           cache[2]);
6490
6491             }
6492             ASSERT_UTF8_CACHE(cache);
6493             found = TRUE;
6494         } else if (mg->mg_len != -1) {
6495             len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6496             found = TRUE;
6497         }
6498     }
6499     if (!found || PL_utf8cache < 0) {
6500         const STRLEN real_len = utf8_length(s, send);
6501
6502         if (found && PL_utf8cache < 0) {
6503             if (len != real_len) {
6504                 /* Need to turn the assertions off otherwise we may recurse
6505                    infinitely while printing error messages.  */
6506                 SAVEI8(PL_utf8cache);
6507                 PL_utf8cache = 0;
6508                 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6509                            " real %"UVuf" for %"SVf,
6510                            (UV) len, (UV) real_len, SVfARG(sv));
6511             }
6512         }
6513         len = real_len;
6514     }
6515     *offsetp = len;
6516
6517     if (PL_utf8cache)
6518         utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6519 }
6520
6521 /*
6522 =for apidoc sv_eq
6523
6524 Returns a boolean indicating whether the strings in the two SVs are
6525 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6526 coerce its args to strings if necessary.
6527
6528 =cut
6529 */
6530
6531 I32
6532 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6533 {
6534     dVAR;
6535     const char *pv1;
6536     STRLEN cur1;
6537     const char *pv2;
6538     STRLEN cur2;
6539     I32  eq     = 0;
6540     char *tpv   = NULL;
6541     SV* svrecode = NULL;
6542
6543     if (!sv1) {
6544         pv1 = "";
6545         cur1 = 0;
6546     }
6547     else {
6548         /* if pv1 and pv2 are the same, second SvPV_const call may
6549          * invalidate pv1, so we may need to make a copy */
6550         if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6551             pv1 = SvPV_const(sv1, cur1);
6552             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6553         }
6554         pv1 = SvPV_const(sv1, cur1);
6555     }
6556
6557     if (!sv2){
6558         pv2 = "";
6559         cur2 = 0;
6560     }
6561     else
6562         pv2 = SvPV_const(sv2, cur2);
6563
6564     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6565         /* Differing utf8ness.
6566          * Do not UTF8size the comparands as a side-effect. */
6567          if (PL_encoding) {
6568               if (SvUTF8(sv1)) {
6569                    svrecode = newSVpvn(pv2, cur2);
6570                    sv_recode_to_utf8(svrecode, PL_encoding);
6571                    pv2 = SvPV_const(svrecode, cur2);
6572               }
6573               else {
6574                    svrecode = newSVpvn(pv1, cur1);
6575                    sv_recode_to_utf8(svrecode, PL_encoding);
6576                    pv1 = SvPV_const(svrecode, cur1);
6577               }
6578               /* Now both are in UTF-8. */
6579               if (cur1 != cur2) {
6580                    SvREFCNT_dec(svrecode);
6581                    return FALSE;
6582               }
6583          }
6584          else {
6585               bool is_utf8 = TRUE;
6586
6587               if (SvUTF8(sv1)) {
6588                    /* sv1 is the UTF-8 one,
6589                     * if is equal it must be downgrade-able */
6590                    char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6591                                                      &cur1, &is_utf8);
6592                    if (pv != pv1)
6593                         pv1 = tpv = pv;
6594               }
6595               else {
6596                    /* sv2 is the UTF-8 one,
6597                     * if is equal it must be downgrade-able */
6598                    char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6599                                                       &cur2, &is_utf8);
6600                    if (pv != pv2)
6601                         pv2 = tpv = pv;
6602               }
6603               if (is_utf8) {
6604                    /* Downgrade not possible - cannot be eq */
6605                    assert (tpv == 0);
6606                    return FALSE;
6607               }
6608          }
6609     }
6610
6611     if (cur1 == cur2)
6612         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6613
6614     SvREFCNT_dec(svrecode);
6615     if (tpv)
6616         Safefree(tpv);
6617
6618     return eq;
6619 }
6620
6621 /*
6622 =for apidoc sv_cmp
6623
6624 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
6625 string in C<sv1> is less than, equal to, or greater than the string in
6626 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6627 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
6628
6629 =cut
6630 */
6631
6632 I32
6633 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6634 {
6635     dVAR;
6636     STRLEN cur1, cur2;
6637     const char *pv1, *pv2;
6638     char *tpv = NULL;
6639     I32  cmp;
6640     SV *svrecode = NULL;
6641
6642     if (!sv1) {
6643         pv1 = "";
6644         cur1 = 0;
6645     }
6646     else
6647         pv1 = SvPV_const(sv1, cur1);
6648
6649     if (!sv2) {
6650         pv2 = "";
6651         cur2 = 0;
6652     }
6653     else
6654         pv2 = SvPV_const(sv2, cur2);
6655
6656     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6657         /* Differing utf8ness.
6658          * Do not UTF8size the comparands as a side-effect. */
6659         if (SvUTF8(sv1)) {
6660             if (PL_encoding) {
6661                  svrecode = newSVpvn(pv2, cur2);
6662                  sv_recode_to_utf8(svrecode, PL_encoding);
6663                  pv2 = SvPV_const(svrecode, cur2);
6664             }
6665             else {
6666                  pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6667             }
6668         }
6669         else {
6670             if (PL_encoding) {
6671                  svrecode = newSVpvn(pv1, cur1);
6672                  sv_recode_to_utf8(svrecode, PL_encoding);
6673                  pv1 = SvPV_const(svrecode, cur1);
6674             }
6675             else {
6676                  pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6677             }
6678         }
6679     }
6680
6681     if (!cur1) {
6682         cmp = cur2 ? -1 : 0;
6683     } else if (!cur2) {
6684         cmp = 1;
6685     } else {
6686         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6687
6688         if (retval) {
6689             cmp = retval < 0 ? -1 : 1;
6690         } else if (cur1 == cur2) {
6691             cmp = 0;
6692         } else {
6693             cmp = cur1 < cur2 ? -1 : 1;
6694         }
6695     }
6696
6697     SvREFCNT_dec(svrecode);
6698     if (tpv)
6699         Safefree(tpv);
6700
6701     return cmp;
6702 }
6703
6704 /*
6705 =for apidoc sv_cmp_locale
6706
6707 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6708 'use bytes' aware, handles get magic, and will coerce its args to strings
6709 if necessary.  See also C<sv_cmp>.
6710
6711 =cut
6712 */
6713
6714 I32
6715 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6716 {
6717     dVAR;
6718 #ifdef USE_LOCALE_COLLATE
6719
6720     char *pv1, *pv2;
6721     STRLEN len1, len2;
6722     I32 retval;
6723
6724     if (PL_collation_standard)
6725         goto raw_compare;
6726
6727     len1 = 0;
6728     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6729     len2 = 0;
6730     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6731
6732     if (!pv1 || !len1) {
6733         if (pv2 && len2)
6734             return -1;
6735         else
6736             goto raw_compare;
6737     }
6738     else {
6739         if (!pv2 || !len2)
6740             return 1;
6741     }
6742
6743     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6744
6745     if (retval)
6746         return retval < 0 ? -1 : 1;
6747
6748     /*
6749      * When the result of collation is equality, that doesn't mean
6750      * that there are no differences -- some locales exclude some
6751      * characters from consideration.  So to avoid false equalities,
6752      * we use the raw string as a tiebreaker.
6753      */
6754
6755   raw_compare:
6756     /*FALLTHROUGH*/
6757
6758 #endif /* USE_LOCALE_COLLATE */
6759
6760     return sv_cmp(sv1, sv2);
6761 }
6762
6763
6764 #ifdef USE_LOCALE_COLLATE
6765
6766 /*
6767 =for apidoc sv_collxfrm
6768
6769 Add Collate Transform magic to an SV if it doesn't already have it.
6770
6771 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6772 scalar data of the variable, but transformed to such a format that a normal
6773 memory comparison can be used to compare the data according to the locale
6774 settings.
6775
6776 =cut
6777 */
6778
6779 char *
6780 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6781 {
6782     dVAR;
6783     MAGIC *mg;
6784
6785     PERL_ARGS_ASSERT_SV_COLLXFRM;
6786
6787     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6788     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6789         const char *s;
6790         char *xf;
6791         STRLEN len, xlen;
6792
6793         if (mg)
6794             Safefree(mg->mg_ptr);
6795         s = SvPV_const(sv, len);
6796         if ((xf = mem_collxfrm(s, len, &xlen))) {
6797             if (! mg) {
6798 #ifdef PERL_OLD_COPY_ON_WRITE
6799                 if (SvIsCOW(sv))
6800                     sv_force_normal_flags(sv, 0);
6801 #endif
6802                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6803                                  0, 0);
6804                 assert(mg);
6805             }
6806             mg->mg_ptr = xf;
6807             mg->mg_len = xlen;
6808         }
6809         else {
6810             if (mg) {
6811                 mg->mg_ptr = NULL;
6812                 mg->mg_len = -1;
6813             }
6814         }
6815     }
6816     if (mg && mg->mg_ptr) {
6817         *nxp = mg->mg_len;
6818         return mg->mg_ptr + sizeof(PL_collation_ix);
6819     }
6820     else {
6821         *nxp = 0;
6822         return NULL;
6823     }
6824 }
6825
6826 #endif /* USE_LOCALE_COLLATE */
6827
6828 /*
6829 =for apidoc sv_gets
6830
6831 Get a line from the filehandle and store it into the SV, optionally
6832 appending to the currently-stored string.
6833
6834 =cut
6835 */
6836
6837 char *
6838 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6839 {
6840     dVAR;
6841     const char *rsptr;
6842     STRLEN rslen;
6843     register STDCHAR rslast;
6844     register STDCHAR *bp;
6845     register I32 cnt;
6846     I32 i = 0;
6847     I32 rspara = 0;
6848
6849     PERL_ARGS_ASSERT_SV_GETS;
6850
6851     if (SvTHINKFIRST(sv))
6852         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6853     /* XXX. If you make this PVIV, then copy on write can copy scalars read
6854        from <>.
6855        However, perlbench says it's slower, because the existing swipe code
6856        is faster than copy on write.
6857        Swings and roundabouts.  */
6858     SvUPGRADE(sv, SVt_PV);
6859
6860     SvSCREAM_off(sv);
6861
6862     if (append) {
6863         if (PerlIO_isutf8(fp)) {
6864             if (!SvUTF8(sv)) {
6865                 sv_utf8_upgrade_nomg(sv);
6866                 sv_pos_u2b(sv,&append,0);
6867             }
6868         } else if (SvUTF8(sv)) {
6869             SV * const tsv = newSV(0);
6870             sv_gets(tsv, fp, 0);
6871             sv_utf8_upgrade_nomg(tsv);
6872             SvCUR_set(sv,append);
6873             sv_catsv(sv,tsv);
6874             sv_free(tsv);
6875             goto return_string_or_null;
6876         }
6877     }
6878
6879     SvPOK_only(sv);
6880     if (PerlIO_isutf8(fp))
6881         SvUTF8_on(sv);
6882
6883     if (IN_PERL_COMPILETIME) {
6884         /* we always read code in line mode */
6885         rsptr = "\n";
6886         rslen = 1;
6887     }
6888     else if (RsSNARF(PL_rs)) {
6889         /* If it is a regular disk file use size from stat() as estimate
6890            of amount we are going to read -- may result in mallocing
6891            more memory than we really need if the layers below reduce
6892            the size we read (e.g. CRLF or a gzip layer).
6893          */
6894         Stat_t st;
6895         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
6896             const Off_t offset = PerlIO_tell(fp);
6897             if (offset != (Off_t) -1 && st.st_size + append > offset) {
6898                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6899             }
6900         }
6901         rsptr = NULL;
6902         rslen = 0;
6903     }
6904     else if (RsRECORD(PL_rs)) {
6905       I32 bytesread;
6906       char *buffer;
6907       U32 recsize;
6908 #ifdef VMS
6909       int fd;
6910 #endif
6911
6912       /* Grab the size of the record we're getting */
6913       recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
6914       buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6915       /* Go yank in */
6916 #ifdef VMS
6917       /* VMS wants read instead of fread, because fread doesn't respect */
6918       /* RMS record boundaries. This is not necessarily a good thing to be */
6919       /* doing, but we've got no other real choice - except avoid stdio
6920          as implementation - perhaps write a :vms layer ?
6921        */
6922       fd = PerlIO_fileno(fp);
6923       if (fd == -1) { /* in-memory file from PerlIO::Scalar */
6924           bytesread = PerlIO_read(fp, buffer, recsize);
6925       }
6926       else {
6927           bytesread = PerlLIO_read(fd, buffer, recsize);
6928       }
6929 #else
6930       bytesread = PerlIO_read(fp, buffer, recsize);
6931 #endif
6932       if (bytesread < 0)
6933           bytesread = 0;
6934       SvCUR_set(sv, bytesread + append);
6935       buffer[bytesread] = '\0';
6936       goto return_string_or_null;
6937     }
6938     else if (RsPARA(PL_rs)) {
6939         rsptr = "\n\n";
6940         rslen = 2;
6941         rspara = 1;
6942     }
6943     else {
6944         /* Get $/ i.e. PL_rs into same encoding as stream wants */
6945         if (PerlIO_isutf8(fp)) {
6946             rsptr = SvPVutf8(PL_rs, rslen);
6947         }
6948         else {
6949             if (SvUTF8(PL_rs)) {
6950                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6951                     Perl_croak(aTHX_ "Wide character in $/");
6952                 }
6953             }
6954             rsptr = SvPV_const(PL_rs, rslen);
6955         }
6956     }
6957
6958     rslast = rslen ? rsptr[rslen - 1] : '\0';
6959
6960     if (rspara) {               /* have to do this both before and after */
6961         do {                    /* to make sure file boundaries work right */
6962             if (PerlIO_eof(fp))
6963                 return 0;
6964             i = PerlIO_getc(fp);
6965             if (i != '\n') {
6966                 if (i == -1)
6967                     return 0;
6968                 PerlIO_ungetc(fp,i);
6969                 break;
6970             }
6971         } while (i != EOF);
6972     }
6973
6974     /* See if we know enough about I/O mechanism to cheat it ! */
6975
6976     /* This used to be #ifdef test - it is made run-time test for ease
6977        of abstracting out stdio interface. One call should be cheap
6978        enough here - and may even be a macro allowing compile
6979        time optimization.
6980      */
6981
6982     if (PerlIO_fast_gets(fp)) {
6983
6984     /*
6985      * We're going to steal some values from the stdio struct
6986      * and put EVERYTHING in the innermost loop into registers.
6987      */
6988     register STDCHAR *ptr;
6989     STRLEN bpx;
6990     I32 shortbuffered;
6991
6992 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6993     /* An ungetc()d char is handled separately from the regular
6994      * buffer, so we getc() it back out and stuff it in the buffer.
6995      */
6996     i = PerlIO_getc(fp);
6997     if (i == EOF) return 0;
6998     *(--((*fp)->_ptr)) = (unsigned char) i;
6999     (*fp)->_cnt++;
7000 #endif
7001
7002     /* Here is some breathtakingly efficient cheating */
7003
7004     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
7005     /* make sure we have the room */
7006     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7007         /* Not room for all of it
7008            if we are looking for a separator and room for some
7009          */
7010         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7011             /* just process what we have room for */
7012             shortbuffered = cnt - SvLEN(sv) + append + 1;
7013             cnt -= shortbuffered;
7014         }
7015         else {
7016             shortbuffered = 0;
7017             /* remember that cnt can be negative */
7018             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7019         }
7020     }
7021     else
7022         shortbuffered = 0;
7023     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
7024     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7025     DEBUG_P(PerlIO_printf(Perl_debug_log,
7026         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7027     DEBUG_P(PerlIO_printf(Perl_debug_log,
7028         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7029                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7030                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7031     for (;;) {
7032       screamer:
7033         if (cnt > 0) {
7034             if (rslen) {
7035                 while (cnt > 0) {                    /* this     |  eat */
7036                     cnt--;
7037                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
7038                         goto thats_all_folks;        /* screams  |  sed :-) */
7039                 }
7040             }
7041             else {
7042                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
7043                 bp += cnt;                           /* screams  |  dust */
7044                 ptr += cnt;                          /* louder   |  sed :-) */
7045                 cnt = 0;
7046             }
7047         }
7048
7049         if (shortbuffered) {            /* oh well, must extend */
7050             cnt = shortbuffered;
7051             shortbuffered = 0;
7052             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7053             SvCUR_set(sv, bpx);
7054             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7055             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7056             continue;
7057         }
7058
7059         DEBUG_P(PerlIO_printf(Perl_debug_log,
7060                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7061                               PTR2UV(ptr),(long)cnt));
7062         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7063 #if 0
7064         DEBUG_P(PerlIO_printf(Perl_debug_log,
7065             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7066             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7067             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7068 #endif
7069         /* This used to call 'filbuf' in stdio form, but as that behaves like
7070            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7071            another abstraction.  */
7072         i   = PerlIO_getc(fp);          /* get more characters */
7073 #if 0
7074         DEBUG_P(PerlIO_printf(Perl_debug_log,
7075             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7076             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7077             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7078 #endif
7079         cnt = PerlIO_get_cnt(fp);
7080         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
7081         DEBUG_P(PerlIO_printf(Perl_debug_log,
7082             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7083
7084         if (i == EOF)                   /* all done for ever? */
7085             goto thats_really_all_folks;
7086
7087         bpx = bp - (STDCHAR*)SvPVX_const(sv);   /* box up before relocation */
7088         SvCUR_set(sv, bpx);
7089         SvGROW(sv, bpx + cnt + 2);
7090         bp = (STDCHAR*)SvPVX_const(sv) + bpx;   /* unbox after relocation */
7091
7092         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
7093
7094         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
7095             goto thats_all_folks;
7096     }
7097
7098 thats_all_folks:
7099     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7100           memNE((char*)bp - rslen, rsptr, rslen))
7101         goto screamer;                          /* go back to the fray */
7102 thats_really_all_folks:
7103     if (shortbuffered)
7104         cnt += shortbuffered;
7105         DEBUG_P(PerlIO_printf(Perl_debug_log,
7106             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7107     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
7108     DEBUG_P(PerlIO_printf(Perl_debug_log,
7109         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7110         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7111         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7112     *bp = '\0';
7113     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));      /* set length */
7114     DEBUG_P(PerlIO_printf(Perl_debug_log,
7115         "Screamer: done, len=%ld, string=|%.*s|\n",
7116         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7117     }
7118    else
7119     {
7120        /*The big, slow, and stupid way. */
7121 #ifdef USE_HEAP_INSTEAD_OF_STACK        /* Even slower way. */
7122         STDCHAR *buf = NULL;
7123         Newx(buf, 8192, STDCHAR);
7124         assert(buf);
7125 #else
7126         STDCHAR buf[8192];
7127 #endif
7128
7129 screamer2:
7130         if (rslen) {
7131             register const STDCHAR * const bpe = buf + sizeof(buf);
7132             bp = buf;
7133             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7134                 ; /* keep reading */
7135             cnt = bp - buf;
7136         }
7137         else {
7138             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7139             /* Accomodate broken VAXC compiler, which applies U8 cast to
7140              * both args of ?: operator, causing EOF to change into 255
7141              */
7142             if (cnt > 0)
7143                  i = (U8)buf[cnt - 1];
7144             else
7145                  i = EOF;
7146         }
7147
7148         if (cnt < 0)
7149             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
7150         if (append)
7151              sv_catpvn(sv, (char *) buf, cnt);
7152         else
7153              sv_setpvn(sv, (char *) buf, cnt);
7154
7155         if (i != EOF &&                 /* joy */
7156             (!rslen ||
7157              SvCUR(sv) < rslen ||
7158              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7159         {
7160             append = -1;
7161             /*
7162              * If we're reading from a TTY and we get a short read,
7163              * indicating that the user hit his EOF character, we need
7164              * to notice it now, because if we try to read from the TTY
7165              * again, the EOF condition will disappear.
7166              *
7167              * The comparison of cnt to sizeof(buf) is an optimization
7168              * that prevents unnecessary calls to feof().
7169              *
7170              * - jik 9/25/96
7171              */
7172             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7173                 goto screamer2;
7174         }
7175
7176 #ifdef USE_HEAP_INSTEAD_OF_STACK
7177         Safefree(buf);
7178 #endif
7179     }
7180
7181     if (rspara) {               /* have to do this both before and after */
7182         while (i != EOF) {      /* to make sure file boundaries work right */
7183             i = PerlIO_getc(fp);
7184             if (i != '\n') {
7185                 PerlIO_ungetc(fp,i);
7186                 break;
7187             }
7188         }
7189     }
7190
7191 return_string_or_null:
7192     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7193 }
7194
7195 /*
7196 =for apidoc sv_inc
7197
7198 Auto-increment of the value in the SV, doing string to numeric conversion
7199 if necessary. Handles 'get' magic.
7200
7201 =cut
7202 */
7203
7204 void
7205 Perl_sv_inc(pTHX_ register SV *const sv)
7206 {
7207     dVAR;
7208     register char *d;
7209     int flags;
7210
7211     if (!sv)
7212         return;
7213     SvGETMAGIC(sv);
7214     if (SvTHINKFIRST(sv)) {
7215         if (SvIsCOW(sv))
7216             sv_force_normal_flags(sv, 0);
7217         if (SvREADONLY(sv)) {
7218             if (IN_PERL_RUNTIME)
7219                 Perl_croak(aTHX_ "%s", PL_no_modify);
7220         }
7221         if (SvROK(sv)) {
7222             IV i;
7223             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7224                 return;
7225             i = PTR2IV(SvRV(sv));
7226             sv_unref(sv);
7227             sv_setiv(sv, i);
7228         }
7229     }
7230     flags = SvFLAGS(sv);
7231     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7232         /* It's (privately or publicly) a float, but not tested as an
7233            integer, so test it to see. */
7234         (void) SvIV(sv);
7235         flags = SvFLAGS(sv);
7236     }
7237     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7238         /* It's publicly an integer, or privately an integer-not-float */
7239 #ifdef PERL_PRESERVE_IVUV
7240       oops_its_int:
7241 #endif
7242         if (SvIsUV(sv)) {
7243             if (SvUVX(sv) == UV_MAX)
7244                 sv_setnv(sv, UV_MAX_P1);
7245             else
7246                 (void)SvIOK_only_UV(sv);
7247                 SvUV_set(sv, SvUVX(sv) + 1);
7248         } else {
7249             if (SvIVX(sv) == IV_MAX)
7250                 sv_setuv(sv, (UV)IV_MAX + 1);
7251             else {
7252                 (void)SvIOK_only(sv);
7253                 SvIV_set(sv, SvIVX(sv) + 1);
7254             }
7255         }
7256         return;
7257     }
7258     if (flags & SVp_NOK) {
7259         const NV was = SvNVX(sv);
7260         if (NV_OVERFLOWS_INTEGERS_AT &&
7261             was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7262             Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7263                         "Lost precision when incrementing %" NVff " by 1",
7264                         was);
7265         }
7266         (void)SvNOK_only(sv);
7267         SvNV_set(sv, was + 1.0);
7268         return;
7269     }
7270
7271     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7272         if ((flags & SVTYPEMASK) < SVt_PVIV)
7273             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7274         (void)SvIOK_only(sv);
7275         SvIV_set(sv, 1);
7276         return;
7277     }
7278     d = SvPVX(sv);
7279     while (isALPHA(*d)) d++;
7280     while (isDIGIT(*d)) d++;
7281     if (*d) {
7282 #ifdef PERL_PRESERVE_IVUV
7283         /* Got to punt this as an integer if needs be, but we don't issue
7284            warnings. Probably ought to make the sv_iv_please() that does
7285            the conversion if possible, and silently.  */
7286         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7287         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7288             /* Need to try really hard to see if it's an integer.
7289                9.22337203685478e+18 is an integer.
7290                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7291                so $a="9.22337203685478e+18"; $a+0; $a++
7292                needs to be the same as $a="9.22337203685478e+18"; $a++
7293                or we go insane. */
7294
7295             (void) sv_2iv(sv);
7296             if (SvIOK(sv))
7297                 goto oops_its_int;
7298
7299             /* sv_2iv *should* have made this an NV */
7300             if (flags & SVp_NOK) {
7301                 (void)SvNOK_only(sv);
7302                 SvNV_set(sv, SvNVX(sv) + 1.0);
7303                 return;
7304             }
7305             /* I don't think we can get here. Maybe I should assert this
7306                And if we do get here I suspect that sv_setnv will croak. NWC
7307                Fall through. */
7308 #if defined(USE_LONG_DOUBLE)
7309             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",
7310                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7311 #else
7312             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7313                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7314 #endif
7315         }
7316 #endif /* PERL_PRESERVE_IVUV */
7317         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7318         return;
7319     }
7320     d--;
7321     while (d >= SvPVX_const(sv)) {
7322         if (isDIGIT(*d)) {
7323             if (++*d <= '9')
7324                 return;
7325             *(d--) = '0';
7326         }
7327         else {
7328 #ifdef EBCDIC
7329             /* MKS: The original code here died if letters weren't consecutive.
7330              * at least it didn't have to worry about non-C locales.  The
7331              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7332              * arranged in order (although not consecutively) and that only
7333              * [A-Za-z] are accepted by isALPHA in the C locale.
7334              */
7335             if (*d != 'z' && *d != 'Z') {
7336                 do { ++*d; } while (!isALPHA(*d));
7337                 return;
7338             }
7339             *(d--) -= 'z' - 'a';
7340 #else
7341             ++*d;
7342             if (isALPHA(*d))
7343                 return;
7344             *(d--) -= 'z' - 'a' + 1;
7345 #endif
7346         }
7347     }
7348     /* oh,oh, the number grew */
7349     SvGROW(sv, SvCUR(sv) + 2);
7350     SvCUR_set(sv, SvCUR(sv) + 1);
7351     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7352         *d = d[-1];
7353     if (isDIGIT(d[1]))
7354         *d = '1';
7355     else
7356         *d = d[1];
7357 }
7358
7359 /*
7360 =for apidoc sv_dec
7361
7362 Auto-decrement of the value in the SV, doing string to numeric conversion
7363 if necessary. Handles 'get' magic.
7364
7365 =cut
7366 */
7367
7368 void
7369 Perl_sv_dec(pTHX_ register SV *const sv)
7370 {
7371     dVAR;
7372     int flags;
7373
7374     if (!sv)
7375         return;
7376     SvGETMAGIC(sv);
7377     if (SvTHINKFIRST(sv)) {
7378         if (SvIsCOW(sv))
7379             sv_force_normal_flags(sv, 0);
7380         if (SvREADONLY(sv)) {
7381             if (IN_PERL_RUNTIME)
7382                 Perl_croak(aTHX_ "%s", PL_no_modify);
7383         }
7384         if (SvROK(sv)) {
7385             IV i;
7386             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7387                 return;
7388             i = PTR2IV(SvRV(sv));
7389             sv_unref(sv);
7390             sv_setiv(sv, i);
7391         }
7392     }
7393     /* Unlike sv_inc we don't have to worry about string-never-numbers
7394        and keeping them magic. But we mustn't warn on punting */
7395     flags = SvFLAGS(sv);
7396     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7397         /* It's publicly an integer, or privately an integer-not-float */
7398 #ifdef PERL_PRESERVE_IVUV
7399       oops_its_int:
7400 #endif
7401         if (SvIsUV(sv)) {
7402             if (SvUVX(sv) == 0) {
7403                 (void)SvIOK_only(sv);
7404                 SvIV_set(sv, -1);
7405             }
7406             else {
7407                 (void)SvIOK_only_UV(sv);
7408                 SvUV_set(sv, SvUVX(sv) - 1);
7409             }
7410         } else {
7411             if (SvIVX(sv) == IV_MIN) {
7412                 sv_setnv(sv, (NV)IV_MIN);
7413                 goto oops_its_num;
7414             }
7415             else {
7416                 (void)SvIOK_only(sv);
7417                 SvIV_set(sv, SvIVX(sv) - 1);
7418             }
7419         }
7420         return;
7421     }
7422     if (flags & SVp_NOK) {
7423     oops_its_num:
7424         {
7425             const NV was = SvNVX(sv);
7426             if (NV_OVERFLOWS_INTEGERS_AT &&
7427                 was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7428                 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7429                             "Lost precision when decrementing %" NVff " by 1",
7430                             was);
7431             }
7432             (void)SvNOK_only(sv);
7433             SvNV_set(sv, was - 1.0);
7434             return;
7435         }
7436     }
7437     if (!(flags & SVp_POK)) {
7438         if ((flags & SVTYPEMASK) < SVt_PVIV)
7439             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7440         SvIV_set(sv, -1);
7441         (void)SvIOK_only(sv);
7442         return;
7443     }
7444 #ifdef PERL_PRESERVE_IVUV
7445     {
7446         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7447         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7448             /* Need to try really hard to see if it's an integer.
7449                9.22337203685478e+18 is an integer.
7450                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7451                so $a="9.22337203685478e+18"; $a+0; $a--
7452                needs to be the same as $a="9.22337203685478e+18"; $a--
7453                or we go insane. */
7454
7455             (void) sv_2iv(sv);
7456             if (SvIOK(sv))
7457                 goto oops_its_int;
7458
7459             /* sv_2iv *should* have made this an NV */
7460             if (flags & SVp_NOK) {
7461                 (void)SvNOK_only(sv);
7462                 SvNV_set(sv, SvNVX(sv) - 1.0);
7463                 return;
7464             }
7465             /* I don't think we can get here. Maybe I should assert this
7466                And if we do get here I suspect that sv_setnv will croak. NWC
7467                Fall through. */
7468 #if defined(USE_LONG_DOUBLE)
7469             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",
7470                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7471 #else
7472             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7473                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7474 #endif
7475         }
7476     }
7477 #endif /* PERL_PRESERVE_IVUV */
7478     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);   /* punt */
7479 }
7480
7481 /*
7482 =for apidoc sv_mortalcopy
7483
7484 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7485 The new SV is marked as mortal. It will be destroyed "soon", either by an
7486 explicit call to FREETMPS, or by an implicit call at places such as
7487 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
7488
7489 =cut
7490 */
7491
7492 /* Make a string that will exist for the duration of the expression
7493  * evaluation.  Actually, it may have to last longer than that, but
7494  * hopefully we won't free it until it has been assigned to a
7495  * permanent location. */
7496
7497 SV *
7498 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7499 {
7500     dVAR;
7501     register SV *sv;
7502
7503     new_SV(sv);
7504     sv_setsv(sv,oldstr);
7505     EXTEND_MORTAL(1);
7506     PL_tmps_stack[++PL_tmps_ix] = sv;
7507     SvTEMP_on(sv);
7508     return sv;
7509 }
7510
7511 /*
7512 =for apidoc sv_newmortal
7513
7514 Creates a new null SV which is mortal.  The reference count of the SV is
7515 set to 1. It will be destroyed "soon", either by an explicit call to
7516 FREETMPS, or by an implicit call at places such as statement boundaries.
7517 See also C<sv_mortalcopy> and C<sv_2mortal>.
7518
7519 =cut
7520 */
7521
7522 SV *
7523 Perl_sv_newmortal(pTHX)
7524 {
7525     dVAR;
7526     register SV *sv;
7527
7528     new_SV(sv);
7529     SvFLAGS(sv) = SVs_TEMP;
7530     EXTEND_MORTAL(1);
7531     PL_tmps_stack[++PL_tmps_ix] = sv;
7532     return sv;
7533 }
7534
7535
7536 /*
7537 =for apidoc newSVpvn_flags
7538
7539 Creates a new SV and copies a string into it.  The reference count for the
7540 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7541 string.  You are responsible for ensuring that the source string is at least
7542 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7543 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7544 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7545 returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
7546 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7547
7548     #define newSVpvn_utf8(s, len, u)                    \
7549         newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7550
7551 =cut
7552 */
7553
7554 SV *
7555 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7556 {
7557     dVAR;
7558     register SV *sv;
7559
7560     /* All the flags we don't support must be zero.
7561        And we're new code so I'm going to assert this from the start.  */
7562     assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7563     new_SV(sv);
7564     sv_setpvn(sv,s,len);
7565     SvFLAGS(sv) |= (flags & SVf_UTF8);
7566     return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
7567 }
7568
7569 /*
7570 =for apidoc sv_2mortal
7571
7572 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
7573 by an explicit call to FREETMPS, or by an implicit call at places such as
7574 statement boundaries.  SvTEMP() is turned on which means that the SV's
7575 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7576 and C<sv_mortalcopy>.
7577
7578 =cut
7579 */
7580
7581 SV *
7582 Perl_sv_2mortal(pTHX_ register SV *const sv)
7583 {
7584     dVAR;
7585     if (!sv)
7586         return NULL;
7587     if (SvREADONLY(sv) && SvIMMORTAL(sv))
7588         return sv;
7589     EXTEND_MORTAL(1);
7590     PL_tmps_stack[++PL_tmps_ix] = sv;
7591     SvTEMP_on(sv);
7592     return sv;
7593 }
7594
7595 /*
7596 =for apidoc newSVpv
7597
7598 Creates a new SV and copies a string into it.  The reference count for the
7599 SV is set to 1.  If C<len> is zero, Perl will compute the length using
7600 strlen().  For efficiency, consider using C<newSVpvn> instead.
7601
7602 =cut
7603 */
7604
7605 SV *
7606 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7607 {
7608     dVAR;
7609     register SV *sv;
7610
7611     new_SV(sv);
7612     sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7613     return sv;
7614 }
7615
7616 /*
7617 =for apidoc newSVpvn
7618
7619 Creates a new SV and copies a string into it.  The reference count for the
7620 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7621 string.  You are responsible for ensuring that the source string is at least
7622 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7623
7624 =cut
7625 */
7626
7627 SV *
7628 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7629 {
7630     dVAR;
7631     register SV *sv;
7632
7633     new_SV(sv);
7634     sv_setpvn(sv,s,len);
7635     return sv;
7636 }
7637
7638 /*
7639 =for apidoc newSVhek
7640
7641 Creates a new SV from the hash key structure.  It will generate scalars that
7642 point to the shared string table where possible. Returns a new (undefined)
7643 SV if the hek is NULL.
7644
7645 =cut
7646 */
7647
7648 SV *
7649 Perl_newSVhek(pTHX_ const HEK *const hek)
7650 {
7651     dVAR;
7652     if (!hek) {
7653         SV *sv;
7654
7655         new_SV(sv);
7656         return sv;
7657     }
7658
7659     if (HEK_LEN(hek) == HEf_SVKEY) {
7660         return newSVsv(*(SV**)HEK_KEY(hek));
7661     } else {
7662         const int flags = HEK_FLAGS(hek);
7663         if (flags & HVhek_WASUTF8) {
7664             /* Trouble :-)
7665                Andreas would like keys he put in as utf8 to come back as utf8
7666             */
7667             STRLEN utf8_len = HEK_LEN(hek);
7668             const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7669             SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7670
7671             SvUTF8_on (sv);
7672             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7673             return sv;
7674         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7675             /* We don't have a pointer to the hv, so we have to replicate the
7676                flag into every HEK. This hv is using custom a hasing
7677                algorithm. Hence we can't return a shared string scalar, as
7678                that would contain the (wrong) hash value, and might get passed
7679                into an hv routine with a regular hash.
7680                Similarly, a hash that isn't using shared hash keys has to have
7681                the flag in every key so that we know not to try to call
7682                share_hek_kek on it.  */
7683
7684             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7685             if (HEK_UTF8(hek))
7686                 SvUTF8_on (sv);
7687             return sv;
7688         }
7689         /* This will be overwhelminly the most common case.  */
7690         {
7691             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7692                more efficient than sharepvn().  */
7693             SV *sv;
7694
7695             new_SV(sv);
7696             sv_upgrade(sv, SVt_PV);
7697             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7698             SvCUR_set(sv, HEK_LEN(hek));
7699             SvLEN_set(sv, 0);
7700             SvREADONLY_on(sv);
7701             SvFAKE_on(sv);
7702             SvPOK_on(sv);
7703             if (HEK_UTF8(hek))
7704                 SvUTF8_on(sv);
7705             return sv;
7706         }
7707     }
7708 }
7709
7710 /*
7711 =for apidoc newSVpvn_share
7712
7713 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7714 table. If the string does not already exist in the table, it is created
7715 first.  Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7716 value is used; otherwise the hash is computed. The string's hash can be later
7717 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7718 that as the string table is used for shared hash keys these strings will have
7719 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7720
7721 =cut
7722 */
7723
7724 SV *
7725 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7726 {
7727     dVAR;
7728     register SV *sv;
7729     bool is_utf8 = FALSE;
7730     const char *const orig_src = src;
7731
7732     if (len < 0) {
7733         STRLEN tmplen = -len;
7734         is_utf8 = TRUE;
7735         /* See the note in hv.c:hv_fetch() --jhi */
7736         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7737         len = tmplen;
7738     }
7739     if (!hash)
7740         PERL_HASH(hash, src, len);
7741     new_SV(sv);
7742     /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7743        changes here, update it there too.  */
7744     sv_upgrade(sv, SVt_PV);
7745     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7746     SvCUR_set(sv, len);
7747     SvLEN_set(sv, 0);
7748     SvREADONLY_on(sv);
7749     SvFAKE_on(sv);
7750     SvPOK_on(sv);
7751     if (is_utf8)
7752         SvUTF8_on(sv);
7753     if (src != orig_src)
7754         Safefree(src);
7755     return sv;
7756 }
7757
7758
7759 #if defined(PERL_IMPLICIT_CONTEXT)
7760
7761 /* pTHX_ magic can't cope with varargs, so this is a no-context
7762  * version of the main function, (which may itself be aliased to us).
7763  * Don't access this version directly.
7764  */
7765
7766 SV *
7767 Perl_newSVpvf_nocontext(const char *const pat, ...)
7768 {
7769     dTHX;
7770     register SV *sv;
7771     va_list args;
7772
7773     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7774
7775     va_start(args, pat);
7776     sv = vnewSVpvf(pat, &args);
7777     va_end(args);
7778     return sv;
7779 }
7780 #endif
7781
7782 /*
7783 =for apidoc newSVpvf
7784
7785 Creates a new SV and initializes it with the string formatted like
7786 C<sprintf>.
7787
7788 =cut
7789 */
7790
7791 SV *
7792 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7793 {
7794     register SV *sv;
7795     va_list args;
7796
7797     PERL_ARGS_ASSERT_NEWSVPVF;
7798
7799     va_start(args, pat);
7800     sv = vnewSVpvf(pat, &args);
7801     va_end(args);
7802     return sv;
7803 }
7804
7805 /* backend for newSVpvf() and newSVpvf_nocontext() */
7806
7807 SV *
7808 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7809 {
7810     dVAR;
7811     register SV *sv;
7812
7813     PERL_ARGS_ASSERT_VNEWSVPVF;
7814
7815     new_SV(sv);
7816     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7817     return sv;
7818 }
7819
7820 /*
7821 =for apidoc newSVnv
7822
7823 Creates a new SV and copies a floating point value into it.
7824 The reference count for the SV is set to 1.
7825
7826 =cut
7827 */
7828
7829 SV *
7830 Perl_newSVnv(pTHX_ const NV n)
7831 {
7832     dVAR;
7833     register SV *sv;
7834
7835     new_SV(sv);
7836     sv_setnv(sv,n);
7837     return sv;
7838 }
7839
7840 /*
7841 =for apidoc newSViv
7842
7843 Creates a new SV and copies an integer into it.  The reference count for the
7844 SV is set to 1.
7845
7846 =cut
7847 */
7848
7849 SV *
7850 Perl_newSViv(pTHX_ const IV i)
7851 {
7852     dVAR;
7853     register SV *sv;
7854
7855     new_SV(sv);
7856     sv_setiv(sv,i);
7857     return sv;
7858 }
7859
7860 /*
7861 =for apidoc newSVuv
7862
7863 Creates a new SV and copies an unsigned integer into it.
7864 The reference count for the SV is set to 1.
7865
7866 =cut
7867 */
7868
7869 SV *
7870 Perl_newSVuv(pTHX_ const UV u)
7871 {
7872     dVAR;
7873     register SV *sv;
7874
7875     new_SV(sv);
7876     sv_setuv(sv,u);
7877     return sv;
7878 }
7879
7880 /*
7881 =for apidoc newSV_type
7882
7883 Creates a new SV, of the type specified.  The reference count for the new SV
7884 is set to 1.
7885
7886 =cut
7887 */
7888
7889 SV *
7890 Perl_newSV_type(pTHX_ const svtype type)
7891 {
7892     register SV *sv;
7893
7894     new_SV(sv);
7895     sv_upgrade(sv, type);
7896     return sv;
7897 }
7898
7899 /*
7900 =for apidoc newRV_noinc
7901
7902 Creates an RV wrapper for an SV.  The reference count for the original
7903 SV is B<not> incremented.
7904
7905 =cut
7906 */
7907
7908 SV *
7909 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
7910 {
7911     dVAR;
7912     register SV *sv = newSV_type(SVt_IV);
7913
7914     PERL_ARGS_ASSERT_NEWRV_NOINC;
7915
7916     SvTEMP_off(tmpRef);
7917     SvRV_set(sv, tmpRef);
7918     SvROK_on(sv);
7919     return sv;
7920 }
7921
7922 /* newRV_inc is the official function name to use now.
7923  * newRV_inc is in fact #defined to newRV in sv.h
7924  */
7925
7926 SV *
7927 Perl_newRV(pTHX_ SV *const sv)
7928 {
7929     dVAR;
7930
7931     PERL_ARGS_ASSERT_NEWRV;
7932
7933     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
7934 }
7935
7936 /*
7937 =for apidoc newSVsv
7938
7939 Creates a new SV which is an exact duplicate of the original SV.
7940 (Uses C<sv_setsv>).
7941
7942 =cut
7943 */
7944
7945 SV *
7946 Perl_newSVsv(pTHX_ register SV *const old)
7947 {
7948     dVAR;
7949     register SV *sv;
7950
7951     if (!old)
7952         return NULL;
7953     if (SvTYPE(old) == SVTYPEMASK) {
7954         if (ckWARN_d(WARN_INTERNAL))
7955             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7956         return NULL;
7957     }
7958     new_SV(sv);
7959     /* SV_GMAGIC is the default for sv_setv()
7960        SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7961        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
7962     sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7963     return sv;
7964 }
7965
7966 /*
7967 =for apidoc sv_reset
7968
7969 Underlying implementation for the C<reset> Perl function.
7970 Note that the perl-level function is vaguely deprecated.
7971
7972 =cut
7973 */
7974
7975 void
7976 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
7977 {
7978     dVAR;
7979     char todo[PERL_UCHAR_MAX+1];
7980
7981     PERL_ARGS_ASSERT_SV_RESET;
7982
7983     if (!stash)
7984         return;
7985
7986     if (!*s) {          /* reset ?? searches */
7987         MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
7988         if (mg) {
7989             const U32 count = mg->mg_len / sizeof(PMOP**);
7990             PMOP **pmp = (PMOP**) mg->mg_ptr;
7991             PMOP *const *const end = pmp + count;
7992
7993             while (pmp < end) {
7994 #ifdef USE_ITHREADS
7995                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
7996 #else
7997                 (*pmp)->op_pmflags &= ~PMf_USED;
7998 #endif
7999                 ++pmp;
8000             }
8001         }
8002         return;
8003     }
8004
8005     /* reset variables */
8006
8007     if (!HvARRAY(stash))
8008         return;
8009
8010     Zero(todo, 256, char);
8011     while (*s) {
8012         I32 max;
8013         I32 i = (unsigned char)*s;
8014         if (s[1] == '-') {
8015             s += 2;
8016         }
8017         max = (unsigned char)*s++;
8018         for ( ; i <= max; i++) {
8019             todo[i] = 1;
8020         }
8021         for (i = 0; i <= (I32) HvMAX(stash); i++) {
8022             HE *entry;
8023             for (entry = HvARRAY(stash)[i];
8024                  entry;
8025                  entry = HeNEXT(entry))
8026             {
8027                 register GV *gv;
8028                 register SV *sv;
8029
8030                 if (!todo[(U8)*HeKEY(entry)])
8031                     continue;
8032                 gv = MUTABLE_GV(HeVAL(entry));
8033                 sv = GvSV(gv);
8034                 if (sv) {
8035                     if (SvTHINKFIRST(sv)) {
8036                         if (!SvREADONLY(sv) && SvROK(sv))
8037                             sv_unref(sv);
8038                         /* XXX Is this continue a bug? Why should THINKFIRST
8039                            exempt us from resetting arrays and hashes?  */
8040                         continue;
8041                     }
8042                     SvOK_off(sv);
8043                     if (SvTYPE(sv) >= SVt_PV) {
8044                         SvCUR_set(sv, 0);
8045                         if (SvPVX_const(sv) != NULL)
8046                             *SvPVX(sv) = '\0';
8047                         SvTAINT(sv);
8048                     }
8049                 }
8050                 if (GvAV(gv)) {
8051                     av_clear(GvAV(gv));
8052                 }
8053                 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8054 #if defined(VMS)
8055                     Perl_die(aTHX_ "Can't reset %%ENV on this system");
8056 #else /* ! VMS */
8057                     hv_clear(GvHV(gv));
8058 #  if defined(USE_ENVIRON_ARRAY)
8059                     if (gv == PL_envgv)
8060                         my_clearenv();
8061 #  endif /* USE_ENVIRON_ARRAY */
8062 #endif /* VMS */
8063                 }
8064             }
8065         }
8066     }
8067 }
8068
8069 /*
8070 =for apidoc sv_2io
8071
8072 Using various gambits, try to get an IO from an SV: the IO slot if its a
8073 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8074 named after the PV if we're a string.
8075
8076 =cut
8077 */
8078
8079 IO*
8080 Perl_sv_2io(pTHX_ SV *const sv)
8081 {
8082     IO* io;
8083     GV* gv;
8084
8085     PERL_ARGS_ASSERT_SV_2IO;
8086
8087     switch (SvTYPE(sv)) {
8088     case SVt_PVIO:
8089         io = MUTABLE_IO(sv);
8090         break;
8091     case SVt_PVGV:
8092         if (isGV_with_GP(sv)) {
8093             gv = MUTABLE_GV(sv);
8094             io = GvIO(gv);
8095             if (!io)
8096                 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8097             break;
8098         }
8099         /* FALL THROUGH */
8100     default:
8101         if (!SvOK(sv))
8102             Perl_croak(aTHX_ PL_no_usym, "filehandle");
8103         if (SvROK(sv))
8104             return sv_2io(SvRV(sv));
8105         gv = gv_fetchsv(sv, 0, SVt_PVIO);
8106         if (gv)
8107             io = GvIO(gv);
8108         else
8109             io = 0;
8110         if (!io)
8111             Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8112         break;
8113     }
8114     return io;
8115 }
8116
8117 /*
8118 =for apidoc sv_2cv
8119
8120 Using various gambits, try to get a CV from an SV; in addition, try if
8121 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8122 The flags in C<lref> are passed to sv_fetchsv.
8123
8124 =cut
8125 */
8126
8127 CV *
8128 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8129 {
8130     dVAR;
8131     GV *gv = NULL;
8132     CV *cv = NULL;
8133
8134     PERL_ARGS_ASSERT_SV_2CV;
8135
8136     if (!sv) {
8137         *st = NULL;
8138         *gvp = NULL;
8139         return NULL;
8140     }
8141     switch (SvTYPE(sv)) {
8142     case SVt_PVCV:
8143         *st = CvSTASH(sv);
8144         *gvp = NULL;
8145         return MUTABLE_CV(sv);
8146     case SVt_PVHV:
8147     case SVt_PVAV:
8148         *st = NULL;
8149         *gvp = NULL;
8150         return NULL;
8151     case SVt_PVGV:
8152         if (isGV_with_GP(sv)) {
8153             gv = MUTABLE_GV(sv);
8154             *gvp = gv;
8155             *st = GvESTASH(gv);
8156             goto fix_gv;
8157         }
8158         /* FALL THROUGH */
8159
8160     default:
8161         if (SvROK(sv)) {
8162             SV * const *sp = &sv;       /* Used in tryAMAGICunDEREF macro. */
8163             SvGETMAGIC(sv);
8164             tryAMAGICunDEREF(to_cv);
8165
8166             sv = SvRV(sv);
8167             if (SvTYPE(sv) == SVt_PVCV) {
8168                 cv = MUTABLE_CV(sv);
8169                 *gvp = NULL;
8170                 *st = CvSTASH(cv);
8171                 return cv;
8172             }
8173             else if(isGV_with_GP(sv))
8174                 gv = MUTABLE_GV(sv);
8175             else
8176                 Perl_croak(aTHX_ "Not a subroutine reference");
8177         }
8178         else if (isGV_with_GP(sv)) {
8179             SvGETMAGIC(sv);
8180             gv = MUTABLE_GV(sv);
8181         }
8182         else
8183             gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8184         *gvp = gv;
8185         if (!gv) {
8186             *st = NULL;
8187             return NULL;
8188         }
8189         /* Some flags to gv_fetchsv mean don't really create the GV  */
8190         if (!isGV_with_GP(gv)) {
8191             *st = NULL;
8192             return NULL;
8193         }
8194         *st = GvESTASH(gv);
8195     fix_gv:
8196         if (lref && !GvCVu(gv)) {
8197             SV *tmpsv;
8198             ENTER;
8199             tmpsv = newSV(0);
8200             gv_efullname3(tmpsv, gv, NULL);
8201             /* XXX this is probably not what they think they're getting.
8202              * It has the same effect as "sub name;", i.e. just a forward
8203              * declaration! */
8204             newSUB(start_subparse(FALSE, 0),
8205                    newSVOP(OP_CONST, 0, tmpsv),
8206                    NULL, NULL);
8207             LEAVE;
8208             if (!GvCVu(gv))
8209                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8210                            SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8211         }
8212         return GvCVu(gv);
8213     }
8214 }
8215
8216 /*
8217 =for apidoc sv_true
8218
8219 Returns true if the SV has a true value by Perl's rules.
8220 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8221 instead use an in-line version.
8222
8223 =cut
8224 */
8225
8226 I32
8227 Perl_sv_true(pTHX_ register SV *const sv)
8228 {
8229     if (!sv)
8230         return 0;
8231     if (SvPOK(sv)) {
8232         register const XPV* const tXpv = (XPV*)SvANY(sv);
8233         if (tXpv &&
8234                 (tXpv->xpv_cur > 1 ||
8235                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8236             return 1;
8237         else
8238             return 0;
8239     }
8240     else {
8241         if (SvIOK(sv))
8242             return SvIVX(sv) != 0;
8243         else {
8244             if (SvNOK(sv))
8245                 return SvNVX(sv) != 0.0;
8246             else
8247                 return sv_2bool(sv);
8248         }
8249     }
8250 }
8251
8252 /*
8253 =for apidoc sv_pvn_force
8254
8255 Get a sensible string out of the SV somehow.
8256 A private implementation of the C<SvPV_force> macro for compilers which
8257 can't cope with complex macro expressions. Always use the macro instead.
8258
8259 =for apidoc sv_pvn_force_flags
8260
8261 Get a sensible string out of the SV somehow.
8262 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8263 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8264 implemented in terms of this function.
8265 You normally want to use the various wrapper macros instead: see
8266 C<SvPV_force> and C<SvPV_force_nomg>
8267
8268 =cut
8269 */
8270
8271 char *
8272 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8273 {
8274     dVAR;
8275
8276     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8277
8278     if (SvTHINKFIRST(sv) && !SvROK(sv))
8279         sv_force_normal_flags(sv, 0);
8280
8281     if (SvPOK(sv)) {
8282         if (lp)
8283             *lp = SvCUR(sv);
8284     }
8285     else {
8286         char *s;
8287         STRLEN len;
8288
8289         if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8290             const char * const ref = sv_reftype(sv,0);
8291             if (PL_op)
8292                 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8293                            ref, OP_NAME(PL_op));
8294             else
8295                 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8296         }
8297         if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8298             || isGV_with_GP(sv))
8299             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8300                 OP_NAME(PL_op));
8301         s = sv_2pv_flags(sv, &len, flags);
8302         if (lp)
8303             *lp = len;
8304
8305         if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
8306             if (SvROK(sv))
8307                 sv_unref(sv);
8308             SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
8309             SvGROW(sv, len + 1);
8310             Move(s,SvPVX(sv),len,char);
8311             SvCUR_set(sv, len);
8312             SvPVX(sv)[len] = '\0';
8313         }
8314         if (!SvPOK(sv)) {
8315             SvPOK_on(sv);               /* validate pointer */
8316             SvTAINT(sv);
8317             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8318                                   PTR2UV(sv),SvPVX_const(sv)));
8319         }
8320     }
8321     return SvPVX_mutable(sv);
8322 }
8323
8324 /*
8325 =for apidoc sv_pvbyten_force
8326
8327 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8328
8329 =cut
8330 */
8331
8332 char *
8333 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8334 {
8335     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8336
8337     sv_pvn_force(sv,lp);
8338     sv_utf8_downgrade(sv,0);
8339     *lp = SvCUR(sv);
8340     return SvPVX(sv);
8341 }
8342
8343 /*
8344 =for apidoc sv_pvutf8n_force
8345
8346 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8347
8348 =cut
8349 */
8350
8351 char *
8352 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8353 {
8354     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8355
8356     sv_pvn_force(sv,lp);
8357     sv_utf8_upgrade(sv);
8358     *lp = SvCUR(sv);
8359     return SvPVX(sv);
8360 }
8361
8362 /*
8363 =for apidoc sv_reftype
8364
8365 Returns a string describing what the SV is a reference to.
8366
8367 =cut
8368 */
8369
8370 const char *
8371 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8372 {
8373     PERL_ARGS_ASSERT_SV_REFTYPE;
8374
8375     /* The fact that I don't need to downcast to char * everywhere, only in ?:
8376        inside return suggests a const propagation bug in g++.  */
8377     if (ob && SvOBJECT(sv)) {
8378         char * const name = HvNAME_get(SvSTASH(sv));
8379         return name ? name : (char *) "__ANON__";
8380     }
8381     else {
8382         switch (SvTYPE(sv)) {
8383         case SVt_NULL:
8384         case SVt_IV:
8385         case SVt_NV:
8386         case SVt_PV:
8387         case SVt_PVIV:
8388         case SVt_PVNV:
8389         case SVt_PVMG:
8390                                 if (SvVOK(sv))
8391                                     return "VSTRING";
8392                                 if (SvROK(sv))
8393                                     return "REF";
8394                                 else
8395                                     return "SCALAR";
8396
8397         case SVt_PVLV:          return (char *)  (SvROK(sv) ? "REF"
8398                                 /* tied lvalues should appear to be
8399                                  * scalars for backwards compatitbility */
8400                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8401                                     ? "SCALAR" : "LVALUE");
8402         case SVt_PVAV:          return "ARRAY";
8403         case SVt_PVHV:          return "HASH";
8404         case SVt_PVCV:          return "CODE";
8405         case SVt_PVGV:          return (char *) (isGV_with_GP(sv)
8406                                     ? "GLOB" : "SCALAR");
8407         case SVt_PVFM:          return "FORMAT";
8408         case SVt_PVIO:          return "IO";
8409         case SVt_BIND:          return "BIND";
8410         case SVt_REGEXP:        return "REGEXP";
8411         default:                return "UNKNOWN";
8412         }
8413     }
8414 }
8415
8416 /*
8417 =for apidoc sv_isobject
8418
8419 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8420 object.  If the SV is not an RV, or if the object is not blessed, then this
8421 will return false.
8422
8423 =cut
8424 */
8425
8426 int
8427 Perl_sv_isobject(pTHX_ SV *sv)
8428 {
8429     if (!sv)
8430         return 0;
8431     SvGETMAGIC(sv);
8432     if (!SvROK(sv))
8433         return 0;
8434     sv = SvRV(sv);
8435     if (!SvOBJECT(sv))
8436         return 0;
8437     return 1;
8438 }
8439
8440 /*
8441 =for apidoc sv_isa
8442
8443 Returns a boolean indicating whether the SV is blessed into the specified
8444 class.  This does not check for subtypes; use C<sv_derived_from> to verify
8445 an inheritance relationship.
8446
8447 =cut
8448 */
8449
8450 int
8451 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8452 {
8453     const char *hvname;
8454
8455     PERL_ARGS_ASSERT_SV_ISA;
8456
8457     if (!sv)
8458         return 0;
8459     SvGETMAGIC(sv);
8460     if (!SvROK(sv))
8461         return 0;
8462     sv = SvRV(sv);
8463     if (!SvOBJECT(sv))
8464         return 0;
8465     hvname = HvNAME_get(SvSTASH(sv));
8466     if (!hvname)
8467         return 0;
8468
8469     return strEQ(hvname, name);
8470 }
8471
8472 /*
8473 =for apidoc newSVrv
8474
8475 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
8476 it will be upgraded to one.  If C<classname> is non-null then the new SV will
8477 be blessed in the specified package.  The new SV is returned and its
8478 reference count is 1.
8479
8480 =cut
8481 */
8482
8483 SV*
8484 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8485 {
8486     dVAR;
8487     SV *sv;
8488
8489     PERL_ARGS_ASSERT_NEWSVRV;
8490
8491     new_SV(sv);
8492
8493     SV_CHECK_THINKFIRST_COW_DROP(rv);
8494     (void)SvAMAGIC_off(rv);
8495
8496     if (SvTYPE(rv) >= SVt_PVMG) {
8497         const U32 refcnt = SvREFCNT(rv);
8498         SvREFCNT(rv) = 0;
8499         sv_clear(rv);
8500         SvFLAGS(rv) = 0;
8501         SvREFCNT(rv) = refcnt;
8502
8503         sv_upgrade(rv, SVt_IV);
8504     } else if (SvROK(rv)) {
8505         SvREFCNT_dec(SvRV(rv));
8506     } else {
8507         prepare_SV_for_RV(rv);
8508     }
8509
8510     SvOK_off(rv);
8511     SvRV_set(rv, sv);
8512     SvROK_on(rv);
8513
8514     if (classname) {
8515         HV* const stash = gv_stashpv(classname, GV_ADD);
8516         (void)sv_bless(rv, stash);
8517     }
8518     return sv;
8519 }
8520
8521 /*
8522 =for apidoc sv_setref_pv
8523
8524 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
8525 argument will be upgraded to an RV.  That RV will be modified to point to
8526 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8527 into the SV.  The C<classname> argument indicates the package for the
8528 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8529 will have a reference count of 1, and the RV will be returned.
8530
8531 Do not use with other Perl types such as HV, AV, SV, CV, because those
8532 objects will become corrupted by the pointer copy process.
8533
8534 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8535
8536 =cut
8537 */
8538
8539 SV*
8540 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8541 {
8542     dVAR;
8543
8544     PERL_ARGS_ASSERT_SV_SETREF_PV;
8545
8546     if (!pv) {
8547         sv_setsv(rv, &PL_sv_undef);
8548         SvSETMAGIC(rv);
8549     }
8550     else
8551         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8552     return rv;
8553 }
8554
8555 /*
8556 =for apidoc sv_setref_iv
8557
8558 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
8559 argument will be upgraded to an RV.  That RV will be modified to point to
8560 the new SV.  The C<classname> argument indicates the package for the
8561 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8562 will have a reference count of 1, and the RV will be returned.
8563
8564 =cut
8565 */
8566
8567 SV*
8568 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8569 {
8570     PERL_ARGS_ASSERT_SV_SETREF_IV;
8571
8572     sv_setiv(newSVrv(rv,classname), iv);
8573     return rv;
8574 }
8575
8576 /*
8577 =for apidoc sv_setref_uv
8578
8579 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
8580 argument will be upgraded to an RV.  That RV will be modified to point to
8581 the new SV.  The C<classname> argument indicates the package for the
8582 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8583 will have a reference count of 1, and the RV will be returned.
8584
8585 =cut
8586 */
8587
8588 SV*
8589 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8590 {
8591     PERL_ARGS_ASSERT_SV_SETREF_UV;
8592
8593     sv_setuv(newSVrv(rv,classname), uv);
8594     return rv;
8595 }
8596
8597 /*
8598 =for apidoc sv_setref_nv
8599
8600 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
8601 argument will be upgraded to an RV.  That RV will be modified to point to
8602 the new SV.  The C<classname> argument indicates the package for the
8603 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8604 will have a reference count of 1, and the RV will be returned.
8605
8606 =cut
8607 */
8608
8609 SV*
8610 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8611 {
8612     PERL_ARGS_ASSERT_SV_SETREF_NV;
8613
8614     sv_setnv(newSVrv(rv,classname), nv);
8615     return rv;
8616 }
8617
8618 /*
8619 =for apidoc sv_setref_pvn
8620
8621 Copies a string into a new SV, optionally blessing the SV.  The length of the
8622 string must be specified with C<n>.  The C<rv> argument will be upgraded to
8623 an RV.  That RV will be modified to point to the new SV.  The C<classname>
8624 argument indicates the package for the blessing.  Set C<classname> to
8625 C<NULL> to avoid the blessing.  The new SV will have a reference count
8626 of 1, and the RV will be returned.
8627
8628 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8629
8630 =cut
8631 */
8632
8633 SV*
8634 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8635                    const char *const pv, const STRLEN n)
8636 {
8637     PERL_ARGS_ASSERT_SV_SETREF_PVN;
8638
8639     sv_setpvn(newSVrv(rv,classname), pv, n);
8640     return rv;
8641 }
8642
8643 /*
8644 =for apidoc sv_bless
8645
8646 Blesses an SV into a specified package.  The SV must be an RV.  The package
8647 must be designated by its stash (see C<gv_stashpv()>).  The reference count
8648 of the SV is unaffected.
8649
8650 =cut
8651 */
8652
8653 SV*
8654 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8655 {
8656     dVAR;
8657     SV *tmpRef;
8658
8659     PERL_ARGS_ASSERT_SV_BLESS;
8660
8661     if (!SvROK(sv))
8662         Perl_croak(aTHX_ "Can't bless non-reference value");
8663     tmpRef = SvRV(sv);
8664     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8665         if (SvIsCOW(tmpRef))
8666             sv_force_normal_flags(tmpRef, 0);
8667         if (SvREADONLY(tmpRef))
8668             Perl_croak(aTHX_ "%s", PL_no_modify);
8669         if (SvOBJECT(tmpRef)) {
8670             if (SvTYPE(tmpRef) != SVt_PVIO)
8671                 --PL_sv_objcount;
8672             SvREFCNT_dec(SvSTASH(tmpRef));
8673         }
8674     }
8675     SvOBJECT_on(tmpRef);
8676     if (SvTYPE(tmpRef) != SVt_PVIO)
8677         ++PL_sv_objcount;
8678     SvUPGRADE(tmpRef, SVt_PVMG);
8679     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8680
8681     if (Gv_AMG(stash))
8682         SvAMAGIC_on(sv);
8683     else
8684         (void)SvAMAGIC_off(sv);
8685
8686     if(SvSMAGICAL(tmpRef))
8687         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8688             mg_set(tmpRef);
8689
8690
8691
8692     return sv;
8693 }
8694
8695 /* Downgrades a PVGV to a PVMG.
8696  */
8697
8698 STATIC void
8699 S_sv_unglob(pTHX_ SV *const sv)
8700 {
8701     dVAR;
8702     void *xpvmg;
8703     HV *stash;
8704     SV * const temp = sv_newmortal();
8705
8706     PERL_ARGS_ASSERT_SV_UNGLOB;
8707
8708     assert(SvTYPE(sv) == SVt_PVGV);
8709     SvFAKE_off(sv);
8710     gv_efullname3(temp, MUTABLE_GV(sv), "*");
8711
8712     if (GvGP(sv)) {
8713         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
8714            && HvNAME_get(stash))
8715             mro_method_changed_in(stash);
8716         gp_free(MUTABLE_GV(sv));
8717     }
8718     if (GvSTASH(sv)) {
8719         sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
8720         GvSTASH(sv) = NULL;
8721     }
8722     GvMULTI_off(sv);
8723     if (GvNAME_HEK(sv)) {
8724         unshare_hek(GvNAME_HEK(sv));
8725     }
8726     isGV_with_GP_off(sv);
8727
8728     /* need to keep SvANY(sv) in the right arena */
8729     xpvmg = new_XPVMG();
8730     StructCopy(SvANY(sv), xpvmg, XPVMG);
8731     del_XPVGV(SvANY(sv));
8732     SvANY(sv) = xpvmg;
8733
8734     SvFLAGS(sv) &= ~SVTYPEMASK;
8735     SvFLAGS(sv) |= SVt_PVMG;
8736
8737     /* Intentionally not calling any local SET magic, as this isn't so much a
8738        set operation as merely an internal storage change.  */
8739     sv_setsv_flags(sv, temp, 0);
8740 }
8741
8742 /*
8743 =for apidoc sv_unref_flags
8744
8745 Unsets the RV status of the SV, and decrements the reference count of
8746 whatever was being referenced by the RV.  This can almost be thought of
8747 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
8748 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8749 (otherwise the decrementing is conditional on the reference count being
8750 different from one or the reference being a readonly SV).
8751 See C<SvROK_off>.
8752
8753 =cut
8754 */
8755
8756 void
8757 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8758 {
8759     SV* const target = SvRV(ref);
8760
8761     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8762
8763     if (SvWEAKREF(ref)) {
8764         sv_del_backref(target, ref);
8765         SvWEAKREF_off(ref);
8766         SvRV_set(ref, NULL);
8767         return;
8768     }
8769     SvRV_set(ref, NULL);
8770     SvROK_off(ref);
8771     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8772        assigned to as BEGIN {$a = \"Foo"} will fail.  */
8773     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8774         SvREFCNT_dec(target);
8775     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8776         sv_2mortal(target);     /* Schedule for freeing later */
8777 }
8778
8779 /*
8780 =for apidoc sv_untaint
8781
8782 Untaint an SV. Use C<SvTAINTED_off> instead.
8783 =cut
8784 */
8785
8786 void
8787 Perl_sv_untaint(pTHX_ SV *const sv)
8788 {
8789     PERL_ARGS_ASSERT_SV_UNTAINT;
8790
8791     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8792         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8793         if (mg)
8794             mg->mg_len &= ~1;
8795     }
8796 }
8797
8798 /*
8799 =for apidoc sv_tainted
8800
8801 Test an SV for taintedness. Use C<SvTAINTED> instead.
8802 =cut
8803 */
8804
8805 bool
8806 Perl_sv_tainted(pTHX_ SV *const sv)
8807 {
8808     PERL_ARGS_ASSERT_SV_TAINTED;
8809
8810     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8811         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8812         if (mg && (mg->mg_len & 1) )
8813             return TRUE;
8814     }
8815     return FALSE;
8816 }
8817
8818 /*
8819 =for apidoc sv_setpviv
8820
8821 Copies an integer into the given SV, also updating its string value.
8822 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
8823
8824 =cut
8825 */
8826
8827 void
8828 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8829 {
8830     char buf[TYPE_CHARS(UV)];
8831     char *ebuf;
8832     char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8833
8834     PERL_ARGS_ASSERT_SV_SETPVIV;
8835
8836     sv_setpvn(sv, ptr, ebuf - ptr);
8837 }
8838
8839 /*
8840 =for apidoc sv_setpviv_mg
8841
8842 Like C<sv_setpviv>, but also handles 'set' magic.
8843
8844 =cut
8845 */
8846
8847 void
8848 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8849 {
8850     PERL_ARGS_ASSERT_SV_SETPVIV_MG;
8851
8852     sv_setpviv(sv, iv);
8853     SvSETMAGIC(sv);
8854 }
8855
8856 #if defined(PERL_IMPLICIT_CONTEXT)
8857
8858 /* pTHX_ magic can't cope with varargs, so this is a no-context
8859  * version of the main function, (which may itself be aliased to us).
8860  * Don't access this version directly.
8861  */
8862
8863 void
8864 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
8865 {
8866     dTHX;
8867     va_list args;
8868
8869     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
8870
8871     va_start(args, pat);
8872     sv_vsetpvf(sv, pat, &args);
8873     va_end(args);
8874 }
8875
8876 /* pTHX_ magic can't cope with varargs, so this is a no-context
8877  * version of the main function, (which may itself be aliased to us).
8878  * Don't access this version directly.
8879  */
8880
8881 void
8882 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8883 {
8884     dTHX;
8885     va_list args;
8886
8887     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
8888
8889     va_start(args, pat);
8890     sv_vsetpvf_mg(sv, pat, &args);
8891     va_end(args);
8892 }
8893 #endif
8894
8895 /*
8896 =for apidoc sv_setpvf
8897
8898 Works like C<sv_catpvf> but copies the text into the SV instead of
8899 appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
8900
8901 =cut
8902 */
8903
8904 void
8905 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
8906 {
8907     va_list args;
8908
8909     PERL_ARGS_ASSERT_SV_SETPVF;
8910
8911     va_start(args, pat);
8912     sv_vsetpvf(sv, pat, &args);
8913     va_end(args);
8914 }
8915
8916 /*
8917 =for apidoc sv_vsetpvf
8918
8919 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8920 appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
8921
8922 Usually used via its frontend C<sv_setpvf>.
8923
8924 =cut
8925 */
8926
8927 void
8928 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8929 {
8930     PERL_ARGS_ASSERT_SV_VSETPVF;
8931
8932     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8933 }
8934
8935 /*
8936 =for apidoc sv_setpvf_mg
8937
8938 Like C<sv_setpvf>, but also handles 'set' magic.
8939
8940 =cut
8941 */
8942
8943 void
8944 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8945 {
8946     va_list args;
8947
8948     PERL_ARGS_ASSERT_SV_SETPVF_MG;
8949
8950     va_start(args, pat);
8951     sv_vsetpvf_mg(sv, pat, &args);
8952     va_end(args);
8953 }
8954
8955 /*
8956 =for apidoc sv_vsetpvf_mg
8957
8958 Like C<sv_vsetpvf>, but also handles 'set' magic.
8959
8960 Usually used via its frontend C<sv_setpvf_mg>.
8961
8962 =cut
8963 */
8964
8965 void
8966 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8967 {
8968     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
8969
8970     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8971     SvSETMAGIC(sv);
8972 }
8973
8974 #if defined(PERL_IMPLICIT_CONTEXT)
8975
8976 /* pTHX_ magic can't cope with varargs, so this is a no-context
8977  * version of the main function, (which may itself be aliased to us).
8978  * Don't access this version directly.
8979  */
8980
8981 void
8982 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
8983 {
8984     dTHX;
8985     va_list args;
8986
8987     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
8988
8989     va_start(args, pat);
8990     sv_vcatpvf(sv, pat, &args);
8991     va_end(args);
8992 }
8993
8994 /* pTHX_ magic can't cope with varargs, so this is a no-context
8995  * version of the main function, (which may itself be aliased to us).
8996  * Don't access this version directly.
8997  */
8998
8999 void
9000 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9001 {
9002     dTHX;
9003     va_list args;
9004
9005     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9006
9007     va_start(args, pat);
9008     sv_vcatpvf_mg(sv, pat, &args);
9009     va_end(args);
9010 }
9011 #endif
9012
9013 /*
9014 =for apidoc sv_catpvf
9015
9016 Processes its arguments like C<sprintf> and appends the formatted
9017 output to an SV.  If the appended data contains "wide" characters
9018 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9019 and characters >255 formatted with %c), the original SV might get
9020 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
9021 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9022 valid UTF-8; if the original SV was bytes, the pattern should be too.
9023
9024 =cut */
9025
9026 void
9027 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9028 {
9029     va_list args;
9030
9031     PERL_ARGS_ASSERT_SV_CATPVF;
9032
9033     va_start(args, pat);
9034     sv_vcatpvf(sv, pat, &args);
9035     va_end(args);
9036 }
9037
9038 /*
9039 =for apidoc sv_vcatpvf
9040
9041 Processes its arguments like C<vsprintf> and appends the formatted output
9042 to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
9043
9044 Usually used via its frontend C<sv_catpvf>.
9045
9046 =cut
9047 */
9048
9049 void
9050 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9051 {
9052     PERL_ARGS_ASSERT_SV_VCATPVF;
9053
9054     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9055 }
9056
9057 /*
9058 =for apidoc sv_catpvf_mg
9059
9060 Like C<sv_catpvf>, but also handles 'set' magic.
9061
9062 =cut
9063 */
9064
9065 void
9066 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9067 {
9068     va_list args;
9069
9070     PERL_ARGS_ASSERT_SV_CATPVF_MG;
9071
9072     va_start(args, pat);
9073     sv_vcatpvf_mg(sv, pat, &args);
9074     va_end(args);
9075 }
9076
9077 /*
9078 =for apidoc sv_vcatpvf_mg
9079
9080 Like C<sv_vcatpvf>, but also handles 'set' magic.
9081
9082 Usually used via its frontend C<sv_catpvf_mg>.
9083
9084 =cut
9085 */
9086
9087 void
9088 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9089 {
9090     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9091
9092     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9093     SvSETMAGIC(sv);
9094 }
9095
9096 /*
9097 =for apidoc sv_vsetpvfn
9098
9099 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9100 appending it.
9101
9102 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9103
9104 =cut
9105 */
9106
9107 void
9108 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9109                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9110 {
9111     PERL_ARGS_ASSERT_SV_VSETPVFN;
9112
9113     sv_setpvs(sv, "");
9114     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9115 }
9116
9117 STATIC I32
9118 S_expect_number(pTHX_ char **const pattern)
9119 {
9120     dVAR;
9121     I32 var = 0;
9122
9123     PERL_ARGS_ASSERT_EXPECT_NUMBER;
9124
9125     switch (**pattern) {
9126     case '1': case '2': case '3':
9127     case '4': case '5': case '6':
9128     case '7': case '8': case '9':
9129         var = *(*pattern)++ - '0';
9130         while (isDIGIT(**pattern)) {
9131             const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9132             if (tmp < var)
9133                 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
9134             var = tmp;
9135         }
9136     }
9137     return var;
9138 }
9139
9140 STATIC char *
9141 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9142 {
9143     const int neg = nv < 0;
9144     UV uv;
9145
9146     PERL_ARGS_ASSERT_F0CONVERT;
9147
9148     if (neg)
9149         nv = -nv;
9150     if (nv < UV_MAX) {
9151         char *p = endbuf;
9152         nv += 0.5;
9153         uv = (UV)nv;
9154         if (uv & 1 && uv == nv)
9155             uv--;                       /* Round to even */
9156         do {
9157             const unsigned dig = uv % 10;
9158             *--p = '0' + dig;
9159         } while (uv /= 10);
9160         if (neg)
9161             *--p = '-';
9162         *len = endbuf - p;
9163         return p;
9164     }
9165     return NULL;
9166 }
9167
9168
9169 /*
9170 =for apidoc sv_vcatpvfn
9171
9172 Processes its arguments like C<vsprintf> and appends the formatted output
9173 to an SV.  Uses an array of SVs if the C style variable argument list is
9174 missing (NULL).  When running with taint checks enabled, indicates via
9175 C<maybe_tainted> if results are untrustworthy (often due to the use of
9176 locales).
9177
9178 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9179
9180 =cut
9181 */
9182
9183
9184 #define VECTORIZE_ARGS  vecsv = va_arg(*args, SV*);\
9185                         vecstr = (U8*)SvPV_const(vecsv,veclen);\
9186                         vec_utf8 = DO_UTF8(vecsv);
9187
9188 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9189
9190 void
9191 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9192                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9193 {
9194     dVAR;
9195     char *p;
9196     char *q;
9197     const char *patend;
9198     STRLEN origlen;
9199     I32 svix = 0;
9200     static const char nullstr[] = "(null)";
9201     SV *argsv = NULL;
9202     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
9203     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9204     SV *nsv = NULL;
9205     /* Times 4: a decimal digit takes more than 3 binary digits.
9206      * NV_DIG: mantissa takes than many decimal digits.
9207      * Plus 32: Playing safe. */
9208     char ebuf[IV_DIG * 4 + NV_DIG + 32];
9209     /* large enough for "%#.#f" --chip */
9210     /* what about long double NVs? --jhi */
9211
9212     PERL_ARGS_ASSERT_SV_VCATPVFN;
9213     PERL_UNUSED_ARG(maybe_tainted);
9214
9215     /* no matter what, this is a string now */
9216     (void)SvPV_force(sv, origlen);
9217
9218     /* special-case "", "%s", and "%-p" (SVf - see below) */
9219     if (patlen == 0)
9220         return;
9221     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9222         if (args) {
9223             const char * const s = va_arg(*args, char*);
9224             sv_catpv(sv, s ? s : nullstr);
9225         }
9226         else if (svix < svmax) {
9227             sv_catsv(sv, *svargs);
9228         }
9229         return;
9230     }
9231     if (args && patlen == 3 && pat[0] == '%' &&
9232                 pat[1] == '-' && pat[2] == 'p') {
9233         argsv = MUTABLE_SV(va_arg(*args, void*));
9234         sv_catsv(sv, argsv);
9235         return;
9236     }
9237
9238 #ifndef USE_LONG_DOUBLE
9239     /* special-case "%.<number>[gf]" */
9240     if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9241          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9242         unsigned digits = 0;
9243         const char *pp;
9244
9245         pp = pat + 2;
9246         while (*pp >= '0' && *pp <= '9')
9247             digits = 10 * digits + (*pp++ - '0');
9248         if (pp - pat == (int)patlen - 1) {
9249             NV nv;
9250
9251             if (svix < svmax)
9252                 nv = SvNV(*svargs);
9253             else
9254                 return;
9255             if (*pp == 'g') {
9256                 /* Add check for digits != 0 because it seems that some
9257                    gconverts are buggy in this case, and we don't yet have
9258                    a Configure test for this.  */
9259                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9260                      /* 0, point, slack */
9261                     Gconvert(nv, (int)digits, 0, ebuf);
9262                     sv_catpv(sv, ebuf);
9263                     if (*ebuf)  /* May return an empty string for digits==0 */
9264                         return;
9265                 }
9266             } else if (!digits) {
9267                 STRLEN l;
9268
9269                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9270                     sv_catpvn(sv, p, l);
9271                     return;
9272                 }
9273             }
9274         }
9275     }
9276 #endif /* !USE_LONG_DOUBLE */
9277
9278     if (!args && svix < svmax && DO_UTF8(*svargs))
9279         has_utf8 = TRUE;
9280
9281     patend = (char*)pat + patlen;
9282     for (p = (char*)pat; p < patend; p = q) {
9283         bool alt = FALSE;
9284         bool left = FALSE;
9285         bool vectorize = FALSE;
9286         bool vectorarg = FALSE;
9287         bool vec_utf8 = FALSE;
9288         char fill = ' ';
9289         char plus = 0;
9290         char intsize = 0;
9291         STRLEN width = 0;
9292         STRLEN zeros = 0;
9293         bool has_precis = FALSE;
9294         STRLEN precis = 0;
9295         const I32 osvix = svix;
9296         bool is_utf8 = FALSE;  /* is this item utf8?   */
9297 #ifdef HAS_LDBL_SPRINTF_BUG
9298         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9299            with sfio - Allen <allens@cpan.org> */
9300         bool fix_ldbl_sprintf_bug = FALSE;
9301 #endif
9302
9303         char esignbuf[4];
9304         U8 utf8buf[UTF8_MAXBYTES+1];
9305         STRLEN esignlen = 0;
9306
9307         const char *eptr = NULL;
9308         const char *fmtstart;
9309         STRLEN elen = 0;
9310         SV *vecsv = NULL;
9311         const U8 *vecstr = NULL;
9312         STRLEN veclen = 0;
9313         char c = 0;
9314         int i;
9315         unsigned base = 0;
9316         IV iv = 0;
9317         UV uv = 0;
9318         /* we need a long double target in case HAS_LONG_DOUBLE but
9319            not USE_LONG_DOUBLE
9320         */
9321 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9322         long double nv;
9323 #else
9324         NV nv;
9325 #endif
9326         STRLEN have;
9327         STRLEN need;
9328         STRLEN gap;
9329         const char *dotstr = ".";
9330         STRLEN dotstrlen = 1;
9331         I32 efix = 0; /* explicit format parameter index */
9332         I32 ewix = 0; /* explicit width index */
9333         I32 epix = 0; /* explicit precision index */
9334         I32 evix = 0; /* explicit vector index */
9335         bool asterisk = FALSE;
9336
9337         /* echo everything up to the next format specification */
9338         for (q = p; q < patend && *q != '%'; ++q) ;
9339         if (q > p) {
9340             if (has_utf8 && !pat_utf8)
9341                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9342             else
9343                 sv_catpvn(sv, p, q - p);
9344             p = q;
9345         }
9346         if (q++ >= patend)
9347             break;
9348
9349         fmtstart = q;
9350
9351 /*
9352     We allow format specification elements in this order:
9353         \d+\$              explicit format parameter index
9354         [-+ 0#]+           flags
9355         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
9356         0                  flag (as above): repeated to allow "v02"
9357         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
9358         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9359         [hlqLV]            size
9360     [%bcdefginopsuxDFOUX] format (mandatory)
9361 */
9362
9363         if (args) {
9364 /*
9365         As of perl5.9.3, printf format checking is on by default.
9366         Internally, perl uses %p formats to provide an escape to
9367         some extended formatting.  This block deals with those
9368         extensions: if it does not match, (char*)q is reset and
9369         the normal format processing code is used.
9370
9371         Currently defined extensions are:
9372                 %p              include pointer address (standard)
9373                 %-p     (SVf)   include an SV (previously %_)
9374                 %-<num>p        include an SV with precision <num>
9375                 %<num>p         reserved for future extensions
9376
9377         Robin Barker 2005-07-14
9378
9379                 %1p     (VDf)   removed.  RMB 2007-10-19
9380 */
9381             char* r = q;
9382             bool sv = FALSE;
9383             STRLEN n = 0;
9384             if (*q == '-')
9385                 sv = *q++;
9386             n = expect_number(&q);
9387             if (*q++ == 'p') {
9388                 if (sv) {                       /* SVf */
9389                     if (n) {
9390                         precis = n;
9391                         has_precis = TRUE;
9392                     }
9393                     argsv = MUTABLE_SV(va_arg(*args, void*));
9394                     eptr = SvPV_const(argsv, elen);
9395                     if (DO_UTF8(argsv))
9396                         is_utf8 = TRUE;
9397                     goto string;
9398                 }
9399                 else if (n) {
9400                     if (ckWARN_d(WARN_INTERNAL))
9401                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9402                         "internal %%<num>p might conflict with future printf extensions");
9403                 }
9404             }
9405             q = r;
9406         }
9407
9408         if ( (width = expect_number(&q)) ) {
9409             if (*q == '$') {
9410                 ++q;
9411                 efix = width;
9412             } else {
9413                 goto gotwidth;
9414             }
9415         }
9416
9417         /* FLAGS */
9418
9419         while (*q) {
9420             switch (*q) {
9421             case ' ':
9422             case '+':
9423                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9424                     q++;
9425                 else
9426                     plus = *q++;
9427                 continue;
9428
9429             case '-':
9430                 left = TRUE;
9431                 q++;
9432                 continue;
9433
9434             case '0':
9435                 fill = *q++;
9436                 continue;
9437
9438             case '#':
9439                 alt = TRUE;
9440                 q++;
9441                 continue;
9442
9443             default:
9444                 break;
9445             }
9446             break;
9447         }
9448
9449       tryasterisk:
9450         if (*q == '*') {
9451             q++;
9452             if ( (ewix = expect_number(&q)) )
9453                 if (*q++ != '$')
9454                     goto unknown;
9455             asterisk = TRUE;
9456         }
9457         if (*q == 'v') {
9458             q++;
9459             if (vectorize)
9460                 goto unknown;
9461             if ((vectorarg = asterisk)) {
9462                 evix = ewix;
9463                 ewix = 0;
9464                 asterisk = FALSE;
9465             }
9466             vectorize = TRUE;
9467             goto tryasterisk;
9468         }
9469
9470         if (!asterisk)
9471         {
9472             if( *q == '0' )
9473                 fill = *q++;
9474             width = expect_number(&q);
9475         }
9476
9477         if (vectorize) {
9478             if (vectorarg) {
9479                 if (args)
9480                     vecsv = va_arg(*args, SV*);
9481                 else if (evix) {
9482                     vecsv = (evix > 0 && evix <= svmax)
9483                         ? svargs[evix-1] : &PL_sv_undef;
9484                 } else {
9485                     vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
9486                 }
9487                 dotstr = SvPV_const(vecsv, dotstrlen);
9488                 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9489                    bad with tied or overloaded values that return UTF8.  */
9490                 if (DO_UTF8(vecsv))
9491                     is_utf8 = TRUE;
9492                 else if (has_utf8) {
9493                     vecsv = sv_mortalcopy(vecsv);
9494                     sv_utf8_upgrade(vecsv);
9495                     dotstr = SvPV_const(vecsv, dotstrlen);
9496                     is_utf8 = TRUE;
9497                 }
9498             }
9499             if (args) {
9500                 VECTORIZE_ARGS
9501             }
9502             else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9503                 vecsv = svargs[efix ? efix-1 : svix++];
9504                 vecstr = (U8*)SvPV_const(vecsv,veclen);
9505                 vec_utf8 = DO_UTF8(vecsv);
9506
9507                 /* if this is a version object, we need to convert
9508                  * back into v-string notation and then let the
9509                  * vectorize happen normally
9510                  */
9511                 if (sv_derived_from(vecsv, "version")) {
9512                     char *version = savesvpv(vecsv);
9513                     if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9514                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9515                         "vector argument not supported with alpha versions");
9516                         goto unknown;
9517                     }
9518                     vecsv = sv_newmortal();
9519                     scan_vstring(version, version + veclen, vecsv);
9520                     vecstr = (U8*)SvPV_const(vecsv, veclen);
9521                     vec_utf8 = DO_UTF8(vecsv);
9522                     Safefree(version);
9523                 }
9524             }
9525             else {
9526                 vecstr = (U8*)"";
9527                 veclen = 0;
9528             }
9529         }
9530
9531         if (asterisk) {
9532             if (args)
9533                 i = va_arg(*args, int);
9534             else
9535                 i = (ewix ? ewix <= svmax : svix < svmax) ?
9536                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9537             left |= (i < 0);
9538             width = (i < 0) ? -i : i;
9539         }
9540       gotwidth:
9541
9542         /* PRECISION */
9543
9544         if (*q == '.') {
9545             q++;
9546             if (*q == '*') {
9547                 q++;
9548                 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9549                     goto unknown;
9550                 /* XXX: todo, support specified precision parameter */
9551                 if (epix)
9552                     goto unknown;
9553                 if (args)
9554                     i = va_arg(*args, int);
9555                 else
9556                     i = (ewix ? ewix <= svmax : svix < svmax)
9557                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9558                 precis = i;
9559                 has_precis = !(i < 0);
9560             }
9561             else {
9562                 precis = 0;
9563                 while (isDIGIT(*q))
9564                     precis = precis * 10 + (*q++ - '0');
9565                 has_precis = TRUE;
9566             }
9567         }
9568
9569         /* SIZE */
9570
9571         switch (*q) {
9572 #ifdef WIN32
9573         case 'I':                       /* Ix, I32x, and I64x */
9574 #  ifdef WIN64
9575             if (q[1] == '6' && q[2] == '4') {
9576                 q += 3;
9577                 intsize = 'q';
9578                 break;
9579             }
9580 #  endif
9581             if (q[1] == '3' && q[2] == '2') {
9582                 q += 3;
9583                 break;
9584             }
9585 #  ifdef WIN64
9586             intsize = 'q';
9587 #  endif
9588             q++;
9589             break;
9590 #endif
9591 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9592         case 'L':                       /* Ld */
9593             /*FALLTHROUGH*/
9594 #ifdef HAS_QUAD
9595         case 'q':                       /* qd */
9596 #endif
9597             intsize = 'q';
9598             q++;
9599             break;
9600 #endif
9601         case 'l':
9602 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9603             if (*(q + 1) == 'l') {      /* lld, llf */
9604                 intsize = 'q';
9605                 q += 2;
9606                 break;
9607              }
9608 #endif
9609             /*FALLTHROUGH*/
9610         case 'h':
9611             /*FALLTHROUGH*/
9612         case 'V':
9613             intsize = *q++;
9614             break;
9615         }
9616
9617         /* CONVERSION */
9618
9619         if (*q == '%') {
9620             eptr = q++;
9621             elen = 1;
9622             if (vectorize) {
9623                 c = '%';
9624                 goto unknown;
9625             }
9626             goto string;
9627         }
9628
9629         if (!vectorize && !args) {
9630             if (efix) {
9631                 const I32 i = efix-1;
9632                 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
9633             } else {
9634                 argsv = (svix >= 0 && svix < svmax)
9635                     ? svargs[svix++] : &PL_sv_undef;
9636             }
9637         }
9638
9639         switch (c = *q++) {
9640
9641             /* STRINGS */
9642
9643         case 'c':
9644             if (vectorize)
9645                 goto unknown;
9646             uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9647             if ((uv > 255 ||
9648                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9649                 && !IN_BYTES) {
9650                 eptr = (char*)utf8buf;
9651                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9652                 is_utf8 = TRUE;
9653             }
9654             else {
9655                 c = (char)uv;
9656                 eptr = &c;
9657                 elen = 1;
9658             }
9659             goto string;
9660
9661         case 's':
9662             if (vectorize)
9663                 goto unknown;
9664             if (args) {
9665                 eptr = va_arg(*args, char*);
9666                 if (eptr)
9667                     elen = strlen(eptr);
9668                 else {
9669                     eptr = (char *)nullstr;
9670                     elen = sizeof nullstr - 1;
9671                 }
9672             }
9673             else {
9674                 eptr = SvPV_const(argsv, elen);
9675                 if (DO_UTF8(argsv)) {
9676                     I32 old_precis = precis;
9677                     if (has_precis && precis < elen) {
9678                         I32 p = precis;
9679                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9680                         precis = p;
9681                     }
9682                     if (width) { /* fudge width (can't fudge elen) */
9683                         if (has_precis && precis < elen)
9684                             width += precis - old_precis;
9685                         else
9686                             width += elen - sv_len_utf8(argsv);
9687                     }
9688                     is_utf8 = TRUE;
9689                 }
9690             }
9691
9692         string:
9693             if (has_precis && elen > precis)
9694                 elen = precis;
9695             break;
9696
9697             /* INTEGERS */
9698
9699         case 'p':
9700             if (alt || vectorize)
9701                 goto unknown;
9702             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9703             base = 16;
9704             goto integer;
9705
9706         case 'D':
9707 #ifdef IV_IS_QUAD
9708             intsize = 'q';
9709 #else
9710             intsize = 'l';
9711 #endif
9712             /*FALLTHROUGH*/
9713         case 'd':
9714         case 'i':
9715 #if vdNUMBER
9716         format_vd:
9717 #endif
9718             if (vectorize) {
9719                 STRLEN ulen;
9720                 if (!veclen)
9721                     continue;
9722                 if (vec_utf8)
9723                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9724                                         UTF8_ALLOW_ANYUV);
9725                 else {
9726                     uv = *vecstr;
9727                     ulen = 1;
9728                 }
9729                 vecstr += ulen;
9730                 veclen -= ulen;
9731                 if (plus)
9732                      esignbuf[esignlen++] = plus;
9733             }
9734             else if (args) {
9735                 switch (intsize) {
9736                 case 'h':       iv = (short)va_arg(*args, int); break;
9737                 case 'l':       iv = va_arg(*args, long); break;
9738                 case 'V':       iv = va_arg(*args, IV); break;
9739                 default:        iv = va_arg(*args, int); break;
9740                 case 'q':
9741 #ifdef HAS_QUAD
9742                                 iv = va_arg(*args, Quad_t); break;
9743 #else
9744                                 goto unknown;
9745 #endif
9746                 }
9747             }
9748             else {
9749                 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9750                 switch (intsize) {
9751                 case 'h':       iv = (short)tiv; break;
9752                 case 'l':       iv = (long)tiv; break;
9753                 case 'V':
9754                 default:        iv = tiv; break;
9755                 case 'q':
9756 #ifdef HAS_QUAD
9757                                 iv = (Quad_t)tiv; break;
9758 #else
9759                                 goto unknown;
9760 #endif
9761                 }
9762             }
9763             if ( !vectorize )   /* we already set uv above */
9764             {
9765                 if (iv >= 0) {
9766                     uv = iv;
9767                     if (plus)
9768                         esignbuf[esignlen++] = plus;
9769                 }
9770                 else {
9771                     uv = -iv;
9772                     esignbuf[esignlen++] = '-';
9773                 }
9774             }
9775             base = 10;
9776             goto integer;
9777
9778         case 'U':
9779 #ifdef IV_IS_QUAD
9780             intsize = 'q';
9781 #else
9782             intsize = 'l';
9783 #endif
9784             /*FALLTHROUGH*/
9785         case 'u':
9786             base = 10;
9787             goto uns_integer;
9788
9789         case 'B':
9790         case 'b':
9791             base = 2;
9792             goto uns_integer;
9793
9794         case 'O':
9795 #ifdef IV_IS_QUAD
9796             intsize = 'q';
9797 #else
9798             intsize = 'l';
9799 #endif
9800             /*FALLTHROUGH*/
9801         case 'o':
9802             base = 8;
9803             goto uns_integer;
9804
9805         case 'X':
9806         case 'x':
9807             base = 16;
9808
9809         uns_integer:
9810             if (vectorize) {
9811                 STRLEN ulen;
9812         vector:
9813                 if (!veclen)
9814                     continue;
9815                 if (vec_utf8)
9816                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9817                                         UTF8_ALLOW_ANYUV);
9818                 else {
9819                     uv = *vecstr;
9820                     ulen = 1;
9821                 }
9822                 vecstr += ulen;
9823                 veclen -= ulen;
9824             }
9825             else if (args) {
9826                 switch (intsize) {
9827                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
9828                 case 'l':  uv = va_arg(*args, unsigned long); break;
9829                 case 'V':  uv = va_arg(*args, UV); break;
9830                 default:   uv = va_arg(*args, unsigned); break;
9831                 case 'q':
9832 #ifdef HAS_QUAD
9833                            uv = va_arg(*args, Uquad_t); break;
9834 #else
9835                            goto unknown;
9836 #endif
9837                 }
9838             }
9839             else {
9840                 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9841                 switch (intsize) {
9842                 case 'h':       uv = (unsigned short)tuv; break;
9843                 case 'l':       uv = (unsigned long)tuv; break;
9844                 case 'V':
9845                 default:        uv = tuv; break;
9846                 case 'q':
9847 #ifdef HAS_QUAD
9848                                 uv = (Uquad_t)tuv; break;
9849 #else
9850                                 goto unknown;
9851 #endif
9852                 }
9853             }
9854
9855         integer:
9856             {
9857                 char *ptr = ebuf + sizeof ebuf;
9858                 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
9859                 zeros = 0;
9860
9861                 switch (base) {
9862                     unsigned dig;
9863                 case 16:
9864                     p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
9865                     do {
9866                         dig = uv & 15;
9867                         *--ptr = p[dig];
9868                     } while (uv >>= 4);
9869                     if (tempalt) {
9870                         esignbuf[esignlen++] = '0';
9871                         esignbuf[esignlen++] = c;  /* 'x' or 'X' */
9872                     }
9873                     break;
9874                 case 8:
9875                     do {
9876                         dig = uv & 7;
9877                         *--ptr = '0' + dig;
9878                     } while (uv >>= 3);
9879                     if (alt && *ptr != '0')
9880                         *--ptr = '0';
9881                     break;
9882                 case 2:
9883                     do {
9884                         dig = uv & 1;
9885                         *--ptr = '0' + dig;
9886                     } while (uv >>= 1);
9887                     if (tempalt) {
9888                         esignbuf[esignlen++] = '0';
9889                         esignbuf[esignlen++] = c;
9890                     }
9891                     break;
9892                 default:                /* it had better be ten or less */
9893                     do {
9894                         dig = uv % base;
9895                         *--ptr = '0' + dig;
9896                     } while (uv /= base);
9897                     break;
9898                 }
9899                 elen = (ebuf + sizeof ebuf) - ptr;
9900                 eptr = ptr;
9901                 if (has_precis) {
9902                     if (precis > elen)
9903                         zeros = precis - elen;
9904                     else if (precis == 0 && elen == 1 && *eptr == '0'
9905                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
9906                         elen = 0;
9907
9908                 /* a precision nullifies the 0 flag. */
9909                     if (fill == '0')
9910                         fill = ' ';
9911                 }
9912             }
9913             break;
9914
9915             /* FLOATING POINT */
9916
9917         case 'F':
9918             c = 'f';            /* maybe %F isn't supported here */
9919             /*FALLTHROUGH*/
9920         case 'e': case 'E':
9921         case 'f':
9922         case 'g': case 'G':
9923             if (vectorize)
9924                 goto unknown;
9925
9926             /* This is evil, but floating point is even more evil */
9927
9928             /* for SV-style calling, we can only get NV
9929                for C-style calling, we assume %f is double;
9930                for simplicity we allow any of %Lf, %llf, %qf for long double
9931             */
9932             switch (intsize) {
9933             case 'V':
9934 #if defined(USE_LONG_DOUBLE)
9935                 intsize = 'q';
9936 #endif
9937                 break;
9938 /* [perl #20339] - we should accept and ignore %lf rather than die */
9939             case 'l':
9940                 /*FALLTHROUGH*/
9941             default:
9942 #if defined(USE_LONG_DOUBLE)
9943                 intsize = args ? 0 : 'q';
9944 #endif
9945                 break;
9946             case 'q':
9947 #if defined(HAS_LONG_DOUBLE)
9948                 break;
9949 #else
9950                 /*FALLTHROUGH*/
9951 #endif
9952             case 'h':
9953                 goto unknown;
9954             }
9955
9956             /* now we need (long double) if intsize == 'q', else (double) */
9957             nv = (args) ?
9958 #if LONG_DOUBLESIZE > DOUBLESIZE
9959                 intsize == 'q' ?
9960                     va_arg(*args, long double) :
9961                     va_arg(*args, double)
9962 #else
9963                     va_arg(*args, double)
9964 #endif
9965                 : SvNV(argsv);
9966
9967             need = 0;
9968             /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
9969                else. frexp() has some unspecified behaviour for those three */
9970             if (c != 'e' && c != 'E' && (nv * 0) == 0) {
9971                 i = PERL_INT_MIN;
9972                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9973                    will cast our (long double) to (double) */
9974                 (void)Perl_frexp(nv, &i);
9975                 if (i == PERL_INT_MIN)
9976                     Perl_die(aTHX_ "panic: frexp");
9977                 if (i > 0)
9978                     need = BIT_DIGITS(i);
9979             }
9980             need += has_precis ? precis : 6; /* known default */
9981
9982             if (need < width)
9983                 need = width;
9984
9985 #ifdef HAS_LDBL_SPRINTF_BUG
9986             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9987                with sfio - Allen <allens@cpan.org> */
9988
9989 #  ifdef DBL_MAX
9990 #    define MY_DBL_MAX DBL_MAX
9991 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9992 #    if DOUBLESIZE >= 8
9993 #      define MY_DBL_MAX 1.7976931348623157E+308L
9994 #    else
9995 #      define MY_DBL_MAX 3.40282347E+38L
9996 #    endif
9997 #  endif
9998
9999 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10000 #    define MY_DBL_MAX_BUG 1L
10001 #  else
10002 #    define MY_DBL_MAX_BUG MY_DBL_MAX
10003 #  endif
10004
10005 #  ifdef DBL_MIN
10006 #    define MY_DBL_MIN DBL_MIN
10007 #  else  /* XXX guessing! -Allen */
10008 #    if DOUBLESIZE >= 8
10009 #      define MY_DBL_MIN 2.2250738585072014E-308L
10010 #    else
10011 #      define MY_DBL_MIN 1.17549435E-38L
10012 #    endif
10013 #  endif
10014
10015             if ((intsize == 'q') && (c == 'f') &&
10016                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10017                 (need < DBL_DIG)) {
10018                 /* it's going to be short enough that
10019                  * long double precision is not needed */
10020
10021                 if ((nv <= 0L) && (nv >= -0L))
10022                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10023                 else {
10024                     /* would use Perl_fp_class as a double-check but not
10025                      * functional on IRIX - see perl.h comments */
10026
10027                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10028                         /* It's within the range that a double can represent */
10029 #if defined(DBL_MAX) && !defined(DBL_MIN)
10030                         if ((nv >= ((long double)1/DBL_MAX)) ||
10031                             (nv <= (-(long double)1/DBL_MAX)))
10032 #endif
10033                         fix_ldbl_sprintf_bug = TRUE;
10034                     }
10035                 }
10036                 if (fix_ldbl_sprintf_bug == TRUE) {
10037                     double temp;
10038
10039                     intsize = 0;
10040                     temp = (double)nv;
10041                     nv = (NV)temp;
10042                 }
10043             }
10044
10045 #  undef MY_DBL_MAX
10046 #  undef MY_DBL_MAX_BUG
10047 #  undef MY_DBL_MIN
10048
10049 #endif /* HAS_LDBL_SPRINTF_BUG */
10050
10051             need += 20; /* fudge factor */
10052             if (PL_efloatsize < need) {
10053                 Safefree(PL_efloatbuf);
10054                 PL_efloatsize = need + 20; /* more fudge */
10055                 Newx(PL_efloatbuf, PL_efloatsize, char);
10056                 PL_efloatbuf[0] = '\0';
10057             }
10058
10059             if ( !(width || left || plus || alt) && fill != '0'
10060                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
10061                 /* See earlier comment about buggy Gconvert when digits,
10062                    aka precis is 0  */
10063                 if ( c == 'g' && precis) {
10064                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10065                     /* May return an empty string for digits==0 */
10066                     if (*PL_efloatbuf) {
10067                         elen = strlen(PL_efloatbuf);
10068                         goto float_converted;
10069                     }
10070                 } else if ( c == 'f' && !precis) {
10071                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10072                         break;
10073                 }
10074             }
10075             {
10076                 char *ptr = ebuf + sizeof ebuf;
10077                 *--ptr = '\0';
10078                 *--ptr = c;
10079                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10080 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10081                 if (intsize == 'q') {
10082                     /* Copy the one or more characters in a long double
10083                      * format before the 'base' ([efgEFG]) character to
10084                      * the format string. */
10085                     static char const prifldbl[] = PERL_PRIfldbl;
10086                     char const *p = prifldbl + sizeof(prifldbl) - 3;
10087                     while (p >= prifldbl) { *--ptr = *p--; }
10088                 }
10089 #endif
10090                 if (has_precis) {
10091                     base = precis;
10092                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10093                     *--ptr = '.';
10094                 }
10095                 if (width) {
10096                     base = width;
10097                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10098                 }
10099                 if (fill == '0')
10100                     *--ptr = fill;
10101                 if (left)
10102                     *--ptr = '-';
10103                 if (plus)
10104                     *--ptr = plus;
10105                 if (alt)
10106                     *--ptr = '#';
10107                 *--ptr = '%';
10108
10109                 /* No taint.  Otherwise we are in the strange situation
10110                  * where printf() taints but print($float) doesn't.
10111                  * --jhi */
10112 #if defined(HAS_LONG_DOUBLE)
10113                 elen = ((intsize == 'q')
10114                         ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10115                         : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10116 #else
10117                 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10118 #endif
10119             }
10120         float_converted:
10121             eptr = PL_efloatbuf;
10122             break;
10123
10124             /* SPECIAL */
10125
10126         case 'n':
10127             if (vectorize)
10128                 goto unknown;
10129             i = SvCUR(sv) - origlen;
10130             if (args) {
10131                 switch (intsize) {
10132                 case 'h':       *(va_arg(*args, short*)) = i; break;
10133                 default:        *(va_arg(*args, int*)) = i; break;
10134                 case 'l':       *(va_arg(*args, long*)) = i; break;
10135                 case 'V':       *(va_arg(*args, IV*)) = i; break;
10136                 case 'q':
10137 #ifdef HAS_QUAD
10138                                 *(va_arg(*args, Quad_t*)) = i; break;
10139 #else
10140                                 goto unknown;
10141 #endif
10142                 }
10143             }
10144             else
10145                 sv_setuv_mg(argsv, (UV)i);
10146             continue;   /* not "break" */
10147
10148             /* UNKNOWN */
10149
10150         default:
10151       unknown:
10152             if (!args
10153                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10154                 && ckWARN(WARN_PRINTF))
10155             {
10156                 SV * const msg = sv_newmortal();
10157                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10158                           (PL_op->op_type == OP_PRTF) ? "" : "s");
10159                 if (fmtstart < patend) {
10160                     const char * const fmtend = q < patend ? q : patend;
10161                     const char * f;
10162                     sv_catpvs(msg, "\"%");
10163                     for (f = fmtstart; f < fmtend; f++) {
10164                         if (isPRINT(*f)) {
10165                             sv_catpvn(msg, f, 1);
10166                         } else {
10167                             Perl_sv_catpvf(aTHX_ msg,
10168                                            "\\%03"UVof, (UV)*f & 0xFF);
10169                         }
10170                     }
10171                     sv_catpvs(msg, "\"");
10172                 } else {
10173                     sv_catpvs(msg, "end of string");
10174                 }
10175                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10176             }
10177
10178             /* output mangled stuff ... */
10179             if (c == '\0')
10180                 --q;
10181             eptr = p;
10182             elen = q - p;
10183
10184             /* ... right here, because formatting flags should not apply */
10185             SvGROW(sv, SvCUR(sv) + elen + 1);
10186             p = SvEND(sv);
10187             Copy(eptr, p, elen, char);
10188             p += elen;
10189             *p = '\0';
10190             SvCUR_set(sv, p - SvPVX_const(sv));
10191             svix = osvix;
10192             continue;   /* not "break" */
10193         }
10194
10195         if (is_utf8 != has_utf8) {
10196             if (is_utf8) {
10197                 if (SvCUR(sv))
10198                     sv_utf8_upgrade(sv);
10199             }
10200             else {
10201                 const STRLEN old_elen = elen;
10202                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10203                 sv_utf8_upgrade(nsv);
10204                 eptr = SvPVX_const(nsv);
10205                 elen = SvCUR(nsv);
10206
10207                 if (width) { /* fudge width (can't fudge elen) */
10208                     width += elen - old_elen;
10209                 }
10210                 is_utf8 = TRUE;
10211             }
10212         }
10213
10214         have = esignlen + zeros + elen;
10215         if (have < zeros)
10216             Perl_croak_nocontext("%s", PL_memory_wrap);
10217
10218         need = (have > width ? have : width);
10219         gap = need - have;
10220
10221         if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10222             Perl_croak_nocontext("%s", PL_memory_wrap);
10223         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10224         p = SvEND(sv);
10225         if (esignlen && fill == '0') {
10226             int i;
10227             for (i = 0; i < (int)esignlen; i++)
10228                 *p++ = esignbuf[i];
10229         }
10230         if (gap && !left) {
10231             memset(p, fill, gap);
10232             p += gap;
10233         }
10234         if (esignlen && fill != '0') {
10235             int i;
10236             for (i = 0; i < (int)esignlen; i++)
10237                 *p++ = esignbuf[i];
10238         }
10239         if (zeros) {
10240             int i;
10241             for (i = zeros; i; i--)
10242                 *p++ = '0';
10243         }
10244         if (elen) {
10245             Copy(eptr, p, elen, char);
10246             p += elen;
10247         }
10248         if (gap && left) {
10249             memset(p, ' ', gap);
10250             p += gap;
10251         }
10252         if (vectorize) {
10253             if (veclen) {
10254                 Copy(dotstr, p, dotstrlen, char);
10255                 p += dotstrlen;
10256             }
10257             else
10258                 vectorize = FALSE;              /* done iterating over vecstr */
10259         }
10260         if (is_utf8)
10261             has_utf8 = TRUE;
10262         if (has_utf8)
10263             SvUTF8_on(sv);
10264         *p = '\0';
10265         SvCUR_set(sv, p - SvPVX_const(sv));
10266         if (vectorize) {
10267             esignlen = 0;
10268             goto vector;
10269         }
10270     }
10271 }
10272
10273 /* =========================================================================
10274
10275 =head1 Cloning an interpreter
10276
10277 All the macros and functions in this section are for the private use of
10278 the main function, perl_clone().
10279
10280 The foo_dup() functions make an exact copy of an existing foo thingy.
10281 During the course of a cloning, a hash table is used to map old addresses
10282 to new addresses. The table is created and manipulated with the
10283 ptr_table_* functions.
10284
10285 =cut
10286
10287  * =========================================================================*/
10288
10289
10290 #if defined(USE_ITHREADS)
10291
10292 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10293 #ifndef GpREFCNT_inc
10294 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10295 #endif
10296
10297
10298 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10299    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10300    If this changes, please unmerge ss_dup.  */
10301 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10302 #define sv_dup_inc_NN(s,t)      SvREFCNT_inc_NN(sv_dup(s,t))
10303 #define av_dup(s,t)     MUTABLE_AV(sv_dup((const SV *)s,t))
10304 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10305 #define hv_dup(s,t)     MUTABLE_HV(sv_dup((const SV *)s,t))
10306 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10307 #define cv_dup(s,t)     MUTABLE_CV(sv_dup((const SV *)s,t))
10308 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10309 #define io_dup(s,t)     MUTABLE_IO(sv_dup((const SV *)s,t))
10310 #define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10311 #define gv_dup(s,t)     MUTABLE_GV(sv_dup((const SV *)s,t))
10312 #define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10313 #define SAVEPV(p)       ((p) ? savepv(p) : NULL)
10314 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
10315
10316 /* clone a parser */
10317
10318 yy_parser *
10319 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10320 {
10321     yy_parser *parser;
10322
10323     PERL_ARGS_ASSERT_PARSER_DUP;
10324
10325     if (!proto)
10326         return NULL;
10327
10328     /* look for it in the table first */
10329     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10330     if (parser)
10331         return parser;
10332
10333     /* create anew and remember what it is */
10334     Newxz(parser, 1, yy_parser);
10335     ptr_table_store(PL_ptr_table, proto, parser);
10336
10337     parser->yyerrstatus = 0;
10338     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
10339
10340     /* XXX these not yet duped */
10341     parser->old_parser = NULL;
10342     parser->stack = NULL;
10343     parser->ps = NULL;
10344     parser->stack_size = 0;
10345     /* XXX parser->stack->state = 0; */
10346
10347     /* XXX eventually, just Copy() most of the parser struct ? */
10348
10349     parser->lex_brackets = proto->lex_brackets;
10350     parser->lex_casemods = proto->lex_casemods;
10351     parser->lex_brackstack = savepvn(proto->lex_brackstack,
10352                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10353     parser->lex_casestack = savepvn(proto->lex_casestack,
10354                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10355     parser->lex_defer   = proto->lex_defer;
10356     parser->lex_dojoin  = proto->lex_dojoin;
10357     parser->lex_expect  = proto->lex_expect;
10358     parser->lex_formbrack = proto->lex_formbrack;
10359     parser->lex_inpat   = proto->lex_inpat;
10360     parser->lex_inwhat  = proto->lex_inwhat;
10361     parser->lex_op      = proto->lex_op;
10362     parser->lex_repl    = sv_dup_inc(proto->lex_repl, param);
10363     parser->lex_starts  = proto->lex_starts;
10364     parser->lex_stuff   = sv_dup_inc(proto->lex_stuff, param);
10365     parser->multi_close = proto->multi_close;
10366     parser->multi_open  = proto->multi_open;
10367     parser->multi_start = proto->multi_start;
10368     parser->multi_end   = proto->multi_end;
10369     parser->pending_ident = proto->pending_ident;
10370     parser->preambled   = proto->preambled;
10371     parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10372     parser->linestr     = sv_dup_inc(proto->linestr, param);
10373     parser->expect      = proto->expect;
10374     parser->copline     = proto->copline;
10375     parser->last_lop_op = proto->last_lop_op;
10376     parser->lex_state   = proto->lex_state;
10377     parser->rsfp        = fp_dup(proto->rsfp, '<', param);
10378     /* rsfp_filters entries have fake IoDIRP() */
10379     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10380     parser->in_my       = proto->in_my;
10381     parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10382     parser->error_count = proto->error_count;
10383
10384
10385     parser->linestr     = sv_dup_inc(proto->linestr, param);
10386
10387     {
10388         char * const ols = SvPVX(proto->linestr);
10389         char * const ls  = SvPVX(parser->linestr);
10390
10391         parser->bufptr      = ls + (proto->bufptr >= ols ?
10392                                     proto->bufptr -  ols : 0);
10393         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
10394                                     proto->oldbufptr -  ols : 0);
10395         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10396                                     proto->oldoldbufptr -  ols : 0);
10397         parser->linestart   = ls + (proto->linestart >= ols ?
10398                                     proto->linestart -  ols : 0);
10399         parser->last_uni    = ls + (proto->last_uni >= ols ?
10400                                     proto->last_uni -  ols : 0);
10401         parser->last_lop    = ls + (proto->last_lop >= ols ?
10402                                     proto->last_lop -  ols : 0);
10403
10404         parser->bufend      = ls + SvCUR(parser->linestr);
10405     }
10406
10407     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10408
10409
10410 #ifdef PERL_MAD
10411     parser->endwhite    = proto->endwhite;
10412     parser->faketokens  = proto->faketokens;
10413     parser->lasttoke    = proto->lasttoke;
10414     parser->nextwhite   = proto->nextwhite;
10415     parser->realtokenstart = proto->realtokenstart;
10416     parser->skipwhite   = proto->skipwhite;
10417     parser->thisclose   = proto->thisclose;
10418     parser->thismad     = proto->thismad;
10419     parser->thisopen    = proto->thisopen;
10420     parser->thisstuff   = proto->thisstuff;
10421     parser->thistoken   = proto->thistoken;
10422     parser->thiswhite   = proto->thiswhite;
10423
10424     Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10425     parser->curforce    = proto->curforce;
10426 #else
10427     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10428     Copy(proto->nexttype, parser->nexttype, 5,  I32);
10429     parser->nexttoke    = proto->nexttoke;
10430 #endif
10431     return parser;
10432 }
10433
10434
10435 /* duplicate a file handle */
10436
10437 PerlIO *
10438 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10439 {
10440     PerlIO *ret;
10441
10442     PERL_ARGS_ASSERT_FP_DUP;
10443     PERL_UNUSED_ARG(type);
10444
10445     if (!fp)
10446         return (PerlIO*)NULL;
10447
10448     /* look for it in the table first */
10449     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10450     if (ret)
10451         return ret;
10452
10453     /* create anew and remember what it is */
10454     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10455     ptr_table_store(PL_ptr_table, fp, ret);
10456     return ret;
10457 }
10458
10459 /* duplicate a directory handle */
10460
10461 DIR *
10462 Perl_dirp_dup(pTHX_ DIR *const dp)
10463 {
10464     PERL_UNUSED_CONTEXT;
10465     if (!dp)
10466         return (DIR*)NULL;
10467     /* XXX TODO */
10468     return dp;
10469 }
10470
10471 /* duplicate a typeglob */
10472
10473 GP *
10474 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10475 {
10476     GP *ret;
10477
10478     PERL_ARGS_ASSERT_GP_DUP;
10479
10480     if (!gp)
10481         return (GP*)NULL;
10482     /* look for it in the table first */
10483     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10484     if (ret)
10485         return ret;
10486
10487     /* create anew and remember what it is */
10488     Newxz(ret, 1, GP);
10489     ptr_table_store(PL_ptr_table, gp, ret);
10490
10491     /* clone */
10492     /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
10493        on Newxz() to do this for us.  */
10494     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
10495     ret->gp_io          = io_dup_inc(gp->gp_io, param);
10496     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
10497     ret->gp_av          = av_dup_inc(gp->gp_av, param);
10498     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
10499     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10500     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
10501     ret->gp_cvgen       = gp->gp_cvgen;
10502     ret->gp_line        = gp->gp_line;
10503     ret->gp_file_hek    = hek_dup(gp->gp_file_hek, param);
10504     return ret;
10505 }
10506
10507 /* duplicate a chain of magic */
10508
10509 MAGIC *
10510 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10511 {
10512     MAGIC *mgret = NULL;
10513     MAGIC **mgprev_p = &mgret;
10514
10515     PERL_ARGS_ASSERT_MG_DUP;
10516
10517     for (; mg; mg = mg->mg_moremagic) {
10518         MAGIC *nmg;
10519         Newx(nmg, 1, MAGIC);
10520         *mgprev_p = nmg;
10521         mgprev_p = &(nmg->mg_moremagic);
10522
10523         /* There was a comment "XXX copy dynamic vtable?" but as we don't have
10524            dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
10525            from the original commit adding Perl_mg_dup() - revision 4538.
10526            Similarly there is the annotation "XXX random ptr?" next to the
10527            assignment to nmg->mg_ptr.  */
10528         *nmg = *mg;
10529
10530         /* FIXME for plugins
10531         if (nmg->mg_type == PERL_MAGIC_qr) {
10532             nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
10533         }
10534         else
10535         */
10536         if(nmg->mg_type == PERL_MAGIC_backref) {
10537             /* The backref AV has its reference count deliberately bumped by
10538                1.  */
10539             nmg->mg_obj
10540                 = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param));
10541         }
10542         else {
10543             nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
10544                               ? sv_dup_inc(nmg->mg_obj, param)
10545                               : sv_dup(nmg->mg_obj, param);
10546         }
10547
10548         if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
10549             if (nmg->mg_len > 0) {
10550                 nmg->mg_ptr     = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
10551                 if (nmg->mg_type == PERL_MAGIC_overload_table &&
10552                         AMT_AMAGIC((AMT*)nmg->mg_ptr))
10553                 {
10554                     AMT * const namtp = (AMT*)nmg->mg_ptr;
10555                     I32 i;
10556                     for (i = 1; i < NofAMmeth; i++) {
10557                         namtp->table[i] = cv_dup_inc(namtp->table[i], param);
10558                     }
10559                 }
10560             }
10561             else if (nmg->mg_len == HEf_SVKEY)
10562                 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
10563         }
10564         if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
10565             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10566         }
10567     }
10568     return mgret;
10569 }
10570
10571 #endif /* USE_ITHREADS */
10572
10573 /* create a new pointer-mapping table */
10574
10575 PTR_TBL_t *
10576 Perl_ptr_table_new(pTHX)
10577 {
10578     PTR_TBL_t *tbl;
10579     PERL_UNUSED_CONTEXT;
10580
10581     Newxz(tbl, 1, PTR_TBL_t);
10582     tbl->tbl_max        = 511;
10583     tbl->tbl_items      = 0;
10584     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10585     return tbl;
10586 }
10587
10588 #define PTR_TABLE_HASH(ptr) \
10589   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10590
10591 /*
10592    we use the PTE_SVSLOT 'reservation' made above, both here (in the
10593    following define) and at call to new_body_inline made below in
10594    Perl_ptr_table_store()
10595  */
10596
10597 #define del_pte(p)     del_body_type(p, PTE_SVSLOT)
10598
10599 /* map an existing pointer using a table */
10600
10601 STATIC PTR_TBL_ENT_t *
10602 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10603 {
10604     PTR_TBL_ENT_t *tblent;
10605     const UV hash = PTR_TABLE_HASH(sv);
10606
10607     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10608
10609     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10610     for (; tblent; tblent = tblent->next) {
10611         if (tblent->oldval == sv)
10612             return tblent;
10613     }
10614     return NULL;
10615 }
10616
10617 void *
10618 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10619 {
10620     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10621
10622     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10623     PERL_UNUSED_CONTEXT;
10624
10625     return tblent ? tblent->newval : NULL;
10626 }
10627
10628 /* add a new entry to a pointer-mapping table */
10629
10630 void
10631 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10632 {
10633     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10634
10635     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10636     PERL_UNUSED_CONTEXT;
10637
10638     if (tblent) {
10639         tblent->newval = newsv;
10640     } else {
10641         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10642
10643         new_body_inline(tblent, PTE_SVSLOT);
10644
10645         tblent->oldval = oldsv;
10646         tblent->newval = newsv;
10647         tblent->next = tbl->tbl_ary[entry];
10648         tbl->tbl_ary[entry] = tblent;
10649         tbl->tbl_items++;
10650         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10651             ptr_table_split(tbl);
10652     }
10653 }
10654
10655 /* double the hash bucket size of an existing ptr table */
10656
10657 void
10658 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10659 {
10660     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10661     const UV oldsize = tbl->tbl_max + 1;
10662     UV newsize = oldsize * 2;
10663     UV i;
10664
10665     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10666     PERL_UNUSED_CONTEXT;
10667
10668     Renew(ary, newsize, PTR_TBL_ENT_t*);
10669     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10670     tbl->tbl_max = --newsize;
10671     tbl->tbl_ary = ary;
10672     for (i=0; i < oldsize; i++, ary++) {
10673         PTR_TBL_ENT_t **curentp, **entp, *ent;
10674         if (!*ary)
10675             continue;
10676         curentp = ary + oldsize;
10677         for (entp = ary, ent = *ary; ent; ent = *entp) {
10678             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10679                 *entp = ent->next;
10680                 ent->next = *curentp;
10681                 *curentp = ent;
10682                 continue;
10683             }
10684             else
10685                 entp = &ent->next;
10686         }
10687     }
10688 }
10689
10690 /* remove all the entries from a ptr table */
10691
10692 void
10693 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10694 {
10695     if (tbl && tbl->tbl_items) {
10696         register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
10697         UV riter = tbl->tbl_max;
10698
10699         do {
10700             PTR_TBL_ENT_t *entry = array[riter];
10701
10702             while (entry) {
10703                 PTR_TBL_ENT_t * const oentry = entry;
10704                 entry = entry->next;
10705                 del_pte(oentry);
10706             }
10707         } while (riter--);
10708
10709         tbl->tbl_items = 0;
10710     }
10711 }
10712
10713 /* clear and free a ptr table */
10714
10715 void
10716 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10717 {
10718     if (!tbl) {
10719         return;
10720     }
10721     ptr_table_clear(tbl);
10722     Safefree(tbl->tbl_ary);
10723     Safefree(tbl);
10724 }
10725
10726 #if defined(USE_ITHREADS)
10727
10728 void
10729 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10730 {
10731     PERL_ARGS_ASSERT_RVPV_DUP;
10732
10733     if (SvROK(sstr)) {
10734         SvRV_set(dstr, SvWEAKREF(sstr)
10735                        ? sv_dup(SvRV_const(sstr), param)
10736                        : sv_dup_inc(SvRV_const(sstr), param));
10737
10738     }
10739     else if (SvPVX_const(sstr)) {
10740         /* Has something there */
10741         if (SvLEN(sstr)) {
10742             /* Normal PV - clone whole allocated space */
10743             SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10744             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10745                 /* Not that normal - actually sstr is copy on write.
10746                    But we are a true, independant SV, so:  */
10747                 SvREADONLY_off(dstr);
10748                 SvFAKE_off(dstr);
10749             }
10750         }
10751         else {
10752             /* Special case - not normally malloced for some reason */
10753             if (isGV_with_GP(sstr)) {
10754                 /* Don't need to do anything here.  */
10755             }
10756             else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10757                 /* A "shared" PV - clone it as "shared" PV */
10758                 SvPV_set(dstr,
10759                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10760                                          param)));
10761             }
10762             else {
10763                 /* Some other special case - random pointer */
10764                 SvPV_set(dstr, (char *) SvPVX_const(sstr));
10765             }
10766         }
10767     }
10768     else {
10769         /* Copy the NULL */
10770         SvPV_set(dstr, NULL);
10771     }
10772 }
10773
10774 /* duplicate an SV of any type (including AV, HV etc) */
10775
10776 SV *
10777 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10778 {
10779     dVAR;
10780     SV *dstr;
10781
10782     PERL_ARGS_ASSERT_SV_DUP;
10783
10784     if (!sstr)
10785         return NULL;
10786     if (SvTYPE(sstr) == SVTYPEMASK) {
10787 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10788         abort();
10789 #endif
10790         return NULL;
10791     }
10792     /* look for it in the table first */
10793     dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
10794     if (dstr)
10795         return dstr;
10796
10797     if(param->flags & CLONEf_JOIN_IN) {
10798         /** We are joining here so we don't want do clone
10799             something that is bad **/
10800         if (SvTYPE(sstr) == SVt_PVHV) {
10801             const HEK * const hvname = HvNAME_HEK(sstr);
10802             if (hvname)
10803                 /** don't clone stashes if they already exist **/
10804                 return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
10805         }
10806     }
10807
10808     /* create anew and remember what it is */
10809     new_SV(dstr);
10810
10811 #ifdef DEBUG_LEAKING_SCALARS
10812     dstr->sv_debug_optype = sstr->sv_debug_optype;
10813     dstr->sv_debug_line = sstr->sv_debug_line;
10814     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10815     dstr->sv_debug_cloned = 1;
10816     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10817 #endif
10818
10819     ptr_table_store(PL_ptr_table, sstr, dstr);
10820
10821     /* clone */
10822     SvFLAGS(dstr)       = SvFLAGS(sstr);
10823     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
10824     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
10825
10826 #ifdef DEBUGGING
10827     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10828         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10829                       (void*)PL_watch_pvx, SvPVX_const(sstr));
10830 #endif
10831
10832     /* don't clone objects whose class has asked us not to */
10833     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10834         SvFLAGS(dstr) = 0;
10835         return dstr;
10836     }
10837
10838     switch (SvTYPE(sstr)) {
10839     case SVt_NULL:
10840         SvANY(dstr)     = NULL;
10841         break;
10842     case SVt_IV:
10843         SvANY(dstr)     = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10844         if(SvROK(sstr)) {
10845             Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10846         } else {
10847             SvIV_set(dstr, SvIVX(sstr));
10848         }
10849         break;
10850     case SVt_NV:
10851         SvANY(dstr)     = new_XNV();
10852         SvNV_set(dstr, SvNVX(sstr));
10853         break;
10854         /* case SVt_BIND: */
10855     default:
10856         {
10857             /* These are all the types that need complex bodies allocating.  */
10858             void *new_body;
10859             const svtype sv_type = SvTYPE(sstr);
10860             const struct body_details *const sv_type_details
10861                 = bodies_by_type + sv_type;
10862
10863             switch (sv_type) {
10864             default:
10865                 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10866                 break;
10867
10868             case SVt_PVGV:
10869             case SVt_PVIO:
10870             case SVt_PVFM:
10871             case SVt_PVHV:
10872             case SVt_PVAV:
10873             case SVt_PVCV:
10874             case SVt_PVLV:
10875             case SVt_REGEXP:
10876             case SVt_PVMG:
10877             case SVt_PVNV:
10878             case SVt_PVIV:
10879             case SVt_PV:
10880                 assert(sv_type_details->body_size);
10881                 if (sv_type_details->arena) {
10882                     new_body_inline(new_body, sv_type);
10883                     new_body
10884                         = (void*)((char*)new_body - sv_type_details->offset);
10885                 } else {
10886                     new_body = new_NOARENA(sv_type_details);
10887                 }
10888             }
10889             assert(new_body);
10890             SvANY(dstr) = new_body;
10891
10892 #ifndef PURIFY
10893             Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
10894                  ((char*)SvANY(dstr)) + sv_type_details->offset,
10895                  sv_type_details->copy, char);
10896 #else
10897             Copy(((char*)SvANY(sstr)),
10898                  ((char*)SvANY(dstr)),
10899                  sv_type_details->body_size + sv_type_details->offset, char);
10900 #endif
10901
10902             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
10903                 && !isGV_with_GP(dstr))
10904                 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10905
10906             /* The Copy above means that all the source (unduplicated) pointers
10907                are now in the destination.  We can check the flags and the
10908                pointers in either, but it's possible that there's less cache
10909                missing by always going for the destination.
10910                FIXME - instrument and check that assumption  */
10911             if (sv_type >= SVt_PVMG) {
10912                 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
10913                     SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
10914                 } else if (SvMAGIC(dstr))
10915                     SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10916                 if (SvSTASH(dstr))
10917                     SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10918             }
10919
10920             /* The cast silences a GCC warning about unhandled types.  */
10921             switch ((int)sv_type) {
10922             case SVt_PV:
10923                 break;
10924             case SVt_PVIV:
10925                 break;
10926             case SVt_PVNV:
10927                 break;
10928             case SVt_PVMG:
10929                 break;
10930             case SVt_REGEXP:
10931                 /* FIXME for plugins */
10932                 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
10933                 break;
10934             case SVt_PVLV:
10935                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10936                 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10937                     LvTARG(dstr) = dstr;
10938                 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10939                     LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
10940                 else
10941                     LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10942             case SVt_PVGV:
10943                 if(isGV_with_GP(sstr)) {
10944                     GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
10945                     /* Don't call sv_add_backref here as it's going to be
10946                        created as part of the magic cloning of the symbol
10947                        table.  */
10948                     /* Danger Will Robinson - GvGP(dstr) isn't initialised
10949                        at the point of this comment.  */
10950                     GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10951                     GvGP(dstr)  = gp_dup(GvGP(sstr), param);
10952                     (void)GpREFCNT_inc(GvGP(dstr));
10953                 } else
10954                     Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10955                 break;
10956             case SVt_PVIO:
10957                 IoIFP(dstr)     = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10958                 if (IoOFP(dstr) == IoIFP(sstr))
10959                     IoOFP(dstr) = IoIFP(dstr);
10960                 else
10961                     IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10962                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
10963                 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10964                     /* I have no idea why fake dirp (rsfps)
10965                        should be treated differently but otherwise
10966                        we end up with leaks -- sky*/
10967                     IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
10968                     IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
10969                     IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10970                 } else {
10971                     IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
10972                     IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
10973                     IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
10974                     if (IoDIRP(dstr)) {
10975                         IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr));
10976                     } else {
10977                         NOOP;
10978                         /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
10979                     }
10980                 }
10981                 IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
10982                 IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
10983                 IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
10984                 break;
10985             case SVt_PVAV:
10986                 /* avoid cloning an empty array */
10987                 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
10988                     SV **dst_ary, **src_ary;
10989                     SSize_t items = AvFILLp((const AV *)sstr) + 1;
10990
10991                     src_ary = AvARRAY((const AV *)sstr);
10992                     Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
10993                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10994                     AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
10995                     AvALLOC((const AV *)dstr) = dst_ary;
10996                     if (AvREAL((const AV *)sstr)) {
10997                         while (items-- > 0)
10998                             *dst_ary++ = sv_dup_inc(*src_ary++, param);
10999                     }
11000                     else {
11001                         while (items-- > 0)
11002                             *dst_ary++ = sv_dup(*src_ary++, param);
11003                     }
11004                     items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11005                     while (items-- > 0) {
11006                         *dst_ary++ = &PL_sv_undef;
11007                     }
11008                 }
11009                 else {
11010                     AvARRAY(MUTABLE_AV(dstr))   = NULL;
11011                     AvALLOC((const AV *)dstr)   = (SV**)NULL;
11012                     AvMAX(  (const AV *)dstr)   = -1;
11013                     AvFILLp((const AV *)dstr)   = -1;
11014                 }
11015                 break;
11016             case SVt_PVHV:
11017                 if (HvARRAY((const HV *)sstr)) {
11018                     STRLEN i = 0;
11019                     const bool sharekeys = !!HvSHAREKEYS(sstr);
11020                     XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11021                     XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11022                     char *darray;
11023                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11024                         + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11025                         char);
11026                     HvARRAY(dstr) = (HE**)darray;
11027                     while (i <= sxhv->xhv_max) {
11028                         const HE * const source = HvARRAY(sstr)[i];
11029                         HvARRAY(dstr)[i] = source
11030                             ? he_dup(source, sharekeys, param) : 0;
11031                         ++i;
11032                     }
11033                     if (SvOOK(sstr)) {
11034                         HEK *hvname;
11035                         const struct xpvhv_aux * const saux = HvAUX(sstr);
11036                         struct xpvhv_aux * const daux = HvAUX(dstr);
11037                         /* This flag isn't copied.  */
11038                         /* SvOOK_on(hv) attacks the IV flags.  */
11039                         SvFLAGS(dstr) |= SVf_OOK;
11040
11041                         hvname = saux->xhv_name;
11042                         daux->xhv_name = hek_dup(hvname, param);
11043
11044                         daux->xhv_riter = saux->xhv_riter;
11045                         daux->xhv_eiter = saux->xhv_eiter
11046                             ? he_dup(saux->xhv_eiter,
11047                                         (bool)!!HvSHAREKEYS(sstr), param) : 0;
11048                         /* backref array needs refcnt=2; see sv_add_backref */
11049                         daux->xhv_backreferences =
11050                             saux->xhv_backreferences
11051                             ? MUTABLE_AV(SvREFCNT_inc(
11052                                                       sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
11053                                 : 0;
11054
11055                         daux->xhv_mro_meta = saux->xhv_mro_meta
11056                             ? mro_meta_dup(saux->xhv_mro_meta, param)
11057                             : 0;
11058
11059                         /* Record stashes for possible cloning in Perl_clone(). */
11060                         if (hvname)
11061                             av_push(param->stashes, dstr);
11062                     }
11063                 }
11064                 else
11065                     HvARRAY(MUTABLE_HV(dstr)) = NULL;
11066                 break;
11067             case SVt_PVCV:
11068                 if (!(param->flags & CLONEf_COPY_STACKS)) {
11069                     CvDEPTH(dstr) = 0;
11070                 }
11071             case SVt_PVFM:
11072                 /* NOTE: not refcounted */
11073                 CvSTASH(dstr)   = hv_dup(CvSTASH(dstr), param);
11074                 OP_REFCNT_LOCK;
11075                 if (!CvISXSUB(dstr))
11076                     CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11077                 OP_REFCNT_UNLOCK;
11078                 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11079                     CvXSUBANY(dstr).any_ptr =
11080                         sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11081                 }
11082                 /* don't dup if copying back - CvGV isn't refcounted, so the
11083                  * duped GV may never be freed. A bit of a hack! DAPM */
11084                 CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
11085                     NULL : gv_dup(CvGV(dstr), param) ;
11086                 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11087                 CvOUTSIDE(dstr) =
11088                     CvWEAKOUTSIDE(sstr)
11089                     ? cv_dup(    CvOUTSIDE(dstr), param)
11090                     : cv_dup_inc(CvOUTSIDE(dstr), param);
11091                 if (!CvISXSUB(dstr))
11092                     CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11093                 break;
11094             }
11095         }
11096     }
11097
11098     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11099         ++PL_sv_objcount;
11100
11101     return dstr;
11102  }
11103
11104 /* duplicate a context */
11105
11106 PERL_CONTEXT *
11107 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11108 {
11109     PERL_CONTEXT *ncxs;
11110
11111     PERL_ARGS_ASSERT_CX_DUP;
11112
11113     if (!cxs)
11114         return (PERL_CONTEXT*)NULL;
11115
11116     /* look for it in the table first */
11117     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11118     if (ncxs)
11119         return ncxs;
11120
11121     /* create anew and remember what it is */
11122     Newx(ncxs, max + 1, PERL_CONTEXT);
11123     ptr_table_store(PL_ptr_table, cxs, ncxs);
11124     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11125
11126     while (ix >= 0) {
11127         PERL_CONTEXT * const ncx = &ncxs[ix];
11128         if (CxTYPE(ncx) == CXt_SUBST) {
11129             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11130         }
11131         else {
11132             switch (CxTYPE(ncx)) {
11133             case CXt_SUB:
11134                 ncx->blk_sub.cv         = (ncx->blk_sub.olddepth == 0
11135                                            ? cv_dup_inc(ncx->blk_sub.cv, param)
11136                                            : cv_dup(ncx->blk_sub.cv,param));
11137                 ncx->blk_sub.argarray   = (CxHASARGS(ncx)
11138                                            ? av_dup_inc(ncx->blk_sub.argarray,
11139                                                         param)
11140                                            : NULL);
11141                 ncx->blk_sub.savearray  = av_dup_inc(ncx->blk_sub.savearray,
11142                                                      param);
11143                 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11144                                            ncx->blk_sub.oldcomppad);
11145                 break;
11146             case CXt_EVAL:
11147                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11148                                                       param);
11149                 ncx->blk_eval.cur_text  = sv_dup(ncx->blk_eval.cur_text, param);
11150                 break;
11151             case CXt_LOOP_LAZYSV:
11152                 ncx->blk_loop.state_u.lazysv.end
11153                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11154                 /* We are taking advantage of av_dup_inc and sv_dup_inc
11155                    actually being the same function, and order equivalance of
11156                    the two unions.
11157                    We can assert the later [but only at run time :-(]  */
11158                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11159                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
11160             case CXt_LOOP_FOR:
11161                 ncx->blk_loop.state_u.ary.ary
11162                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11163             case CXt_LOOP_LAZYIV:
11164             case CXt_LOOP_PLAIN:
11165                 if (CxPADLOOP(ncx)) {
11166                     ncx->blk_loop.oldcomppad
11167                         = (PAD*)ptr_table_fetch(PL_ptr_table,
11168                                                 ncx->blk_loop.oldcomppad);
11169                 } else {
11170                     ncx->blk_loop.oldcomppad
11171                         = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
11172                                        param);
11173                 }
11174                 break;
11175             case CXt_FORMAT:
11176                 ncx->blk_format.cv      = cv_dup(ncx->blk_format.cv, param);
11177                 ncx->blk_format.gv      = gv_dup(ncx->blk_format.gv, param);
11178                 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11179                                                      param);
11180                 break;
11181             case CXt_BLOCK:
11182             case CXt_NULL:
11183                 break;
11184             }
11185         }
11186         --ix;
11187     }
11188     return ncxs;
11189 }
11190
11191 /* duplicate a stack info structure */
11192
11193 PERL_SI *
11194 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11195 {
11196     PERL_SI *nsi;
11197
11198     PERL_ARGS_ASSERT_SI_DUP;
11199
11200     if (!si)
11201         return (PERL_SI*)NULL;
11202
11203     /* look for it in the table first */
11204     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11205     if (nsi)
11206         return nsi;
11207
11208     /* create anew and remember what it is */
11209     Newxz(nsi, 1, PERL_SI);
11210     ptr_table_store(PL_ptr_table, si, nsi);
11211
11212     nsi->si_stack       = av_dup_inc(si->si_stack, param);
11213     nsi->si_cxix        = si->si_cxix;
11214     nsi->si_cxmax       = si->si_cxmax;
11215     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11216     nsi->si_type        = si->si_type;
11217     nsi->si_prev        = si_dup(si->si_prev, param);
11218     nsi->si_next        = si_dup(si->si_next, param);
11219     nsi->si_markoff     = si->si_markoff;
11220
11221     return nsi;
11222 }
11223
11224 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
11225 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
11226 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
11227 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
11228 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
11229 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
11230 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
11231 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
11232 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
11233 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
11234 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
11235 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
11236 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11237 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11238
11239 /* XXXXX todo */
11240 #define pv_dup_inc(p)   SAVEPV(p)
11241 #define pv_dup(p)       SAVEPV(p)
11242 #define svp_dup_inc(p,pp)       any_dup(p,pp)
11243
11244 /* map any object to the new equivent - either something in the
11245  * ptr table, or something in the interpreter structure
11246  */
11247
11248 void *
11249 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11250 {
11251     void *ret;
11252
11253     PERL_ARGS_ASSERT_ANY_DUP;
11254
11255     if (!v)
11256         return (void*)NULL;
11257
11258     /* look for it in the table first */
11259     ret = ptr_table_fetch(PL_ptr_table, v);
11260     if (ret)
11261         return ret;
11262
11263     /* see if it is part of the interpreter structure */
11264     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11265         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11266     else {
11267         ret = v;
11268     }
11269
11270     return ret;
11271 }
11272
11273 /* duplicate the save stack */
11274
11275 ANY *
11276 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11277 {
11278     dVAR;
11279     ANY * const ss      = proto_perl->Isavestack;
11280     const I32 max       = proto_perl->Isavestack_max;
11281     I32 ix              = proto_perl->Isavestack_ix;
11282     ANY *nss;
11283     const SV *sv;
11284     const GV *gv;
11285     const AV *av;
11286     const HV *hv;
11287     void* ptr;
11288     int intval;
11289     long longval;
11290     GP *gp;
11291     IV iv;
11292     I32 i;
11293     char *c = NULL;
11294     void (*dptr) (void*);
11295     void (*dxptr) (pTHX_ void*);
11296
11297     PERL_ARGS_ASSERT_SS_DUP;
11298
11299     Newxz(nss, max, ANY);
11300
11301     while (ix > 0) {
11302         const I32 type = POPINT(ss,ix);
11303         TOPINT(nss,ix) = type;
11304         switch (type) {
11305         case SAVEt_HELEM:               /* hash element */
11306             sv = (const SV *)POPPTR(ss,ix);
11307             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11308             /* fall through */
11309         case SAVEt_ITEM:                        /* normal string */
11310         case SAVEt_SV:                          /* scalar reference */
11311             sv = (const SV *)POPPTR(ss,ix);
11312             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11313             /* fall through */
11314         case SAVEt_FREESV:
11315         case SAVEt_MORTALIZESV:
11316             sv = (const SV *)POPPTR(ss,ix);
11317             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11318             break;
11319         case SAVEt_SHARED_PVREF:                /* char* in shared space */
11320             c = (char*)POPPTR(ss,ix);
11321             TOPPTR(nss,ix) = savesharedpv(c);
11322             ptr = POPPTR(ss,ix);
11323             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11324             break;
11325         case SAVEt_GENERIC_SVREF:               /* generic sv */
11326         case SAVEt_SVREF:                       /* scalar reference */
11327             sv = (const SV *)POPPTR(ss,ix);
11328             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11329             ptr = POPPTR(ss,ix);
11330             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11331             break;
11332         case SAVEt_HV:                          /* hash reference */
11333         case SAVEt_AV:                          /* array reference */
11334             sv = (const SV *) POPPTR(ss,ix);
11335             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11336             /* fall through */
11337         case SAVEt_COMPPAD:
11338         case SAVEt_NSTAB:
11339             sv = (const SV *) POPPTR(ss,ix);
11340             TOPPTR(nss,ix) = sv_dup(sv, param);
11341             break;
11342         case SAVEt_INT:                         /* int reference */
11343             ptr = POPPTR(ss,ix);
11344             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11345             intval = (int)POPINT(ss,ix);
11346             TOPINT(nss,ix) = intval;
11347             break;
11348         case SAVEt_LONG:                        /* long reference */
11349             ptr = POPPTR(ss,ix);
11350             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11351             /* fall through */
11352         case SAVEt_CLEARSV:
11353             longval = (long)POPLONG(ss,ix);
11354             TOPLONG(nss,ix) = longval;
11355             break;
11356         case SAVEt_I32:                         /* I32 reference */
11357         case SAVEt_I16:                         /* I16 reference */
11358         case SAVEt_I8:                          /* I8 reference */
11359         case SAVEt_COP_ARYBASE:                 /* call CopARYBASE_set */
11360             ptr = POPPTR(ss,ix);
11361             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11362             i = POPINT(ss,ix);
11363             TOPINT(nss,ix) = i;
11364             break;
11365         case SAVEt_IV:                          /* IV reference */
11366             ptr = POPPTR(ss,ix);
11367             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11368             iv = POPIV(ss,ix);
11369             TOPIV(nss,ix) = iv;
11370             break;
11371         case SAVEt_HPTR:                        /* HV* reference */
11372         case SAVEt_APTR:                        /* AV* reference */
11373         case SAVEt_SPTR:                        /* SV* reference */
11374             ptr = POPPTR(ss,ix);
11375             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11376             sv = (const SV *)POPPTR(ss,ix);
11377             TOPPTR(nss,ix) = sv_dup(sv, param);
11378             break;
11379         case SAVEt_VPTR:                        /* random* reference */
11380             ptr = POPPTR(ss,ix);
11381             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11382             ptr = POPPTR(ss,ix);
11383             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11384             break;
11385         case SAVEt_GENERIC_PVREF:               /* generic char* */
11386         case SAVEt_PPTR:                        /* char* reference */
11387             ptr = POPPTR(ss,ix);
11388             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11389             c = (char*)POPPTR(ss,ix);
11390             TOPPTR(nss,ix) = pv_dup(c);
11391             break;
11392         case SAVEt_GP:                          /* scalar reference */
11393             gp = (GP*)POPPTR(ss,ix);
11394             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11395             (void)GpREFCNT_inc(gp);
11396             gv = (const GV *)POPPTR(ss,ix);
11397             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11398             break;
11399         case SAVEt_FREEOP:
11400             ptr = POPPTR(ss,ix);
11401             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11402                 /* these are assumed to be refcounted properly */
11403                 OP *o;
11404                 switch (((OP*)ptr)->op_type) {
11405                 case OP_LEAVESUB:
11406                 case OP_LEAVESUBLV:
11407                 case OP_LEAVEEVAL:
11408                 case OP_LEAVE:
11409                 case OP_SCOPE:
11410                 case OP_LEAVEWRITE:
11411                     TOPPTR(nss,ix) = ptr;
11412                     o = (OP*)ptr;
11413                     OP_REFCNT_LOCK;
11414                     (void) OpREFCNT_inc(o);
11415                     OP_REFCNT_UNLOCK;
11416                     break;
11417                 default:
11418                     TOPPTR(nss,ix) = NULL;
11419                     break;
11420                 }
11421             }
11422             else
11423                 TOPPTR(nss,ix) = NULL;
11424             break;
11425         case SAVEt_DELETE:
11426             hv = (const HV *)POPPTR(ss,ix);
11427             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11428             i = POPINT(ss,ix);
11429             TOPINT(nss,ix) = i;
11430             /* Fall through */
11431         case SAVEt_FREEPV:
11432             c = (char*)POPPTR(ss,ix);
11433             TOPPTR(nss,ix) = pv_dup_inc(c);
11434             break;
11435         case SAVEt_STACK_POS:           /* Position on Perl stack */
11436             i = POPINT(ss,ix);
11437             TOPINT(nss,ix) = i;
11438             break;
11439         case SAVEt_DESTRUCTOR:
11440             ptr = POPPTR(ss,ix);
11441             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11442             dptr = POPDPTR(ss,ix);
11443             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11444                                         any_dup(FPTR2DPTR(void *, dptr),
11445                                                 proto_perl));
11446             break;
11447         case SAVEt_DESTRUCTOR_X:
11448             ptr = POPPTR(ss,ix);
11449             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11450             dxptr = POPDXPTR(ss,ix);
11451             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11452                                          any_dup(FPTR2DPTR(void *, dxptr),
11453                                                  proto_perl));
11454             break;
11455         case SAVEt_REGCONTEXT:
11456         case SAVEt_ALLOC:
11457             i = POPINT(ss,ix);
11458             TOPINT(nss,ix) = i;
11459             ix -= i;
11460             break;
11461         case SAVEt_AELEM:               /* array element */
11462             sv = (const SV *)POPPTR(ss,ix);
11463             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11464             i = POPINT(ss,ix);
11465             TOPINT(nss,ix) = i;
11466             av = (const AV *)POPPTR(ss,ix);
11467             TOPPTR(nss,ix) = av_dup_inc(av, param);
11468             break;
11469         case SAVEt_OP:
11470             ptr = POPPTR(ss,ix);
11471             TOPPTR(nss,ix) = ptr;
11472             break;
11473         case SAVEt_HINTS:
11474             ptr = POPPTR(ss,ix);
11475             if (ptr) {
11476                 HINTS_REFCNT_LOCK;
11477                 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11478                 HINTS_REFCNT_UNLOCK;
11479             }
11480             TOPPTR(nss,ix) = ptr;
11481             i = POPINT(ss,ix);
11482             TOPINT(nss,ix) = i;
11483             if (i & HINT_LOCALIZE_HH) {
11484                 hv = (const HV *)POPPTR(ss,ix);
11485                 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11486             }
11487             break;
11488         case SAVEt_PADSV_AND_MORTALIZE:
11489             longval = (long)POPLONG(ss,ix);
11490             TOPLONG(nss,ix) = longval;
11491             ptr = POPPTR(ss,ix);
11492             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11493             sv = (const SV *)POPPTR(ss,ix);
11494             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11495             break;
11496         case SAVEt_BOOL:
11497             ptr = POPPTR(ss,ix);
11498             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11499             longval = (long)POPBOOL(ss,ix);
11500             TOPBOOL(nss,ix) = (bool)longval;
11501             break;
11502         case SAVEt_SET_SVFLAGS:
11503             i = POPINT(ss,ix);
11504             TOPINT(nss,ix) = i;
11505             i = POPINT(ss,ix);
11506             TOPINT(nss,ix) = i;
11507             sv = (const SV *)POPPTR(ss,ix);
11508             TOPPTR(nss,ix) = sv_dup(sv, param);
11509             break;
11510         case SAVEt_RE_STATE:
11511             {
11512                 const struct re_save_state *const old_state
11513                     = (struct re_save_state *)
11514                     (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11515                 struct re_save_state *const new_state
11516                     = (struct re_save_state *)
11517                     (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11518
11519                 Copy(old_state, new_state, 1, struct re_save_state);
11520                 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11521
11522                 new_state->re_state_bostr
11523                     = pv_dup(old_state->re_state_bostr);
11524                 new_state->re_state_reginput
11525                     = pv_dup(old_state->re_state_reginput);
11526                 new_state->re_state_regeol
11527                     = pv_dup(old_state->re_state_regeol);
11528                 new_state->re_state_regoffs
11529                     = (regexp_paren_pair*)
11530                         any_dup(old_state->re_state_regoffs, proto_perl);
11531                 new_state->re_state_reglastparen
11532                     = (U32*) any_dup(old_state->re_state_reglastparen,
11533                               proto_perl);
11534                 new_state->re_state_reglastcloseparen
11535                     = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11536                               proto_perl);
11537                 /* XXX This just has to be broken. The old save_re_context
11538                    code did SAVEGENERICPV(PL_reg_start_tmp);
11539                    PL_reg_start_tmp is char **.
11540                    Look above to what the dup code does for
11541                    SAVEt_GENERIC_PVREF
11542                    It can never have worked.
11543                    So this is merely a faithful copy of the exiting bug:  */
11544                 new_state->re_state_reg_start_tmp
11545                     = (char **) pv_dup((char *)
11546                                       old_state->re_state_reg_start_tmp);
11547                 /* I assume that it only ever "worked" because no-one called
11548                    (pseudo)fork while the regexp engine had re-entered itself.
11549                 */
11550 #ifdef PERL_OLD_COPY_ON_WRITE
11551                 new_state->re_state_nrs
11552                     = sv_dup(old_state->re_state_nrs, param);
11553 #endif
11554                 new_state->re_state_reg_magic
11555                     = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11556                                proto_perl);
11557                 new_state->re_state_reg_oldcurpm
11558                     = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11559                               proto_perl);
11560                 new_state->re_state_reg_curpm
11561                     = (PMOP*)  any_dup(old_state->re_state_reg_curpm,
11562                                proto_perl);
11563                 new_state->re_state_reg_oldsaved
11564                     = pv_dup(old_state->re_state_reg_oldsaved);
11565                 new_state->re_state_reg_poscache
11566                     = pv_dup(old_state->re_state_reg_poscache);
11567                 new_state->re_state_reg_starttry
11568                     = pv_dup(old_state->re_state_reg_starttry);
11569                 break;
11570             }
11571         case SAVEt_COMPILE_WARNINGS:
11572             ptr = POPPTR(ss,ix);
11573             TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11574             break;
11575         case SAVEt_PARSER:
11576             ptr = POPPTR(ss,ix);
11577             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11578             break;
11579         default:
11580             Perl_croak(aTHX_
11581                        "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11582         }
11583     }
11584
11585     return nss;
11586 }
11587
11588
11589 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11590  * flag to the result. This is done for each stash before cloning starts,
11591  * so we know which stashes want their objects cloned */
11592
11593 static void
11594 do_mark_cloneable_stash(pTHX_ SV *const sv)
11595 {
11596     const HEK * const hvname = HvNAME_HEK((const HV *)sv);
11597     if (hvname) {
11598         GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
11599         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11600         if (cloner && GvCV(cloner)) {
11601             dSP;
11602             UV status;
11603
11604             ENTER;
11605             SAVETMPS;
11606             PUSHMARK(SP);
11607             mXPUSHs(newSVhek(hvname));
11608             PUTBACK;
11609             call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
11610             SPAGAIN;
11611             status = POPu;
11612             PUTBACK;
11613             FREETMPS;
11614             LEAVE;
11615             if (status)
11616                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11617         }
11618     }
11619 }
11620
11621
11622
11623 /*
11624 =for apidoc perl_clone
11625
11626 Create and return a new interpreter by cloning the current one.
11627
11628 perl_clone takes these flags as parameters:
11629
11630 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11631 without it we only clone the data and zero the stacks,
11632 with it we copy the stacks and the new perl interpreter is
11633 ready to run at the exact same point as the previous one.
11634 The pseudo-fork code uses COPY_STACKS while the
11635 threads->create doesn't.
11636
11637 CLONEf_KEEP_PTR_TABLE
11638 perl_clone keeps a ptr_table with the pointer of the old
11639 variable as a key and the new variable as a value,
11640 this allows it to check if something has been cloned and not
11641 clone it again but rather just use the value and increase the
11642 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11643 the ptr_table using the function
11644 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11645 reason to keep it around is if you want to dup some of your own
11646 variable who are outside the graph perl scans, example of this
11647 code is in threads.xs create
11648
11649 CLONEf_CLONE_HOST
11650 This is a win32 thing, it is ignored on unix, it tells perls
11651 win32host code (which is c++) to clone itself, this is needed on
11652 win32 if you want to run two threads at the same time,
11653 if you just want to do some stuff in a separate perl interpreter
11654 and then throw it away and return to the original one,
11655 you don't need to do anything.
11656
11657 =cut
11658 */
11659
11660 /* XXX the above needs expanding by someone who actually understands it ! */
11661 EXTERN_C PerlInterpreter *
11662 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11663
11664 PerlInterpreter *
11665 perl_clone(PerlInterpreter *proto_perl, UV flags)
11666 {
11667    dVAR;
11668 #ifdef PERL_IMPLICIT_SYS
11669
11670     PERL_ARGS_ASSERT_PERL_CLONE;
11671
11672    /* perlhost.h so we need to call into it
11673    to clone the host, CPerlHost should have a c interface, sky */
11674
11675    if (flags & CLONEf_CLONE_HOST) {
11676        return perl_clone_host(proto_perl,flags);
11677    }
11678    return perl_clone_using(proto_perl, flags,
11679                             proto_perl->IMem,
11680                             proto_perl->IMemShared,
11681                             proto_perl->IMemParse,
11682                             proto_perl->IEnv,
11683                             proto_perl->IStdIO,
11684                             proto_perl->ILIO,
11685                             proto_perl->IDir,
11686                             proto_perl->ISock,
11687                             proto_perl->IProc);
11688 }
11689
11690 PerlInterpreter *
11691 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11692                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
11693                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11694                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11695                  struct IPerlDir* ipD, struct IPerlSock* ipS,
11696                  struct IPerlProc* ipP)
11697 {
11698     /* XXX many of the string copies here can be optimized if they're
11699      * constants; they need to be allocated as common memory and just
11700      * their pointers copied. */
11701
11702     IV i;
11703     CLONE_PARAMS clone_params;
11704     CLONE_PARAMS* const param = &clone_params;
11705
11706     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11707
11708     PERL_ARGS_ASSERT_PERL_CLONE_USING;
11709
11710     /* for each stash, determine whether its objects should be cloned */
11711     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11712     PERL_SET_THX(my_perl);
11713
11714 #  ifdef DEBUGGING
11715     PoisonNew(my_perl, 1, PerlInterpreter);
11716     PL_op = NULL;
11717     PL_curcop = NULL;
11718     PL_markstack = 0;
11719     PL_scopestack = 0;
11720     PL_savestack = 0;
11721     PL_savestack_ix = 0;
11722     PL_savestack_max = -1;
11723     PL_sig_pending = 0;
11724     PL_parser = NULL;
11725     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11726 #  else /* !DEBUGGING */
11727     Zero(my_perl, 1, PerlInterpreter);
11728 #  endif        /* DEBUGGING */
11729
11730     /* host pointers */
11731     PL_Mem              = ipM;
11732     PL_MemShared        = ipMS;
11733     PL_MemParse         = ipMP;
11734     PL_Env              = ipE;
11735     PL_StdIO            = ipStd;
11736     PL_LIO              = ipLIO;
11737     PL_Dir              = ipD;
11738     PL_Sock             = ipS;
11739     PL_Proc             = ipP;
11740 #else           /* !PERL_IMPLICIT_SYS */
11741     IV i;
11742     CLONE_PARAMS clone_params;
11743     CLONE_PARAMS* param = &clone_params;
11744     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11745
11746     PERL_ARGS_ASSERT_PERL_CLONE;
11747
11748     /* for each stash, determine whether its objects should be cloned */
11749     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11750     PERL_SET_THX(my_perl);
11751
11752 #    ifdef DEBUGGING
11753     PoisonNew(my_perl, 1, PerlInterpreter);
11754     PL_op = NULL;
11755     PL_curcop = NULL;
11756     PL_markstack = 0;
11757     PL_scopestack = 0;
11758     PL_savestack = 0;
11759     PL_savestack_ix = 0;
11760     PL_savestack_max = -1;
11761     PL_sig_pending = 0;
11762     PL_parser = NULL;
11763     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11764 #    else       /* !DEBUGGING */
11765     Zero(my_perl, 1, PerlInterpreter);
11766 #    endif      /* DEBUGGING */
11767 #endif          /* PERL_IMPLICIT_SYS */
11768     param->flags = flags;
11769     param->proto_perl = proto_perl;
11770
11771     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11772
11773     PL_body_arenas = NULL;
11774     Zero(&PL_body_roots, 1, PL_body_roots);
11775
11776     PL_nice_chunk       = NULL;
11777     PL_nice_chunk_size  = 0;
11778     PL_sv_count         = 0;
11779     PL_sv_objcount      = 0;
11780     PL_sv_root          = NULL;
11781     PL_sv_arenaroot     = NULL;
11782
11783     PL_debug            = proto_perl->Idebug;
11784
11785     PL_hash_seed        = proto_perl->Ihash_seed;
11786     PL_rehash_seed      = proto_perl->Irehash_seed;
11787
11788 #ifdef USE_REENTRANT_API
11789     /* XXX: things like -Dm will segfault here in perlio, but doing
11790      *  PERL_SET_CONTEXT(proto_perl);
11791      * breaks too many other things
11792      */
11793     Perl_reentrant_init(aTHX);
11794 #endif
11795
11796     /* create SV map for pointer relocation */
11797     PL_ptr_table = ptr_table_new();
11798
11799     /* initialize these special pointers as early as possible */
11800     SvANY(&PL_sv_undef)         = NULL;
11801     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
11802     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
11803     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11804
11805     SvANY(&PL_sv_no)            = new_XPVNV();
11806     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
11807     SvFLAGS(&PL_sv_no)          = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11808                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11809     SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
11810     SvCUR_set(&PL_sv_no, 0);
11811     SvLEN_set(&PL_sv_no, 1);
11812     SvIV_set(&PL_sv_no, 0);
11813     SvNV_set(&PL_sv_no, 0);
11814     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11815
11816     SvANY(&PL_sv_yes)           = new_XPVNV();
11817     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
11818     SvFLAGS(&PL_sv_yes)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11819                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11820     SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
11821     SvCUR_set(&PL_sv_yes, 1);
11822     SvLEN_set(&PL_sv_yes, 2);
11823     SvIV_set(&PL_sv_yes, 1);
11824     SvNV_set(&PL_sv_yes, 1);
11825     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11826
11827     /* create (a non-shared!) shared string table */
11828     PL_strtab           = newHV();
11829     HvSHAREKEYS_off(PL_strtab);
11830     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11831     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11832
11833     PL_compiling = proto_perl->Icompiling;
11834
11835     /* These two PVs will be free'd special way so must set them same way op.c does */
11836     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11837     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11838
11839     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
11840     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11841
11842     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11843     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
11844     if (PL_compiling.cop_hints_hash) {
11845         HINTS_REFCNT_LOCK;
11846         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
11847         HINTS_REFCNT_UNLOCK;
11848     }
11849     PL_curcop           = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
11850 #ifdef PERL_DEBUG_READONLY_OPS
11851     PL_slabs = NULL;
11852     PL_slab_count = 0;
11853 #endif
11854
11855     /* pseudo environmental stuff */
11856     PL_origargc         = proto_perl->Iorigargc;
11857     PL_origargv         = proto_perl->Iorigargv;
11858
11859     param->stashes      = newAV();  /* Setup array of objects to call clone on */
11860
11861     /* Set tainting stuff before PerlIO_debug can possibly get called */
11862     PL_tainting         = proto_perl->Itainting;
11863     PL_taint_warn       = proto_perl->Itaint_warn;
11864
11865 #ifdef PERLIO_LAYERS
11866     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11867     PerlIO_clone(aTHX_ proto_perl, param);
11868 #endif
11869
11870     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
11871     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
11872     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
11873     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
11874     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
11875     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
11876
11877     /* switches */
11878     PL_minus_c          = proto_perl->Iminus_c;
11879     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
11880     PL_localpatches     = proto_perl->Ilocalpatches;
11881     PL_splitstr         = proto_perl->Isplitstr;
11882     PL_minus_n          = proto_perl->Iminus_n;
11883     PL_minus_p          = proto_perl->Iminus_p;
11884     PL_minus_l          = proto_perl->Iminus_l;
11885     PL_minus_a          = proto_perl->Iminus_a;
11886     PL_minus_E          = proto_perl->Iminus_E;
11887     PL_minus_F          = proto_perl->Iminus_F;
11888     PL_doswitches       = proto_perl->Idoswitches;
11889     PL_dowarn           = proto_perl->Idowarn;
11890     PL_doextract        = proto_perl->Idoextract;
11891     PL_sawampersand     = proto_perl->Isawampersand;
11892     PL_unsafe           = proto_perl->Iunsafe;
11893     PL_inplace          = SAVEPV(proto_perl->Iinplace);
11894     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
11895     PL_perldb           = proto_perl->Iperldb;
11896     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11897     PL_exit_flags       = proto_perl->Iexit_flags;
11898
11899     /* magical thingies */
11900     /* XXX time(&PL_basetime) when asked for? */
11901     PL_basetime         = proto_perl->Ibasetime;
11902     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
11903
11904     PL_maxsysfd         = proto_perl->Imaxsysfd;
11905     PL_statusvalue      = proto_perl->Istatusvalue;
11906 #ifdef VMS
11907     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
11908 #else
11909     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11910 #endif
11911     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
11912
11913     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
11914     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
11915     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
11916
11917
11918     /* RE engine related */
11919     Zero(&PL_reg_state, 1, struct re_save_state);
11920     PL_reginterp_cnt    = 0;
11921     PL_regmatch_slab    = NULL;
11922
11923     /* Clone the regex array */
11924     /* ORANGE FIXME for plugins, probably in the SV dup code.
11925        newSViv(PTR2IV(CALLREGDUPE(
11926        INT2PTR(REGEXP *, SvIVX(regex)), param))))
11927     */
11928     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
11929     PL_regex_pad = AvARRAY(PL_regex_padav);
11930
11931     /* shortcuts to various I/O objects */
11932     PL_ofsgv            = gv_dup(proto_perl->Iofsgv, param);
11933     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
11934     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
11935     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
11936     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
11937     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
11938     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
11939
11940     /* shortcuts to regexp stuff */
11941     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
11942
11943     /* shortcuts to misc objects */
11944     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
11945
11946     /* shortcuts to debugging objects */
11947     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
11948     PL_DBline           = gv_dup(proto_perl->IDBline, param);
11949     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
11950     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
11951     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
11952     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
11953     PL_dbargs           = av_dup(proto_perl->Idbargs, param);
11954
11955     /* symbol tables */
11956     PL_defstash         = hv_dup_inc(proto_perl->Idefstash, param);
11957     PL_curstash         = hv_dup(proto_perl->Icurstash, param);
11958     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
11959     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
11960     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
11961
11962     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
11963     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
11964     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
11965     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
11966     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
11967     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
11968     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
11969     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
11970
11971     PL_sub_generation   = proto_perl->Isub_generation;
11972     PL_isarev           = hv_dup_inc(proto_perl->Iisarev, param);
11973
11974     /* funky return mechanisms */
11975     PL_forkprocess      = proto_perl->Iforkprocess;
11976
11977     /* subprocess state */
11978     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
11979
11980     /* internal state */
11981     PL_maxo             = proto_perl->Imaxo;
11982     if (proto_perl->Iop_mask)
11983         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11984     else
11985         PL_op_mask      = NULL;
11986     /* PL_asserting        = proto_perl->Iasserting; */
11987
11988     /* current interpreter roots */
11989     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
11990     OP_REFCNT_LOCK;
11991     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
11992     OP_REFCNT_UNLOCK;
11993     PL_main_start       = proto_perl->Imain_start;
11994     PL_eval_root        = proto_perl->Ieval_root;
11995     PL_eval_start       = proto_perl->Ieval_start;
11996
11997     /* runtime control stuff */
11998     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11999
12000     PL_filemode         = proto_perl->Ifilemode;
12001     PL_lastfd           = proto_perl->Ilastfd;
12002     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
12003     PL_Argv             = NULL;
12004     PL_Cmd              = NULL;
12005     PL_gensym           = proto_perl->Igensym;
12006     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
12007     PL_laststatval      = proto_perl->Ilaststatval;
12008     PL_laststype        = proto_perl->Ilaststype;
12009     PL_mess_sv          = NULL;
12010
12011     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
12012
12013     /* interpreter atexit processing */
12014     PL_exitlistlen      = proto_perl->Iexitlistlen;
12015     if (PL_exitlistlen) {
12016         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12017         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12018     }
12019     else
12020         PL_exitlist     = (PerlExitListEntry*)NULL;
12021
12022     PL_my_cxt_size = proto_perl->Imy_cxt_size;
12023     if (PL_my_cxt_size) {
12024         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12025         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12026 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12027         Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12028         Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12029 #endif
12030     }
12031     else {
12032         PL_my_cxt_list  = (void**)NULL;
12033 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12034         PL_my_cxt_keys  = (const char**)NULL;
12035 #endif
12036     }
12037     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
12038     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
12039     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12040
12041     PL_profiledata      = NULL;
12042
12043     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
12044
12045     PAD_CLONE_VARS(proto_perl, param);
12046
12047 #ifdef HAVE_INTERP_INTERN
12048     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12049 #endif
12050
12051     /* more statics moved here */
12052     PL_generation       = proto_perl->Igeneration;
12053     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
12054
12055     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
12056     PL_in_clean_all     = proto_perl->Iin_clean_all;
12057
12058     PL_uid              = proto_perl->Iuid;
12059     PL_euid             = proto_perl->Ieuid;
12060     PL_gid              = proto_perl->Igid;
12061     PL_egid             = proto_perl->Iegid;
12062     PL_nomemok          = proto_perl->Inomemok;
12063     PL_an               = proto_perl->Ian;
12064     PL_evalseq          = proto_perl->Ievalseq;
12065     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
12066     PL_origalen         = proto_perl->Iorigalen;
12067 #ifdef PERL_USES_PL_PIDSTATUS
12068     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
12069 #endif
12070     PL_osname           = SAVEPV(proto_perl->Iosname);
12071     PL_sighandlerp      = proto_perl->Isighandlerp;
12072
12073     PL_runops           = proto_perl->Irunops;
12074
12075     PL_parser           = parser_dup(proto_perl->Iparser, param);
12076
12077     PL_subline          = proto_perl->Isubline;
12078     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
12079
12080 #ifdef FCRYPT
12081     PL_cryptseen        = proto_perl->Icryptseen;
12082 #endif
12083
12084     PL_hints            = proto_perl->Ihints;
12085
12086     PL_amagic_generation        = proto_perl->Iamagic_generation;
12087
12088 #ifdef USE_LOCALE_COLLATE
12089     PL_collation_ix     = proto_perl->Icollation_ix;
12090     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
12091     PL_collation_standard       = proto_perl->Icollation_standard;
12092     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
12093     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
12094 #endif /* USE_LOCALE_COLLATE */
12095
12096 #ifdef USE_LOCALE_NUMERIC
12097     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
12098     PL_numeric_standard = proto_perl->Inumeric_standard;
12099     PL_numeric_local    = proto_perl->Inumeric_local;
12100     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12101 #endif /* !USE_LOCALE_NUMERIC */
12102
12103     /* utf8 character classes */
12104     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12105     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12106     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12107     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12108     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
12109     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12110     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
12111     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
12112     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
12113     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
12114     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
12115     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
12116     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12117     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
12118     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12119     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12120     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12121     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12122     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12123     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12124
12125     /* Did the locale setup indicate UTF-8? */
12126     PL_utf8locale       = proto_perl->Iutf8locale;
12127     /* Unicode features (see perlrun/-C) */
12128     PL_unicode          = proto_perl->Iunicode;
12129
12130     /* Pre-5.8 signals control */
12131     PL_signals          = proto_perl->Isignals;
12132
12133     /* times() ticks per second */
12134     PL_clocktick        = proto_perl->Iclocktick;
12135
12136     /* Recursion stopper for PerlIO_find_layer */
12137     PL_in_load_module   = proto_perl->Iin_load_module;
12138
12139     /* sort() routine */
12140     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
12141
12142     /* Not really needed/useful since the reenrant_retint is "volatile",
12143      * but do it for consistency's sake. */
12144     PL_reentrant_retint = proto_perl->Ireentrant_retint;
12145
12146     /* Hooks to shared SVs and locks. */
12147     PL_sharehook        = proto_perl->Isharehook;
12148     PL_lockhook         = proto_perl->Ilockhook;
12149     PL_unlockhook       = proto_perl->Iunlockhook;
12150     PL_threadhook       = proto_perl->Ithreadhook;
12151     PL_destroyhook      = proto_perl->Idestroyhook;
12152
12153 #ifdef THREADS_HAVE_PIDS
12154     PL_ppid             = proto_perl->Ippid;
12155 #endif
12156
12157     /* swatch cache */
12158     PL_last_swash_hv    = NULL; /* reinits on demand */
12159     PL_last_swash_klen  = 0;
12160     PL_last_swash_key[0]= '\0';
12161     PL_last_swash_tmps  = (U8*)NULL;
12162     PL_last_swash_slen  = 0;
12163
12164     PL_glob_index       = proto_perl->Iglob_index;
12165     PL_srand_called     = proto_perl->Isrand_called;
12166     PL_bitcount         = NULL; /* reinits on demand */
12167
12168     if (proto_perl->Ipsig_pend) {
12169         Newxz(PL_psig_pend, SIG_SIZE, int);
12170     }
12171     else {
12172         PL_psig_pend    = (int*)NULL;
12173     }
12174
12175     if (proto_perl->Ipsig_ptr) {
12176         Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
12177         Newxz(PL_psig_name, SIG_SIZE, SV*);
12178         for (i = 1; i < SIG_SIZE; i++) {
12179             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12180             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12181         }
12182     }
12183     else {
12184         PL_psig_ptr     = (SV**)NULL;
12185         PL_psig_name    = (SV**)NULL;
12186     }
12187
12188     /* intrpvar.h stuff */
12189
12190     if (flags & CLONEf_COPY_STACKS) {
12191         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12192         PL_tmps_ix              = proto_perl->Itmps_ix;
12193         PL_tmps_max             = proto_perl->Itmps_max;
12194         PL_tmps_floor           = proto_perl->Itmps_floor;
12195         Newxz(PL_tmps_stack, PL_tmps_max, SV*);
12196         i = 0;
12197         while (i <= PL_tmps_ix) {
12198             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Itmps_stack[i], param);
12199             ++i;
12200         }
12201
12202         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12203         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12204         Newxz(PL_markstack, i, I32);
12205         PL_markstack_max        = PL_markstack + (proto_perl->Imarkstack_max
12206                                                   - proto_perl->Imarkstack);
12207         PL_markstack_ptr        = PL_markstack + (proto_perl->Imarkstack_ptr
12208                                                   - proto_perl->Imarkstack);
12209         Copy(proto_perl->Imarkstack, PL_markstack,
12210              PL_markstack_ptr - PL_markstack + 1, I32);
12211
12212         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12213          * NOTE: unlike the others! */
12214         PL_scopestack_ix        = proto_perl->Iscopestack_ix;
12215         PL_scopestack_max       = proto_perl->Iscopestack_max;
12216         Newxz(PL_scopestack, PL_scopestack_max, I32);
12217         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12218
12219         /* NOTE: si_dup() looks at PL_markstack */
12220         PL_curstackinfo         = si_dup(proto_perl->Icurstackinfo, param);
12221
12222         /* PL_curstack          = PL_curstackinfo->si_stack; */
12223         PL_curstack             = av_dup(proto_perl->Icurstack, param);
12224         PL_mainstack            = av_dup(proto_perl->Imainstack, param);
12225
12226         /* next PUSHs() etc. set *(PL_stack_sp+1) */
12227         PL_stack_base           = AvARRAY(PL_curstack);
12228         PL_stack_sp             = PL_stack_base + (proto_perl->Istack_sp
12229                                                    - proto_perl->Istack_base);
12230         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
12231
12232         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12233          * NOTE: unlike the others! */
12234         PL_savestack_ix         = proto_perl->Isavestack_ix;
12235         PL_savestack_max        = proto_perl->Isavestack_max;
12236         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12237         PL_savestack            = ss_dup(proto_perl, param);
12238     }
12239     else {
12240         init_stacks();
12241         ENTER;                  /* perl_destruct() wants to LEAVE; */
12242
12243         /* although we're not duplicating the tmps stack, we should still
12244          * add entries for any SVs on the tmps stack that got cloned by a
12245          * non-refcount means (eg a temp in @_); otherwise they will be
12246          * orphaned
12247          */
12248         for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12249             SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
12250                     proto_perl->Itmps_stack[i]));
12251             if (nsv && !SvREFCNT(nsv)) {
12252                 EXTEND_MORTAL(1);
12253                 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
12254             }
12255         }
12256     }
12257
12258     PL_start_env        = proto_perl->Istart_env;       /* XXXXXX */
12259     PL_top_env          = &PL_start_env;
12260
12261     PL_op               = proto_perl->Iop;
12262
12263     PL_Sv               = NULL;
12264     PL_Xpv              = (XPV*)NULL;
12265     my_perl->Ina        = proto_perl->Ina;
12266
12267     PL_statbuf          = proto_perl->Istatbuf;
12268     PL_statcache        = proto_perl->Istatcache;
12269     PL_statgv           = gv_dup(proto_perl->Istatgv, param);
12270     PL_statname         = sv_dup_inc(proto_perl->Istatname, param);
12271 #ifdef HAS_TIMES
12272     PL_timesbuf         = proto_perl->Itimesbuf;
12273 #endif
12274
12275     PL_tainted          = proto_perl->Itainted;
12276     PL_curpm            = proto_perl->Icurpm;   /* XXX No PMOP ref count */
12277     PL_rs               = sv_dup_inc(proto_perl->Irs, param);
12278     PL_last_in_gv       = gv_dup(proto_perl->Ilast_in_gv, param);
12279     PL_defoutgv         = gv_dup_inc(proto_perl->Idefoutgv, param);
12280     PL_chopset          = proto_perl->Ichopset; /* XXX never deallocated */
12281     PL_toptarget        = sv_dup_inc(proto_perl->Itoptarget, param);
12282     PL_bodytarget       = sv_dup_inc(proto_perl->Ibodytarget, param);
12283     PL_formtarget       = sv_dup(proto_perl->Iformtarget, param);
12284
12285     PL_restartop        = proto_perl->Irestartop;
12286     PL_in_eval          = proto_perl->Iin_eval;
12287     PL_delaymagic       = proto_perl->Idelaymagic;
12288     PL_dirty            = proto_perl->Idirty;
12289     PL_localizing       = proto_perl->Ilocalizing;
12290
12291     PL_errors           = sv_dup_inc(proto_perl->Ierrors, param);
12292     PL_hv_fetch_ent_mh  = NULL;
12293     PL_modcount         = proto_perl->Imodcount;
12294     PL_lastgotoprobe    = NULL;
12295     PL_dumpindent       = proto_perl->Idumpindent;
12296
12297     PL_sortcop          = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12298     PL_sortstash        = hv_dup(proto_perl->Isortstash, param);
12299     PL_firstgv          = gv_dup(proto_perl->Ifirstgv, param);
12300     PL_secondgv         = gv_dup(proto_perl->Isecondgv, param);
12301     PL_efloatbuf        = NULL;         /* reinits on demand */
12302     PL_efloatsize       = 0;                    /* reinits on demand */
12303
12304     /* regex stuff */
12305
12306     PL_screamfirst      = NULL;
12307     PL_screamnext       = NULL;
12308     PL_maxscream        = -1;                   /* reinits on demand */
12309     PL_lastscream       = NULL;
12310
12311
12312     PL_regdummy         = proto_perl->Iregdummy;
12313     PL_colorset         = 0;            /* reinits PL_colors[] */
12314     /*PL_colors[6]      = {0,0,0,0,0,0};*/
12315
12316
12317
12318     /* Pluggable optimizer */
12319     PL_peepp            = proto_perl->Ipeepp;
12320
12321     PL_stashcache       = newHV();
12322
12323     PL_watchaddr        = (char **) ptr_table_fetch(PL_ptr_table,
12324                                             proto_perl->Iwatchaddr);
12325     PL_watchok          = PL_watchaddr ? * PL_watchaddr : NULL;
12326     if (PL_debug && PL_watchaddr) {
12327         PerlIO_printf(Perl_debug_log,
12328           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12329           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12330           PTR2UV(PL_watchok));
12331     }
12332
12333     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
12334
12335     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12336         ptr_table_free(PL_ptr_table);
12337         PL_ptr_table = NULL;
12338     }
12339
12340     /* Call the ->CLONE method, if it exists, for each of the stashes
12341        identified by sv_dup() above.
12342     */
12343     while(av_len(param->stashes) != -1) {
12344         HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12345         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12346         if (cloner && GvCV(cloner)) {
12347             dSP;
12348             ENTER;
12349             SAVETMPS;
12350             PUSHMARK(SP);
12351             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12352             PUTBACK;
12353             call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
12354             FREETMPS;
12355             LEAVE;
12356         }
12357     }
12358
12359     SvREFCNT_dec(param->stashes);
12360
12361     /* orphaned? eg threads->new inside BEGIN or use */
12362     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12363         SvREFCNT_inc_simple_void(PL_compcv);
12364         SAVEFREESV(PL_compcv);
12365     }
12366
12367     return my_perl;
12368 }
12369
12370 #endif /* USE_ITHREADS */
12371
12372 /*
12373 =head1 Unicode Support
12374
12375 =for apidoc sv_recode_to_utf8
12376
12377 The encoding is assumed to be an Encode object, on entry the PV
12378 of the sv is assumed to be octets in that encoding, and the sv
12379 will be converted into Unicode (and UTF-8).
12380
12381 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12382 is not a reference, nothing is done to the sv.  If the encoding is not
12383 an C<Encode::XS> Encoding object, bad things will happen.
12384 (See F<lib/encoding.pm> and L<Encode>).
12385
12386 The PV of the sv is returned.
12387
12388 =cut */
12389
12390 char *
12391 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12392 {
12393     dVAR;
12394
12395     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12396
12397     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12398         SV *uni;
12399         STRLEN len;
12400         const char *s;
12401         dSP;
12402         ENTER;
12403         SAVETMPS;
12404         save_re_context();
12405         PUSHMARK(sp);
12406         EXTEND(SP, 3);
12407         XPUSHs(encoding);
12408         XPUSHs(sv);
12409 /*
12410   NI-S 2002/07/09
12411   Passing sv_yes is wrong - it needs to be or'ed set of constants
12412   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12413   remove converted chars from source.
12414
12415   Both will default the value - let them.
12416
12417         XPUSHs(&PL_sv_yes);
12418 */
12419         PUTBACK;
12420         call_method("decode", G_SCALAR);
12421         SPAGAIN;
12422         uni = POPs;
12423         PUTBACK;
12424         s = SvPV_const(uni, len);
12425         if (s != SvPVX_const(sv)) {
12426             SvGROW(sv, len + 1);
12427             Move(s, SvPVX(sv), len + 1, char);
12428             SvCUR_set(sv, len);
12429         }
12430         FREETMPS;
12431         LEAVE;
12432         SvUTF8_on(sv);
12433         return SvPVX(sv);
12434     }
12435     return SvPOKp(sv) ? SvPVX(sv) : NULL;
12436 }
12437
12438 /*
12439 =for apidoc sv_cat_decode
12440
12441 The encoding is assumed to be an Encode object, the PV of the ssv is
12442 assumed to be octets in that encoding and decoding the input starts
12443 from the position which (PV + *offset) pointed to.  The dsv will be
12444 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
12445 when the string tstr appears in decoding output or the input ends on
12446 the PV of the ssv. The value which the offset points will be modified
12447 to the last input position on the ssv.
12448
12449 Returns TRUE if the terminator was found, else returns FALSE.
12450
12451 =cut */
12452
12453 bool
12454 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12455                    SV *ssv, int *offset, char *tstr, int tlen)
12456 {
12457     dVAR;
12458     bool ret = FALSE;
12459
12460     PERL_ARGS_ASSERT_SV_CAT_DECODE;
12461
12462     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12463         SV *offsv;
12464         dSP;
12465         ENTER;
12466         SAVETMPS;
12467         save_re_context();
12468         PUSHMARK(sp);
12469         EXTEND(SP, 6);
12470         XPUSHs(encoding);
12471         XPUSHs(dsv);
12472         XPUSHs(ssv);
12473         offsv = newSViv(*offset);
12474         mXPUSHs(offsv);
12475         mXPUSHp(tstr, tlen);
12476         PUTBACK;
12477         call_method("cat_decode", G_SCALAR);
12478         SPAGAIN;
12479         ret = SvTRUE(TOPs);
12480         *offset = SvIV(offsv);
12481         PUTBACK;
12482         FREETMPS;
12483         LEAVE;
12484     }
12485     else
12486         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12487     return ret;
12488
12489 }
12490
12491 /* ---------------------------------------------------------------------
12492  *
12493  * support functions for report_uninit()
12494  */
12495
12496 /* the maxiumum size of array or hash where we will scan looking
12497  * for the undefined element that triggered the warning */
12498
12499 #define FUV_MAX_SEARCH_SIZE 1000
12500
12501 /* Look for an entry in the hash whose value has the same SV as val;
12502  * If so, return a mortal copy of the key. */
12503
12504 STATIC SV*
12505 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
12506 {
12507     dVAR;
12508     register HE **array;
12509     I32 i;
12510
12511     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12512
12513     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12514                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12515         return NULL;
12516
12517     array = HvARRAY(hv);
12518
12519     for (i=HvMAX(hv); i>0; i--) {
12520         register HE *entry;
12521         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12522             if (HeVAL(entry) != val)
12523                 continue;
12524             if (    HeVAL(entry) == &PL_sv_undef ||
12525                     HeVAL(entry) == &PL_sv_placeholder)
12526                 continue;
12527             if (!HeKEY(entry))
12528                 return NULL;
12529             if (HeKLEN(entry) == HEf_SVKEY)
12530                 return sv_mortalcopy(HeKEY_sv(entry));
12531             return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12532         }
12533     }
12534     return NULL;
12535 }
12536
12537 /* Look for an entry in the array whose value has the same SV as val;
12538  * If so, return the index, otherwise return -1. */
12539
12540 STATIC I32
12541 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
12542 {
12543     dVAR;
12544
12545     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12546
12547     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12548                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12549         return -1;
12550
12551     if (val != &PL_sv_undef) {
12552         SV ** const svp = AvARRAY(av);
12553         I32 i;
12554
12555         for (i=AvFILLp(av); i>=0; i--)
12556             if (svp[i] == val)
12557                 return i;
12558     }
12559     return -1;
12560 }
12561
12562 /* S_varname(): return the name of a variable, optionally with a subscript.
12563  * If gv is non-zero, use the name of that global, along with gvtype (one
12564  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12565  * targ.  Depending on the value of the subscript_type flag, return:
12566  */
12567
12568 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
12569 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
12570 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
12571 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
12572
12573 STATIC SV*
12574 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
12575         const SV *const keyname, I32 aindex, int subscript_type)
12576 {
12577
12578     SV * const name = sv_newmortal();
12579     if (gv) {
12580         char buffer[2];
12581         buffer[0] = gvtype;
12582         buffer[1] = 0;
12583
12584         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
12585
12586         gv_fullname4(name, gv, buffer, 0);
12587
12588         if ((unsigned int)SvPVX(name)[1] <= 26) {
12589             buffer[0] = '^';
12590             buffer[1] = SvPVX(name)[1] + 'A' - 1;
12591
12592             /* Swap the 1 unprintable control character for the 2 byte pretty
12593                version - ie substr($name, 1, 1) = $buffer; */
12594             sv_insert(name, 1, 1, buffer, 2);
12595         }
12596     }
12597     else {
12598         CV * const cv = find_runcv(NULL);
12599         SV *sv;
12600         AV *av;
12601
12602         if (!cv || !CvPADLIST(cv))
12603             return NULL;
12604         av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
12605         sv = *av_fetch(av, targ, FALSE);
12606         sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12607     }
12608
12609     if (subscript_type == FUV_SUBSCRIPT_HASH) {
12610         SV * const sv = newSV(0);
12611         *SvPVX(name) = '$';
12612         Perl_sv_catpvf(aTHX_ name, "{%s}",
12613             pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12614         SvREFCNT_dec(sv);
12615     }
12616     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12617         *SvPVX(name) = '$';
12618         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12619     }
12620     else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12621         /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12622         Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
12623     }
12624
12625     return name;
12626 }
12627
12628
12629 /*
12630 =for apidoc find_uninit_var
12631
12632 Find the name of the undefined variable (if any) that caused the operator o
12633 to issue a "Use of uninitialized value" warning.
12634 If match is true, only return a name if it's value matches uninit_sv.
12635 So roughly speaking, if a unary operator (such as OP_COS) generates a
12636 warning, then following the direct child of the op may yield an
12637 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12638 other hand, with OP_ADD there are two branches to follow, so we only print
12639 the variable name if we get an exact match.
12640
12641 The name is returned as a mortal SV.
12642
12643 Assumes that PL_op is the op that originally triggered the error, and that
12644 PL_comppad/PL_curpad points to the currently executing pad.
12645
12646 =cut
12647 */
12648
12649 STATIC SV *
12650 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
12651                   bool match)
12652 {
12653     dVAR;
12654     SV *sv;
12655     const GV *gv;
12656     const OP *o, *o2, *kid;
12657
12658     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12659                             uninit_sv == &PL_sv_placeholder)))
12660         return NULL;
12661
12662     switch (obase->op_type) {
12663
12664     case OP_RV2AV:
12665     case OP_RV2HV:
12666     case OP_PADAV:
12667     case OP_PADHV:
12668       {
12669         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12670         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12671         I32 index = 0;
12672         SV *keysv = NULL;
12673         int subscript_type = FUV_SUBSCRIPT_WITHIN;
12674
12675         if (pad) { /* @lex, %lex */
12676             sv = PAD_SVl(obase->op_targ);
12677             gv = NULL;
12678         }
12679         else {
12680             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12681             /* @global, %global */
12682                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12683                 if (!gv)
12684                     break;
12685                 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
12686             }
12687             else /* @{expr}, %{expr} */
12688                 return find_uninit_var(cUNOPx(obase)->op_first,
12689                                                     uninit_sv, match);
12690         }
12691
12692         /* attempt to find a match within the aggregate */
12693         if (hash) {
12694             keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12695             if (keysv)
12696                 subscript_type = FUV_SUBSCRIPT_HASH;
12697         }
12698         else {
12699             index = find_array_subscript((const AV *)sv, uninit_sv);
12700             if (index >= 0)
12701                 subscript_type = FUV_SUBSCRIPT_ARRAY;
12702         }
12703
12704         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12705             break;
12706
12707         return varname(gv, hash ? '%' : '@', obase->op_targ,
12708                                     keysv, index, subscript_type);
12709       }
12710
12711     case OP_PADSV:
12712         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12713             break;
12714         return varname(NULL, '$', obase->op_targ,
12715                                     NULL, 0, FUV_SUBSCRIPT_NONE);
12716
12717     case OP_GVSV:
12718         gv = cGVOPx_gv(obase);
12719         if (!gv || (match && GvSV(gv) != uninit_sv))
12720             break;
12721         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12722
12723     case OP_AELEMFAST:
12724         if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12725             if (match) {
12726                 SV **svp;
12727                 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
12728                 if (!av || SvRMAGICAL(av))
12729                     break;
12730                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12731                 if (!svp || *svp != uninit_sv)
12732                     break;
12733             }
12734             return varname(NULL, '$', obase->op_targ,
12735                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12736         }
12737         else {
12738             gv = cGVOPx_gv(obase);
12739             if (!gv)
12740                 break;
12741             if (match) {
12742                 SV **svp;
12743                 AV *const av = GvAV(gv);
12744                 if (!av || SvRMAGICAL(av))
12745                     break;
12746                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12747                 if (!svp || *svp != uninit_sv)
12748                     break;
12749             }
12750             return varname(gv, '$', 0,
12751                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12752         }
12753         break;
12754
12755     case OP_EXISTS:
12756         o = cUNOPx(obase)->op_first;
12757         if (!o || o->op_type != OP_NULL ||
12758                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12759             break;
12760         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12761
12762     case OP_AELEM:
12763     case OP_HELEM:
12764         if (PL_op == obase)
12765             /* $a[uninit_expr] or $h{uninit_expr} */
12766             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12767
12768         gv = NULL;
12769         o = cBINOPx(obase)->op_first;
12770         kid = cBINOPx(obase)->op_last;
12771
12772         /* get the av or hv, and optionally the gv */
12773         sv = NULL;
12774         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12775             sv = PAD_SV(o->op_targ);
12776         }
12777         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12778                 && cUNOPo->op_first->op_type == OP_GV)
12779         {
12780             gv = cGVOPx_gv(cUNOPo->op_first);
12781             if (!gv)
12782                 break;
12783             sv = o->op_type
12784                 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
12785         }
12786         if (!sv)
12787             break;
12788
12789         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
12790             /* index is constant */
12791             if (match) {
12792                 if (SvMAGICAL(sv))
12793                     break;
12794                 if (obase->op_type == OP_HELEM) {
12795                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
12796                     if (!he || HeVAL(he) != uninit_sv)
12797                         break;
12798                 }
12799                 else {
12800                     SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
12801                     if (!svp || *svp != uninit_sv)
12802                         break;
12803                 }
12804             }
12805             if (obase->op_type == OP_HELEM)
12806                 return varname(gv, '%', o->op_targ,
12807                             cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
12808             else
12809                 return varname(gv, '@', o->op_targ, NULL,
12810                             SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
12811         }
12812         else  {
12813             /* index is an expression;
12814              * attempt to find a match within the aggregate */
12815             if (obase->op_type == OP_HELEM) {
12816                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12817                 if (keysv)
12818                     return varname(gv, '%', o->op_targ,
12819                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
12820             }
12821             else {
12822                 const I32 index
12823                     = find_array_subscript((const AV *)sv, uninit_sv);
12824                 if (index >= 0)
12825                     return varname(gv, '@', o->op_targ,
12826                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
12827             }
12828             if (match)
12829                 break;
12830             return varname(gv,
12831                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
12832                 ? '@' : '%',
12833                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
12834         }
12835         break;
12836
12837     case OP_AASSIGN:
12838         /* only examine RHS */
12839         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
12840
12841     case OP_OPEN:
12842         o = cUNOPx(obase)->op_first;
12843         if (o->op_type == OP_PUSHMARK)
12844             o = o->op_sibling;
12845
12846         if (!o->op_sibling) {
12847             /* one-arg version of open is highly magical */
12848
12849             if (o->op_type == OP_GV) { /* open FOO; */
12850                 gv = cGVOPx_gv(o);
12851                 if (match && GvSV(gv) != uninit_sv)
12852                     break;
12853                 return varname(gv, '$', 0,
12854                             NULL, 0, FUV_SUBSCRIPT_NONE);
12855             }
12856             /* other possibilities not handled are:
12857              * open $x; or open my $x;  should return '${*$x}'
12858              * open expr;               should return '$'.expr ideally
12859              */
12860              break;
12861         }
12862         goto do_op;
12863
12864     /* ops where $_ may be an implicit arg */
12865     case OP_TRANS:
12866     case OP_SUBST:
12867     case OP_MATCH:
12868         if ( !(obase->op_flags & OPf_STACKED)) {
12869             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
12870                                  ? PAD_SVl(obase->op_targ)
12871                                  : DEFSV))
12872             {
12873                 sv = sv_newmortal();
12874                 sv_setpvs(sv, "$_");
12875                 return sv;
12876             }
12877         }
12878         goto do_op;
12879
12880     case OP_PRTF:
12881     case OP_PRINT:
12882     case OP_SAY:
12883         match = 1; /* print etc can return undef on defined args */
12884         /* skip filehandle as it can't produce 'undef' warning  */
12885         o = cUNOPx(obase)->op_first;
12886         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
12887             o = o->op_sibling->op_sibling;
12888         goto do_op2;
12889
12890
12891     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
12892     case OP_RV2SV:
12893     case OP_CUSTOM: /* XS or custom code could trigger random warnings */
12894
12895         /* the following ops are capable of returning PL_sv_undef even for
12896          * defined arg(s) */
12897
12898     case OP_BACKTICK:
12899     case OP_PIPE_OP:
12900     case OP_FILENO:
12901     case OP_BINMODE:
12902     case OP_TIED:
12903     case OP_GETC:
12904     case OP_SYSREAD:
12905     case OP_SEND:
12906     case OP_IOCTL:
12907     case OP_SOCKET:
12908     case OP_SOCKPAIR:
12909     case OP_BIND:
12910     case OP_CONNECT:
12911     case OP_LISTEN:
12912     case OP_ACCEPT:
12913     case OP_SHUTDOWN:
12914     case OP_SSOCKOPT:
12915     case OP_GETPEERNAME:
12916     case OP_FTRREAD:
12917     case OP_FTRWRITE:
12918     case OP_FTREXEC:
12919     case OP_FTROWNED:
12920     case OP_FTEREAD:
12921     case OP_FTEWRITE:
12922     case OP_FTEEXEC:
12923     case OP_FTEOWNED:
12924     case OP_FTIS:
12925     case OP_FTZERO:
12926     case OP_FTSIZE:
12927     case OP_FTFILE:
12928     case OP_FTDIR:
12929     case OP_FTLINK:
12930     case OP_FTPIPE:
12931     case OP_FTSOCK:
12932     case OP_FTBLK:
12933     case OP_FTCHR:
12934     case OP_FTTTY:
12935     case OP_FTSUID:
12936     case OP_FTSGID:
12937     case OP_FTSVTX:
12938     case OP_FTTEXT:
12939     case OP_FTBINARY:
12940     case OP_FTMTIME:
12941     case OP_FTATIME:
12942     case OP_FTCTIME:
12943     case OP_READLINK:
12944     case OP_OPEN_DIR:
12945     case OP_READDIR:
12946     case OP_TELLDIR:
12947     case OP_SEEKDIR:
12948     case OP_REWINDDIR:
12949     case OP_CLOSEDIR:
12950     case OP_GMTIME:
12951     case OP_ALARM:
12952     case OP_SEMGET:
12953     case OP_GETLOGIN:
12954     case OP_UNDEF:
12955     case OP_SUBSTR:
12956     case OP_AEACH:
12957     case OP_EACH:
12958     case OP_SORT:
12959     case OP_CALLER:
12960     case OP_DOFILE:
12961     case OP_PROTOTYPE:
12962     case OP_NCMP:
12963     case OP_SMARTMATCH:
12964     case OP_UNPACK:
12965     case OP_SYSOPEN:
12966     case OP_SYSSEEK:
12967         match = 1;
12968         goto do_op;
12969
12970     case OP_ENTERSUB:
12971     case OP_GOTO:
12972         /* XXX tmp hack: these two may call an XS sub, and currently
12973           XS subs don't have a SUB entry on the context stack, so CV and
12974           pad determination goes wrong, and BAD things happen. So, just
12975           don't try to determine the value under those circumstances.
12976           Need a better fix at dome point. DAPM 11/2007 */
12977         break;
12978
12979
12980     case OP_POS:
12981         /* def-ness of rval pos() is independent of the def-ness of its arg */
12982         if ( !(obase->op_flags & OPf_MOD))
12983             break;
12984
12985     case OP_SCHOMP:
12986     case OP_CHOMP:
12987         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
12988             return newSVpvs_flags("${$/}", SVs_TEMP);
12989         /*FALLTHROUGH*/
12990
12991     default:
12992     do_op:
12993         if (!(obase->op_flags & OPf_KIDS))
12994             break;
12995         o = cUNOPx(obase)->op_first;
12996
12997     do_op2:
12998         if (!o)
12999             break;
13000
13001         /* if all except one arg are constant, or have no side-effects,
13002          * or are optimized away, then it's unambiguous */
13003         o2 = NULL;
13004         for (kid=o; kid; kid = kid->op_sibling) {
13005             if (kid) {
13006                 const OPCODE type = kid->op_type;
13007                 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13008                   || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
13009                   || (type == OP_PUSHMARK)
13010                 )
13011                 continue;
13012             }
13013             if (o2) { /* more than one found */
13014                 o2 = NULL;
13015                 break;
13016             }
13017             o2 = kid;
13018         }
13019         if (o2)
13020             return find_uninit_var(o2, uninit_sv, match);
13021
13022         /* scan all args */
13023         while (o) {
13024             sv = find_uninit_var(o, uninit_sv, 1);
13025             if (sv)
13026                 return sv;
13027             o = o->op_sibling;
13028         }
13029         break;
13030     }
13031     return NULL;
13032 }
13033
13034
13035 /*
13036 =for apidoc report_uninit
13037
13038 Print appropriate "Use of uninitialized variable" warning
13039
13040 =cut
13041 */
13042
13043 void
13044 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13045 {
13046     dVAR;
13047     if (PL_op) {
13048         SV* varname = NULL;
13049         if (uninit_sv) {
13050             varname = find_uninit_var(PL_op, uninit_sv,0);
13051             if (varname)
13052                 sv_insert(varname, 0, 0, " ", 1);
13053         }
13054         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13055                 varname ? SvPV_nolen_const(varname) : "",
13056                 " in ", OP_DESC(PL_op));
13057     }
13058     else
13059         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13060                     "", "", "");
13061 }
13062
13063 /*
13064  * Local variables:
13065  * c-indentation-style: bsd
13066  * c-basic-offset: 4
13067  * indent-tabs-mode: t
13068  * End:
13069  *
13070  * ex: set ts=8 sts=4 sw=4 noet:
13071  */