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         goto common;
3696     default:
3697         location = &GvSV(dstr);
3698         import_flag = GVf_IMPORTED_SV;
3699     common:
3700         if (intro) {
3701             if (stype == SVt_PVCV) {
3702                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3703                 if (GvCVGEN(dstr)) {
3704                     SvREFCNT_dec(GvCV(dstr));
3705                     GvCV(dstr) = NULL;
3706                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3707                 }
3708             }
3709             SAVEGENERICSV(*location);
3710         }
3711         else
3712             dref = *location;
3713         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3714             CV* const cv = MUTABLE_CV(*location);
3715             if (cv) {
3716                 if (!GvCVGEN((const GV *)dstr) &&
3717                     (CvROOT(cv) || CvXSUB(cv)))
3718                     {
3719                         /* Redefining a sub - warning is mandatory if
3720                            it was a const and its value changed. */
3721                         if (CvCONST(cv) && CvCONST((const CV *)sref)
3722                             && cv_const_sv(cv)
3723                             == cv_const_sv((const CV *)sref)) {
3724                             NOOP;
3725                             /* They are 2 constant subroutines generated from
3726                                the same constant. This probably means that
3727                                they are really the "same" proxy subroutine
3728                                instantiated in 2 places. Most likely this is
3729                                when a constant is exported twice.  Don't warn.
3730                             */
3731                         }
3732                         else if (ckWARN(WARN_REDEFINE)
3733                                  || (CvCONST(cv)
3734                                      && (!CvCONST((const CV *)sref)
3735                                          || sv_cmp(cv_const_sv(cv),
3736                                                    cv_const_sv((const CV *)
3737                                                                sref))))) {
3738                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3739                                         (const char *)
3740                                         (CvCONST(cv)
3741                                          ? "Constant subroutine %s::%s redefined"
3742                                          : "Subroutine %s::%s redefined"),
3743                                         HvNAME_get(GvSTASH((const GV *)dstr)),
3744                                         GvENAME(MUTABLE_GV(dstr)));
3745                         }
3746                     }
3747                 if (!intro)
3748                     cv_ckproto_len(cv, (const GV *)dstr,
3749                                    SvPOK(sref) ? SvPVX_const(sref) : NULL,
3750                                    SvPOK(sref) ? SvCUR(sref) : 0);
3751             }
3752             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3753             GvASSUMECV_on(dstr);
3754             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3755         }
3756         *location = sref;
3757         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3758             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3759             GvFLAGS(dstr) |= import_flag;
3760         }
3761         break;
3762     }
3763     SvREFCNT_dec(dref);
3764     if (SvTAINTED(sstr))
3765         SvTAINT(dstr);
3766     return;
3767 }
3768
3769 void
3770 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3771 {
3772     dVAR;
3773     register U32 sflags;
3774     register int dtype;
3775     register svtype stype;
3776
3777     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3778
3779     if (sstr == dstr)
3780         return;
3781
3782     if (SvIS_FREED(dstr)) {
3783         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3784                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3785     }
3786     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3787     if (!sstr)
3788         sstr = &PL_sv_undef;
3789     if (SvIS_FREED(sstr)) {
3790         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3791                    (void*)sstr, (void*)dstr);
3792     }
3793     stype = SvTYPE(sstr);
3794     dtype = SvTYPE(dstr);
3795
3796     (void)SvAMAGIC_off(dstr);
3797     if ( SvVOK(dstr) )
3798     {
3799         /* need to nuke the magic */
3800         mg_free(dstr);
3801     }
3802
3803     /* There's a lot of redundancy below but we're going for speed here */
3804
3805     switch (stype) {
3806     case SVt_NULL:
3807       undef_sstr:
3808         if (dtype != SVt_PVGV) {
3809             (void)SvOK_off(dstr);
3810             return;
3811         }
3812         break;
3813     case SVt_IV:
3814         if (SvIOK(sstr)) {
3815             switch (dtype) {
3816             case SVt_NULL:
3817                 sv_upgrade(dstr, SVt_IV);
3818                 break;
3819             case SVt_NV:
3820             case SVt_PV:
3821                 sv_upgrade(dstr, SVt_PVIV);
3822                 break;
3823             case SVt_PVGV:
3824                 goto end_of_first_switch;
3825             }
3826             (void)SvIOK_only(dstr);
3827             SvIV_set(dstr,  SvIVX(sstr));
3828             if (SvIsUV(sstr))
3829                 SvIsUV_on(dstr);
3830             /* SvTAINTED can only be true if the SV has taint magic, which in
3831                turn means that the SV type is PVMG (or greater). This is the
3832                case statement for SVt_IV, so this cannot be true (whatever gcov
3833                may say).  */
3834             assert(!SvTAINTED(sstr));
3835             return;
3836         }
3837         if (!SvROK(sstr))
3838             goto undef_sstr;
3839         if (dtype < SVt_PV && dtype != SVt_IV)
3840             sv_upgrade(dstr, SVt_IV);
3841         break;
3842
3843     case SVt_NV:
3844         if (SvNOK(sstr)) {
3845             switch (dtype) {
3846             case SVt_NULL:
3847             case SVt_IV:
3848                 sv_upgrade(dstr, SVt_NV);
3849                 break;
3850             case SVt_PV:
3851             case SVt_PVIV:
3852                 sv_upgrade(dstr, SVt_PVNV);
3853                 break;
3854             case SVt_PVGV:
3855                 goto end_of_first_switch;
3856             }
3857             SvNV_set(dstr, SvNVX(sstr));
3858             (void)SvNOK_only(dstr);
3859             /* SvTAINTED can only be true if the SV has taint magic, which in
3860                turn means that the SV type is PVMG (or greater). This is the
3861                case statement for SVt_NV, so this cannot be true (whatever gcov
3862                may say).  */
3863             assert(!SvTAINTED(sstr));
3864             return;
3865         }
3866         goto undef_sstr;
3867
3868     case SVt_PVFM:
3869 #ifdef PERL_OLD_COPY_ON_WRITE
3870         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3871             if (dtype < SVt_PVIV)
3872                 sv_upgrade(dstr, SVt_PVIV);
3873             break;
3874         }
3875         /* Fall through */
3876 #endif
3877     case SVt_REGEXP:
3878     case SVt_PV:
3879         if (dtype < SVt_PV)
3880             sv_upgrade(dstr, SVt_PV);
3881         break;
3882     case SVt_PVIV:
3883         if (dtype < SVt_PVIV)
3884             sv_upgrade(dstr, SVt_PVIV);
3885         break;
3886     case SVt_PVNV:
3887         if (dtype < SVt_PVNV)
3888             sv_upgrade(dstr, SVt_PVNV);
3889         break;
3890     default:
3891         {
3892         const char * const type = sv_reftype(sstr,0);
3893         if (PL_op)
3894             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3895         else
3896             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3897         }
3898         break;
3899
3900         /* case SVt_BIND: */
3901     case SVt_PVLV:
3902     case SVt_PVGV:
3903         if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3904             glob_assign_glob(dstr, sstr, dtype);
3905             return;
3906         }
3907         /* SvVALID means that this PVGV is playing at being an FBM.  */
3908         /*FALLTHROUGH*/
3909
3910     case SVt_PVMG:
3911         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3912             mg_get(sstr);
3913             if (SvTYPE(sstr) != stype) {
3914                 stype = SvTYPE(sstr);
3915                 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3916                     glob_assign_glob(dstr, sstr, dtype);
3917                     return;
3918                 }
3919             }
3920         }
3921         if (stype == SVt_PVLV)
3922             SvUPGRADE(dstr, SVt_PVNV);
3923         else
3924             SvUPGRADE(dstr, (svtype)stype);
3925     }
3926  end_of_first_switch:
3927
3928     /* dstr may have been upgraded.  */
3929     dtype = SvTYPE(dstr);
3930     sflags = SvFLAGS(sstr);
3931
3932     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3933         /* Assigning to a subroutine sets the prototype.  */
3934         if (SvOK(sstr)) {
3935             STRLEN len;
3936             const char *const ptr = SvPV_const(sstr, len);
3937
3938             SvGROW(dstr, len + 1);
3939             Copy(ptr, SvPVX(dstr), len + 1, char);
3940             SvCUR_set(dstr, len);
3941             SvPOK_only(dstr);
3942             SvFLAGS(dstr) |= sflags & SVf_UTF8;
3943         } else {
3944             SvOK_off(dstr);
3945         }
3946     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3947         const char * const type = sv_reftype(dstr,0);
3948         if (PL_op)
3949             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3950         else
3951             Perl_croak(aTHX_ "Cannot copy to %s", type);
3952     } else if (sflags & SVf_ROK) {
3953         if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3954             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3955             sstr = SvRV(sstr);
3956             if (sstr == dstr) {
3957                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3958                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3959                 {
3960                     GvIMPORTED_on(dstr);
3961                 }
3962                 GvMULTI_on(dstr);
3963                 return;
3964             }
3965             glob_assign_glob(dstr, sstr, dtype);
3966             return;
3967         }
3968
3969         if (dtype >= SVt_PV) {
3970             if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3971                 glob_assign_ref(dstr, sstr);
3972                 return;
3973             }
3974             if (SvPVX_const(dstr)) {
3975                 SvPV_free(dstr);
3976                 SvLEN_set(dstr, 0);
3977                 SvCUR_set(dstr, 0);
3978             }
3979         }
3980         (void)SvOK_off(dstr);
3981         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3982         SvFLAGS(dstr) |= sflags & SVf_ROK;
3983         assert(!(sflags & SVp_NOK));
3984         assert(!(sflags & SVp_IOK));
3985         assert(!(sflags & SVf_NOK));
3986         assert(!(sflags & SVf_IOK));
3987     }
3988     else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3989         if (!(sflags & SVf_OK)) {
3990             if (ckWARN(WARN_MISC))
3991                 Perl_warner(aTHX_ packWARN(WARN_MISC),
3992                             "Undefined value assigned to typeglob");
3993         }
3994         else {
3995             GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3996             if (dstr != (const SV *)gv) {
3997                 if (GvGP(dstr))
3998                     gp_free(MUTABLE_GV(dstr));
3999                 GvGP(dstr) = gp_ref(GvGP(gv));
4000             }
4001         }
4002     }
4003     else if (sflags & SVp_POK) {
4004         bool isSwipe = 0;
4005
4006         /*
4007          * Check to see if we can just swipe the string.  If so, it's a
4008          * possible small lose on short strings, but a big win on long ones.
4009          * It might even be a win on short strings if SvPVX_const(dstr)
4010          * has to be allocated and SvPVX_const(sstr) has to be freed.
4011          * Likewise if we can set up COW rather than doing an actual copy, we
4012          * drop to the else clause, as the swipe code and the COW setup code
4013          * have much in common.
4014          */
4015
4016         /* Whichever path we take through the next code, we want this true,
4017            and doing it now facilitates the COW check.  */
4018         (void)SvPOK_only(dstr);
4019
4020         if (
4021             /* If we're already COW then this clause is not true, and if COW
4022                is allowed then we drop down to the else and make dest COW
4023                with us.  If caller hasn't said that we're allowed to COW
4024                shared hash keys then we don't do the COW setup, even if the
4025                source scalar is a shared hash key scalar.  */
4026             (((flags & SV_COW_SHARED_HASH_KEYS)
4027                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4028                : 1 /* If making a COW copy is forbidden then the behaviour we
4029                        desire is as if the source SV isn't actually already
4030                        COW, even if it is.  So we act as if the source flags
4031                        are not COW, rather than actually testing them.  */
4032               )
4033 #ifndef PERL_OLD_COPY_ON_WRITE
4034              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4035                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4036                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4037                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4038                 but in turn, it's somewhat dead code, never expected to go
4039                 live, but more kept as a placeholder on how to do it better
4040                 in a newer implementation.  */
4041              /* If we are COW and dstr is a suitable target then we drop down
4042                 into the else and make dest a COW of us.  */
4043              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4044 #endif
4045              )
4046             &&
4047             !(isSwipe =
4048                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4049                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4050                  (!(flags & SV_NOSTEAL)) &&
4051                                         /* and we're allowed to steal temps */
4052                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4053                  SvLEN(sstr)    &&        /* and really is a string */
4054                                 /* and won't be needed again, potentially */
4055               !(PL_op && PL_op->op_type == OP_AASSIGN))
4056 #ifdef PERL_OLD_COPY_ON_WRITE
4057             && ((flags & SV_COW_SHARED_HASH_KEYS)
4058                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4059                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4060                      && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4061                 : 1)
4062 #endif
4063             ) {
4064             /* Failed the swipe test, and it's not a shared hash key either.
4065                Have to copy the string.  */
4066             STRLEN len = SvCUR(sstr);
4067             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4068             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4069             SvCUR_set(dstr, len);
4070             *SvEND(dstr) = '\0';
4071         } else {
4072             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4073                be true in here.  */
4074             /* Either it's a shared hash key, or it's suitable for
4075                copy-on-write or we can swipe the string.  */
4076             if (DEBUG_C_TEST) {
4077                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4078                 sv_dump(sstr);
4079                 sv_dump(dstr);
4080             }
4081 #ifdef PERL_OLD_COPY_ON_WRITE
4082             if (!isSwipe) {
4083                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4084                     != (SVf_FAKE | SVf_READONLY)) {
4085                     SvREADONLY_on(sstr);
4086                     SvFAKE_on(sstr);
4087                     /* Make the source SV into a loop of 1.
4088                        (about to become 2) */
4089                     SV_COW_NEXT_SV_SET(sstr, sstr);
4090                 }
4091             }
4092 #endif
4093             /* Initial code is common.  */
4094             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4095                 SvPV_free(dstr);
4096             }
4097
4098             if (!isSwipe) {
4099                 /* making another shared SV.  */
4100                 STRLEN cur = SvCUR(sstr);
4101                 STRLEN len = SvLEN(sstr);
4102 #ifdef PERL_OLD_COPY_ON_WRITE
4103                 if (len) {
4104                     assert (SvTYPE(dstr) >= SVt_PVIV);
4105                     /* SvIsCOW_normal */
4106                     /* splice us in between source and next-after-source.  */
4107                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4108                     SV_COW_NEXT_SV_SET(sstr, dstr);
4109                     SvPV_set(dstr, SvPVX_mutable(sstr));
4110                 } else
4111 #endif
4112                 {
4113                     /* SvIsCOW_shared_hash */
4114                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4115                                           "Copy on write: Sharing hash\n"));
4116
4117                     assert (SvTYPE(dstr) >= SVt_PV);
4118                     SvPV_set(dstr,
4119                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4120                 }
4121                 SvLEN_set(dstr, len);
4122                 SvCUR_set(dstr, cur);
4123                 SvREADONLY_on(dstr);
4124                 SvFAKE_on(dstr);
4125             }
4126             else
4127                 {       /* Passes the swipe test.  */
4128                 SvPV_set(dstr, SvPVX_mutable(sstr));
4129                 SvLEN_set(dstr, SvLEN(sstr));
4130                 SvCUR_set(dstr, SvCUR(sstr));
4131
4132                 SvTEMP_off(dstr);
4133                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4134                 SvPV_set(sstr, NULL);
4135                 SvLEN_set(sstr, 0);
4136                 SvCUR_set(sstr, 0);
4137                 SvTEMP_off(sstr);
4138             }
4139         }
4140         if (sflags & SVp_NOK) {
4141             SvNV_set(dstr, SvNVX(sstr));
4142         }
4143         if (sflags & SVp_IOK) {
4144             SvIV_set(dstr, SvIVX(sstr));
4145             /* Must do this otherwise some other overloaded use of 0x80000000
4146                gets confused. I guess SVpbm_VALID */
4147             if (sflags & SVf_IVisUV)
4148                 SvIsUV_on(dstr);
4149         }
4150         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4151         {
4152             const MAGIC * const smg = SvVSTRING_mg(sstr);
4153             if (smg) {
4154                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4155                          smg->mg_ptr, smg->mg_len);
4156                 SvRMAGICAL_on(dstr);
4157             }
4158         }
4159     }
4160     else if (sflags & (SVp_IOK|SVp_NOK)) {
4161         (void)SvOK_off(dstr);
4162         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4163         if (sflags & SVp_IOK) {
4164             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4165             SvIV_set(dstr, SvIVX(sstr));
4166         }
4167         if (sflags & SVp_NOK) {
4168             SvNV_set(dstr, SvNVX(sstr));
4169         }
4170     }
4171     else {
4172         if (isGV_with_GP(sstr)) {
4173             /* This stringification rule for globs is spread in 3 places.
4174                This feels bad. FIXME.  */
4175             const U32 wasfake = sflags & SVf_FAKE;
4176
4177             /* FAKE globs can get coerced, so need to turn this off
4178                temporarily if it is on.  */
4179             SvFAKE_off(sstr);
4180             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4181             SvFLAGS(sstr) |= wasfake;
4182         }
4183         else
4184             (void)SvOK_off(dstr);
4185     }
4186     if (SvTAINTED(sstr))
4187         SvTAINT(dstr);
4188 }
4189
4190 /*
4191 =for apidoc sv_setsv_mg
4192
4193 Like C<sv_setsv>, but also handles 'set' magic.
4194
4195 =cut
4196 */
4197
4198 void
4199 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4200 {
4201     PERL_ARGS_ASSERT_SV_SETSV_MG;
4202
4203     sv_setsv(dstr,sstr);
4204     SvSETMAGIC(dstr);
4205 }
4206
4207 #ifdef PERL_OLD_COPY_ON_WRITE
4208 SV *
4209 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4210 {
4211     STRLEN cur = SvCUR(sstr);
4212     STRLEN len = SvLEN(sstr);
4213     register char *new_pv;
4214
4215     PERL_ARGS_ASSERT_SV_SETSV_COW;
4216
4217     if (DEBUG_C_TEST) {
4218         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4219                       (void*)sstr, (void*)dstr);
4220         sv_dump(sstr);
4221         if (dstr)
4222                     sv_dump(dstr);
4223     }
4224
4225     if (dstr) {
4226         if (SvTHINKFIRST(dstr))
4227             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4228         else if (SvPVX_const(dstr))
4229             Safefree(SvPVX_const(dstr));
4230     }
4231     else
4232         new_SV(dstr);
4233     SvUPGRADE(dstr, SVt_PVIV);
4234
4235     assert (SvPOK(sstr));
4236     assert (SvPOKp(sstr));
4237     assert (!SvIOK(sstr));
4238     assert (!SvIOKp(sstr));
4239     assert (!SvNOK(sstr));
4240     assert (!SvNOKp(sstr));
4241
4242     if (SvIsCOW(sstr)) {
4243
4244         if (SvLEN(sstr) == 0) {
4245             /* source is a COW shared hash key.  */
4246             DEBUG_C(PerlIO_printf(Perl_debug_log,
4247                                   "Fast copy on write: Sharing hash\n"));
4248             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4249             goto common_exit;
4250         }
4251         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4252     } else {
4253         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4254         SvUPGRADE(sstr, SVt_PVIV);
4255         SvREADONLY_on(sstr);
4256         SvFAKE_on(sstr);
4257         DEBUG_C(PerlIO_printf(Perl_debug_log,
4258                               "Fast copy on write: Converting sstr to COW\n"));
4259         SV_COW_NEXT_SV_SET(dstr, sstr);
4260     }
4261     SV_COW_NEXT_SV_SET(sstr, dstr);
4262     new_pv = SvPVX_mutable(sstr);
4263
4264   common_exit:
4265     SvPV_set(dstr, new_pv);
4266     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4267     if (SvUTF8(sstr))
4268         SvUTF8_on(dstr);
4269     SvLEN_set(dstr, len);
4270     SvCUR_set(dstr, cur);
4271     if (DEBUG_C_TEST) {
4272         sv_dump(dstr);
4273     }
4274     return dstr;
4275 }
4276 #endif
4277
4278 /*
4279 =for apidoc sv_setpvn
4280
4281 Copies a string into an SV.  The C<len> parameter indicates the number of
4282 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4283 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4284
4285 =cut
4286 */
4287
4288 void
4289 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4290 {
4291     dVAR;
4292     register char *dptr;
4293
4294     PERL_ARGS_ASSERT_SV_SETPVN;
4295
4296     SV_CHECK_THINKFIRST_COW_DROP(sv);
4297     if (!ptr) {
4298         (void)SvOK_off(sv);
4299         return;
4300     }
4301     else {
4302         /* len is STRLEN which is unsigned, need to copy to signed */
4303         const IV iv = len;
4304         if (iv < 0)
4305             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4306     }
4307     SvUPGRADE(sv, SVt_PV);
4308
4309     dptr = SvGROW(sv, len + 1);
4310     Move(ptr,dptr,len,char);
4311     dptr[len] = '\0';
4312     SvCUR_set(sv, len);
4313     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4314     SvTAINT(sv);
4315 }
4316
4317 /*
4318 =for apidoc sv_setpvn_mg
4319
4320 Like C<sv_setpvn>, but also handles 'set' magic.
4321
4322 =cut
4323 */
4324
4325 void
4326 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4327 {
4328     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4329
4330     sv_setpvn(sv,ptr,len);
4331     SvSETMAGIC(sv);
4332 }
4333
4334 /*
4335 =for apidoc sv_setpv
4336
4337 Copies a string into an SV.  The string must be null-terminated.  Does not
4338 handle 'set' magic.  See C<sv_setpv_mg>.
4339
4340 =cut
4341 */
4342
4343 void
4344 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4345 {
4346     dVAR;
4347     register STRLEN len;
4348
4349     PERL_ARGS_ASSERT_SV_SETPV;
4350
4351     SV_CHECK_THINKFIRST_COW_DROP(sv);
4352     if (!ptr) {
4353         (void)SvOK_off(sv);
4354         return;
4355     }
4356     len = strlen(ptr);
4357     SvUPGRADE(sv, SVt_PV);
4358
4359     SvGROW(sv, len + 1);
4360     Move(ptr,SvPVX(sv),len+1,char);
4361     SvCUR_set(sv, len);
4362     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4363     SvTAINT(sv);
4364 }
4365
4366 /*
4367 =for apidoc sv_setpv_mg
4368
4369 Like C<sv_setpv>, but also handles 'set' magic.
4370
4371 =cut
4372 */
4373
4374 void
4375 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4376 {
4377     PERL_ARGS_ASSERT_SV_SETPV_MG;
4378
4379     sv_setpv(sv,ptr);
4380     SvSETMAGIC(sv);
4381 }
4382
4383 /*
4384 =for apidoc sv_usepvn_flags
4385
4386 Tells an SV to use C<ptr> to find its string value.  Normally the
4387 string is stored inside the SV but sv_usepvn allows the SV to use an
4388 outside string.  The C<ptr> should point to memory that was allocated
4389 by C<malloc>.  The string length, C<len>, must be supplied.  By default
4390 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4391 so that pointer should not be freed or used by the programmer after
4392 giving it to sv_usepvn, and neither should any pointers from "behind"
4393 that pointer (e.g. ptr + 1) be used.
4394
4395 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4396 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4397 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4398 C<len>, and already meets the requirements for storing in C<SvPVX>)
4399
4400 =cut
4401 */
4402
4403 void
4404 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4405 {
4406     dVAR;
4407     STRLEN allocate;
4408
4409     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4410
4411     SV_CHECK_THINKFIRST_COW_DROP(sv);
4412     SvUPGRADE(sv, SVt_PV);
4413     if (!ptr) {
4414         (void)SvOK_off(sv);
4415         if (flags & SV_SMAGIC)
4416             SvSETMAGIC(sv);
4417         return;
4418     }
4419     if (SvPVX_const(sv))
4420         SvPV_free(sv);
4421
4422 #ifdef DEBUGGING
4423     if (flags & SV_HAS_TRAILING_NUL)
4424         assert(ptr[len] == '\0');
4425 #endif
4426
4427     allocate = (flags & SV_HAS_TRAILING_NUL)
4428         ? len + 1 :
4429 #ifdef Perl_safesysmalloc_size
4430         len + 1;
4431 #else
4432         PERL_STRLEN_ROUNDUP(len + 1);
4433 #endif
4434     if (flags & SV_HAS_TRAILING_NUL) {
4435         /* It's long enough - do nothing.
4436            Specfically Perl_newCONSTSUB is relying on this.  */
4437     } else {
4438 #ifdef DEBUGGING
4439         /* Force a move to shake out bugs in callers.  */
4440         char *new_ptr = (char*)safemalloc(allocate);
4441         Copy(ptr, new_ptr, len, char);
4442         PoisonFree(ptr,len,char);
4443         Safefree(ptr);
4444         ptr = new_ptr;
4445 #else
4446         ptr = (char*) saferealloc (ptr, allocate);
4447 #endif
4448     }
4449 #ifdef Perl_safesysmalloc_size
4450     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4451 #else
4452     SvLEN_set(sv, allocate);
4453 #endif
4454     SvCUR_set(sv, len);
4455     SvPV_set(sv, ptr);
4456     if (!(flags & SV_HAS_TRAILING_NUL)) {
4457         ptr[len] = '\0';
4458     }
4459     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4460     SvTAINT(sv);
4461     if (flags & SV_SMAGIC)
4462         SvSETMAGIC(sv);
4463 }
4464
4465 #ifdef PERL_OLD_COPY_ON_WRITE
4466 /* Need to do this *after* making the SV normal, as we need the buffer
4467    pointer to remain valid until after we've copied it.  If we let go too early,
4468    another thread could invalidate it by unsharing last of the same hash key
4469    (which it can do by means other than releasing copy-on-write Svs)
4470    or by changing the other copy-on-write SVs in the loop.  */
4471 STATIC void
4472 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4473 {
4474     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4475
4476     { /* this SV was SvIsCOW_normal(sv) */
4477          /* we need to find the SV pointing to us.  */
4478         SV *current = SV_COW_NEXT_SV(after);
4479
4480         if (current == sv) {
4481             /* The SV we point to points back to us (there were only two of us
4482                in the loop.)
4483                Hence other SV is no longer copy on write either.  */
4484             SvFAKE_off(after);
4485             SvREADONLY_off(after);
4486         } else {
4487             /* We need to follow the pointers around the loop.  */
4488             SV *next;
4489             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4490                 assert (next);
4491                 current = next;
4492                  /* don't loop forever if the structure is bust, and we have
4493                     a pointer into a closed loop.  */
4494                 assert (current != after);
4495                 assert (SvPVX_const(current) == pvx);
4496             }
4497             /* Make the SV before us point to the SV after us.  */
4498             SV_COW_NEXT_SV_SET(current, after);
4499         }
4500     }
4501 }
4502 #endif
4503 /*
4504 =for apidoc sv_force_normal_flags
4505
4506 Undo various types of fakery on an SV: if the PV is a shared string, make
4507 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4508 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4509 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4510 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4511 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4512 set to some other value.) In addition, the C<flags> parameter gets passed to
4513 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4514 with flags set to 0.
4515
4516 =cut
4517 */
4518
4519 void
4520 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4521 {
4522     dVAR;
4523
4524     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4525
4526 #ifdef PERL_OLD_COPY_ON_WRITE
4527     if (SvREADONLY(sv)) {
4528         if (SvFAKE(sv)) {
4529             const char * const pvx = SvPVX_const(sv);
4530             const STRLEN len = SvLEN(sv);
4531             const STRLEN cur = SvCUR(sv);
4532             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4533                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4534                we'll fail an assertion.  */
4535             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4536
4537             if (DEBUG_C_TEST) {
4538                 PerlIO_printf(Perl_debug_log,
4539                               "Copy on write: Force normal %ld\n",
4540                               (long) flags);
4541                 sv_dump(sv);
4542             }
4543             SvFAKE_off(sv);
4544             SvREADONLY_off(sv);
4545             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4546             SvPV_set(sv, NULL);
4547             SvLEN_set(sv, 0);
4548             if (flags & SV_COW_DROP_PV) {
4549                 /* OK, so we don't need to copy our buffer.  */
4550                 SvPOK_off(sv);
4551             } else {
4552                 SvGROW(sv, cur + 1);
4553                 Move(pvx,SvPVX(sv),cur,char);
4554                 SvCUR_set(sv, cur);
4555                 *SvEND(sv) = '\0';
4556             }
4557             if (len) {
4558                 sv_release_COW(sv, pvx, next);
4559             } else {
4560                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4561             }
4562             if (DEBUG_C_TEST) {
4563                 sv_dump(sv);
4564             }
4565         }
4566         else if (IN_PERL_RUNTIME)
4567             Perl_croak(aTHX_ "%s", PL_no_modify);
4568     }
4569 #else
4570     if (SvREADONLY(sv)) {
4571         if (SvFAKE(sv)) {
4572             const char * const pvx = SvPVX_const(sv);
4573             const STRLEN len = SvCUR(sv);
4574             SvFAKE_off(sv);
4575             SvREADONLY_off(sv);
4576             SvPV_set(sv, NULL);
4577             SvLEN_set(sv, 0);
4578             SvGROW(sv, len + 1);
4579             Move(pvx,SvPVX(sv),len,char);
4580             *SvEND(sv) = '\0';
4581             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4582         }
4583         else if (IN_PERL_RUNTIME)
4584             Perl_croak(aTHX_ "%s", PL_no_modify);
4585     }
4586 #endif
4587     if (SvROK(sv))
4588         sv_unref_flags(sv, flags);
4589     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4590         sv_unglob(sv);
4591 }
4592
4593 /*
4594 =for apidoc sv_chop
4595
4596 Efficient removal of characters from the beginning of the string buffer.
4597 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4598 the string buffer.  The C<ptr> becomes the first character of the adjusted
4599 string. Uses the "OOK hack".
4600 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4601 refer to the same chunk of data.
4602
4603 =cut
4604 */
4605
4606 void
4607 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4608 {
4609     STRLEN delta;
4610     STRLEN old_delta;
4611     U8 *p;
4612 #ifdef DEBUGGING
4613     const U8 *real_start;
4614 #endif
4615     STRLEN max_delta;
4616
4617     PERL_ARGS_ASSERT_SV_CHOP;
4618
4619     if (!ptr || !SvPOKp(sv))
4620         return;
4621     delta = ptr - SvPVX_const(sv);
4622     if (!delta) {
4623         /* Nothing to do.  */
4624         return;
4625     }
4626     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4627        nothing uses the value of ptr any more.  */
4628     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4629     if (ptr <= SvPVX_const(sv))
4630         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4631                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4632     SV_CHECK_THINKFIRST(sv);
4633     if (delta > max_delta)
4634         Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4635                    SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4636                    SvPVX_const(sv) + max_delta);
4637
4638     if (!SvOOK(sv)) {
4639         if (!SvLEN(sv)) { /* make copy of shared string */
4640             const char *pvx = SvPVX_const(sv);
4641             const STRLEN len = SvCUR(sv);
4642             SvGROW(sv, len + 1);
4643             Move(pvx,SvPVX(sv),len,char);
4644             *SvEND(sv) = '\0';
4645         }
4646         SvFLAGS(sv) |= SVf_OOK;
4647         old_delta = 0;
4648     } else {
4649         SvOOK_offset(sv, old_delta);
4650     }
4651     SvLEN_set(sv, SvLEN(sv) - delta);
4652     SvCUR_set(sv, SvCUR(sv) - delta);
4653     SvPV_set(sv, SvPVX(sv) + delta);
4654
4655     p = (U8 *)SvPVX_const(sv);
4656
4657     delta += old_delta;
4658
4659 #ifdef DEBUGGING
4660     real_start = p - delta;
4661 #endif
4662
4663     assert(delta);
4664     if (delta < 0x100) {
4665         *--p = (U8) delta;
4666     } else {
4667         *--p = 0;
4668         p -= sizeof(STRLEN);
4669         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4670     }
4671
4672 #ifdef DEBUGGING
4673     /* Fill the preceding buffer with sentinals to verify that no-one is
4674        using it.  */
4675     while (p > real_start) {
4676         --p;
4677         *p = (U8)PTR2UV(p);
4678     }
4679 #endif
4680 }
4681
4682 /*
4683 =for apidoc sv_catpvn
4684
4685 Concatenates the string onto the end of the string which is in the SV.  The
4686 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4687 status set, then the bytes appended should be valid UTF-8.
4688 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4689
4690 =for apidoc sv_catpvn_flags
4691
4692 Concatenates the string onto the end of the string which is in the SV.  The
4693 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4694 status set, then the bytes appended should be valid UTF-8.
4695 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4696 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4697 in terms of this function.
4698
4699 =cut
4700 */
4701
4702 void
4703 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4704 {
4705     dVAR;
4706     STRLEN dlen;
4707     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4708
4709     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4710
4711     SvGROW(dsv, dlen + slen + 1);
4712     if (sstr == dstr)
4713         sstr = SvPVX_const(dsv);
4714     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4715     SvCUR_set(dsv, SvCUR(dsv) + slen);
4716     *SvEND(dsv) = '\0';
4717     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4718     SvTAINT(dsv);
4719     if (flags & SV_SMAGIC)
4720         SvSETMAGIC(dsv);
4721 }
4722
4723 /*
4724 =for apidoc sv_catsv
4725
4726 Concatenates the string from SV C<ssv> onto the end of the string in
4727 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4728 not 'set' magic.  See C<sv_catsv_mg>.
4729
4730 =for apidoc sv_catsv_flags
4731
4732 Concatenates the string from SV C<ssv> onto the end of the string in
4733 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4734 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4735 and C<sv_catsv_nomg> are implemented in terms of this function.
4736
4737 =cut */
4738
4739 void
4740 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4741 {
4742     dVAR;
4743
4744     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4745
4746    if (ssv) {
4747         STRLEN slen;
4748         const char *spv = SvPV_const(ssv, slen);
4749         if (spv) {
4750             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4751                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4752                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4753                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4754                 dsv->sv_flags doesn't have that bit set.
4755                 Andy Dougherty  12 Oct 2001
4756             */
4757             const I32 sutf8 = DO_UTF8(ssv);
4758             I32 dutf8;
4759
4760             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4761                 mg_get(dsv);
4762             dutf8 = DO_UTF8(dsv);
4763
4764             if (dutf8 != sutf8) {
4765                 if (dutf8) {
4766                     /* Not modifying source SV, so taking a temporary copy. */
4767                     SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4768
4769                     sv_utf8_upgrade(csv);
4770                     spv = SvPV_const(csv, slen);
4771                 }
4772                 else
4773                     /* Leave enough space for the cat that's about to happen */
4774                     sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4775             }
4776             sv_catpvn_nomg(dsv, spv, slen);
4777         }
4778     }
4779     if (flags & SV_SMAGIC)
4780         SvSETMAGIC(dsv);
4781 }
4782
4783 /*
4784 =for apidoc sv_catpv
4785
4786 Concatenates the string onto the end of the string which is in the SV.
4787 If the SV has the UTF-8 status set, then the bytes appended should be
4788 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4789
4790 =cut */
4791
4792 void
4793 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4794 {
4795     dVAR;
4796     register STRLEN len;
4797     STRLEN tlen;
4798     char *junk;
4799
4800     PERL_ARGS_ASSERT_SV_CATPV;
4801
4802     if (!ptr)
4803         return;
4804     junk = SvPV_force(sv, tlen);
4805     len = strlen(ptr);
4806     SvGROW(sv, tlen + len + 1);
4807     if (ptr == junk)
4808         ptr = SvPVX_const(sv);
4809     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4810     SvCUR_set(sv, SvCUR(sv) + len);
4811     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4812     SvTAINT(sv);
4813 }
4814
4815 /*
4816 =for apidoc sv_catpv_mg
4817
4818 Like C<sv_catpv>, but also handles 'set' magic.
4819
4820 =cut
4821 */
4822
4823 void
4824 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4825 {
4826     PERL_ARGS_ASSERT_SV_CATPV_MG;
4827
4828     sv_catpv(sv,ptr);
4829     SvSETMAGIC(sv);
4830 }
4831
4832 /*
4833 =for apidoc newSV
4834
4835 Creates a new SV.  A non-zero C<len> parameter indicates the number of
4836 bytes of preallocated string space the SV should have.  An extra byte for a
4837 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
4838 space is allocated.)  The reference count for the new SV is set to 1.
4839
4840 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4841 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4842 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4843 L<perlhack/PERL_MEM_LOG>).  The older API is still there for use in XS
4844 modules supporting older perls.
4845
4846 =cut
4847 */
4848
4849 SV *
4850 Perl_newSV(pTHX_ const STRLEN len)
4851 {
4852     dVAR;
4853     register SV *sv;
4854
4855     new_SV(sv);
4856     if (len) {
4857         sv_upgrade(sv, SVt_PV);
4858         SvGROW(sv, len + 1);
4859     }
4860     return sv;
4861 }
4862 /*
4863 =for apidoc sv_magicext
4864
4865 Adds magic to an SV, upgrading it if necessary. Applies the
4866 supplied vtable and returns a pointer to the magic added.
4867
4868 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4869 In particular, you can add magic to SvREADONLY SVs, and add more than
4870 one instance of the same 'how'.
4871
4872 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4873 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4874 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4875 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4876
4877 (This is now used as a subroutine by C<sv_magic>.)
4878
4879 =cut
4880 */
4881 MAGIC *
4882 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4883                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4884 {
4885     dVAR;
4886     MAGIC* mg;
4887
4888     PERL_ARGS_ASSERT_SV_MAGICEXT;
4889
4890     SvUPGRADE(sv, SVt_PVMG);
4891     Newxz(mg, 1, MAGIC);
4892     mg->mg_moremagic = SvMAGIC(sv);
4893     SvMAGIC_set(sv, mg);
4894
4895     /* Sometimes a magic contains a reference loop, where the sv and
4896        object refer to each other.  To prevent a reference loop that
4897        would prevent such objects being freed, we look for such loops
4898        and if we find one we avoid incrementing the object refcount.
4899
4900        Note we cannot do this to avoid self-tie loops as intervening RV must
4901        have its REFCNT incremented to keep it in existence.
4902
4903     */
4904     if (!obj || obj == sv ||
4905         how == PERL_MAGIC_arylen ||
4906         how == PERL_MAGIC_symtab ||
4907         (SvTYPE(obj) == SVt_PVGV &&
4908             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4909              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4910              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4911     {
4912         mg->mg_obj = obj;
4913     }
4914     else {
4915         mg->mg_obj = SvREFCNT_inc_simple(obj);
4916         mg->mg_flags |= MGf_REFCOUNTED;
4917     }
4918
4919     /* Normal self-ties simply pass a null object, and instead of
4920        using mg_obj directly, use the SvTIED_obj macro to produce a
4921        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4922        with an RV obj pointing to the glob containing the PVIO.  In
4923        this case, to avoid a reference loop, we need to weaken the
4924        reference.
4925     */
4926
4927     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4928         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
4929     {
4930       sv_rvweaken(obj);
4931     }
4932
4933     mg->mg_type = how;
4934     mg->mg_len = namlen;
4935     if (name) {
4936         if (namlen > 0)
4937             mg->mg_ptr = savepvn(name, namlen);
4938         else if (namlen == HEf_SVKEY) {
4939             /* Yes, this is casting away const. This is only for the case of
4940                HEf_SVKEY. I think we need to document this abberation of the
4941                constness of the API, rather than making name non-const, as
4942                that change propagating outwards a long way.  */
4943             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
4944         } else
4945             mg->mg_ptr = (char *) name;
4946     }
4947     mg->mg_virtual = (MGVTBL *) vtable;
4948
4949     mg_magical(sv);
4950     if (SvGMAGICAL(sv))
4951         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4952     return mg;
4953 }
4954
4955 /*
4956 =for apidoc sv_magic
4957
4958 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4959 then adds a new magic item of type C<how> to the head of the magic list.
4960
4961 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4962 handling of the C<name> and C<namlen> arguments.
4963
4964 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4965 to add more than one instance of the same 'how'.
4966
4967 =cut
4968 */
4969
4970 void
4971 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
4972              const char *const name, const I32 namlen)
4973 {
4974     dVAR;
4975     const MGVTBL *vtable;
4976     MAGIC* mg;
4977
4978     PERL_ARGS_ASSERT_SV_MAGIC;
4979
4980 #ifdef PERL_OLD_COPY_ON_WRITE
4981     if (SvIsCOW(sv))
4982         sv_force_normal_flags(sv, 0);
4983 #endif
4984     if (SvREADONLY(sv)) {
4985         if (
4986             /* its okay to attach magic to shared strings; the subsequent
4987              * upgrade to PVMG will unshare the string */
4988             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4989
4990             && IN_PERL_RUNTIME
4991             && how != PERL_MAGIC_regex_global
4992             && how != PERL_MAGIC_bm
4993             && how != PERL_MAGIC_fm
4994             && how != PERL_MAGIC_sv
4995             && how != PERL_MAGIC_backref
4996            )
4997         {
4998             Perl_croak(aTHX_ "%s", PL_no_modify);
4999         }
5000     }
5001     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5002         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5003             /* sv_magic() refuses to add a magic of the same 'how' as an
5004                existing one
5005              */
5006             if (how == PERL_MAGIC_taint) {
5007                 mg->mg_len |= 1;
5008                 /* Any scalar which already had taint magic on which someone
5009                    (erroneously?) did SvIOK_on() or similar will now be
5010                    incorrectly sporting public "OK" flags.  */
5011                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5012             }
5013             return;
5014         }
5015     }
5016
5017     switch (how) {
5018     case PERL_MAGIC_sv:
5019         vtable = &PL_vtbl_sv;
5020         break;
5021     case PERL_MAGIC_overload:
5022         vtable = &PL_vtbl_amagic;
5023         break;
5024     case PERL_MAGIC_overload_elem:
5025         vtable = &PL_vtbl_amagicelem;
5026         break;
5027     case PERL_MAGIC_overload_table:
5028         vtable = &PL_vtbl_ovrld;
5029         break;
5030     case PERL_MAGIC_bm:
5031         vtable = &PL_vtbl_bm;
5032         break;
5033     case PERL_MAGIC_regdata:
5034         vtable = &PL_vtbl_regdata;
5035         break;
5036     case PERL_MAGIC_regdatum:
5037         vtable = &PL_vtbl_regdatum;
5038         break;
5039     case PERL_MAGIC_env:
5040         vtable = &PL_vtbl_env;
5041         break;
5042     case PERL_MAGIC_fm:
5043         vtable = &PL_vtbl_fm;
5044         break;
5045     case PERL_MAGIC_envelem:
5046         vtable = &PL_vtbl_envelem;
5047         break;
5048     case PERL_MAGIC_regex_global:
5049         vtable = &PL_vtbl_mglob;
5050         break;
5051     case PERL_MAGIC_isa:
5052         vtable = &PL_vtbl_isa;
5053         break;
5054     case PERL_MAGIC_isaelem:
5055         vtable = &PL_vtbl_isaelem;
5056         break;
5057     case PERL_MAGIC_nkeys:
5058         vtable = &PL_vtbl_nkeys;
5059         break;
5060     case PERL_MAGIC_dbfile:
5061         vtable = NULL;
5062         break;
5063     case PERL_MAGIC_dbline:
5064         vtable = &PL_vtbl_dbline;
5065         break;
5066 #ifdef USE_LOCALE_COLLATE
5067     case PERL_MAGIC_collxfrm:
5068         vtable = &PL_vtbl_collxfrm;
5069         break;
5070 #endif /* USE_LOCALE_COLLATE */
5071     case PERL_MAGIC_tied:
5072         vtable = &PL_vtbl_pack;
5073         break;
5074     case PERL_MAGIC_tiedelem:
5075     case PERL_MAGIC_tiedscalar:
5076         vtable = &PL_vtbl_packelem;
5077         break;
5078     case PERL_MAGIC_qr:
5079         vtable = &PL_vtbl_regexp;
5080         break;
5081     case PERL_MAGIC_hints:
5082         /* As this vtable is all NULL, we can reuse it.  */
5083     case PERL_MAGIC_sig:
5084         vtable = &PL_vtbl_sig;
5085         break;
5086     case PERL_MAGIC_sigelem:
5087         vtable = &PL_vtbl_sigelem;
5088         break;
5089     case PERL_MAGIC_taint:
5090         vtable = &PL_vtbl_taint;
5091         break;
5092     case PERL_MAGIC_uvar:
5093         vtable = &PL_vtbl_uvar;
5094         break;
5095     case PERL_MAGIC_vec:
5096         vtable = &PL_vtbl_vec;
5097         break;
5098     case PERL_MAGIC_arylen_p:
5099     case PERL_MAGIC_rhash:
5100     case PERL_MAGIC_symtab:
5101     case PERL_MAGIC_vstring:
5102         vtable = NULL;
5103         break;
5104     case PERL_MAGIC_utf8:
5105         vtable = &PL_vtbl_utf8;
5106         break;
5107     case PERL_MAGIC_substr:
5108         vtable = &PL_vtbl_substr;
5109         break;
5110     case PERL_MAGIC_defelem:
5111         vtable = &PL_vtbl_defelem;
5112         break;
5113     case PERL_MAGIC_arylen:
5114         vtable = &PL_vtbl_arylen;
5115         break;
5116     case PERL_MAGIC_pos:
5117         vtable = &PL_vtbl_pos;
5118         break;
5119     case PERL_MAGIC_backref:
5120         vtable = &PL_vtbl_backref;
5121         break;
5122     case PERL_MAGIC_hintselem:
5123         vtable = &PL_vtbl_hintselem;
5124         break;
5125     case PERL_MAGIC_ext:
5126         /* Reserved for use by extensions not perl internals.           */
5127         /* Useful for attaching extension internal data to perl vars.   */
5128         /* Note that multiple extensions may clash if magical scalars   */
5129         /* etc holding private data from one are passed to another.     */
5130         vtable = NULL;
5131         break;
5132     default:
5133         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5134     }
5135
5136     /* Rest of work is done else where */
5137     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5138
5139     switch (how) {
5140     case PERL_MAGIC_taint:
5141         mg->mg_len = 1;
5142         break;
5143     case PERL_MAGIC_ext:
5144     case PERL_MAGIC_dbfile:
5145         SvRMAGICAL_on(sv);
5146         break;
5147     }
5148 }
5149
5150 /*
5151 =for apidoc sv_unmagic
5152
5153 Removes all magic of type C<type> from an SV.
5154
5155 =cut
5156 */
5157
5158 int
5159 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5160 {
5161     MAGIC* mg;
5162     MAGIC** mgp;
5163
5164     PERL_ARGS_ASSERT_SV_UNMAGIC;
5165
5166     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5167         return 0;
5168     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5169     for (mg = *mgp; mg; mg = *mgp) {
5170         if (mg->mg_type == type) {
5171             const MGVTBL* const vtbl = mg->mg_virtual;
5172             *mgp = mg->mg_moremagic;
5173             if (vtbl && vtbl->svt_free)
5174                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5175             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5176                 if (mg->mg_len > 0)
5177                     Safefree(mg->mg_ptr);
5178                 else if (mg->mg_len == HEf_SVKEY)
5179                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5180                 else if (mg->mg_type == PERL_MAGIC_utf8)
5181                     Safefree(mg->mg_ptr);
5182             }
5183             if (mg->mg_flags & MGf_REFCOUNTED)
5184                 SvREFCNT_dec(mg->mg_obj);
5185             Safefree(mg);
5186         }
5187         else
5188             mgp = &mg->mg_moremagic;
5189     }
5190     if (!SvMAGIC(sv)) {
5191         SvMAGICAL_off(sv);
5192         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5193         SvMAGIC_set(sv, NULL);
5194     }
5195
5196     return 0;
5197 }
5198
5199 /*
5200 =for apidoc sv_rvweaken
5201
5202 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5203 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5204 push a back-reference to this RV onto the array of backreferences
5205 associated with that magic. If the RV is magical, set magic will be
5206 called after the RV is cleared.
5207
5208 =cut
5209 */
5210
5211 SV *
5212 Perl_sv_rvweaken(pTHX_ SV *const sv)
5213 {
5214     SV *tsv;
5215
5216     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5217
5218     if (!SvOK(sv))  /* let undefs pass */
5219         return sv;
5220     if (!SvROK(sv))
5221         Perl_croak(aTHX_ "Can't weaken a nonreference");
5222     else if (SvWEAKREF(sv)) {
5223         if (ckWARN(WARN_MISC))
5224             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5225         return sv;
5226     }
5227     tsv = SvRV(sv);
5228     Perl_sv_add_backref(aTHX_ tsv, sv);
5229     SvWEAKREF_on(sv);
5230     SvREFCNT_dec(tsv);
5231     return sv;
5232 }
5233
5234 /* Give tsv backref magic if it hasn't already got it, then push a
5235  * back-reference to sv onto the array associated with the backref magic.
5236  */
5237
5238 /* A discussion about the backreferences array and its refcount:
5239  *
5240  * The AV holding the backreferences is pointed to either as the mg_obj of
5241  * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5242  * structure, from the xhv_backreferences field. (A HV without hv_aux will
5243  * have the standard magic instead.) The array is created with a refcount
5244  * of 2. This means that if during global destruction the array gets
5245  * picked on first to have its refcount decremented by the random zapper,
5246  * it won't actually be freed, meaning it's still theere for when its
5247  * parent gets freed.
5248  * When the parent SV is freed, in the case of magic, the magic is freed,
5249  * Perl_magic_killbackrefs is called which decrements one refcount, then
5250  * mg_obj is freed which kills the second count.
5251  * In the vase of a HV being freed, one ref is removed by
5252  * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5253  * calls.
5254  */
5255
5256 void
5257 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5258 {
5259     dVAR;
5260     AV *av;
5261
5262     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5263
5264     if (SvTYPE(tsv) == SVt_PVHV) {
5265         AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5266
5267         av = *avp;
5268         if (!av) {
5269             /* There is no AV in the offical place - try a fixup.  */
5270             MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5271
5272             if (mg) {
5273                 /* Aha. They've got it stowed in magic.  Bring it back.  */
5274                 av = MUTABLE_AV(mg->mg_obj);
5275                 /* Stop mg_free decreasing the refernce count.  */
5276                 mg->mg_obj = NULL;
5277                 /* Stop mg_free even calling the destructor, given that
5278                    there's no AV to free up.  */
5279                 mg->mg_virtual = 0;
5280                 sv_unmagic(tsv, PERL_MAGIC_backref);
5281             } else {
5282                 av = newAV();
5283                 AvREAL_off(av);
5284                 SvREFCNT_inc_simple_void(av); /* see discussion above */
5285             }
5286             *avp = av;
5287         }
5288     } else {
5289         const MAGIC *const mg
5290             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5291         if (mg)
5292             av = MUTABLE_AV(mg->mg_obj);
5293         else {
5294             av = newAV();
5295             AvREAL_off(av);
5296             sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
5297             /* av now has a refcnt of 2; see discussion above */
5298         }
5299     }
5300     if (AvFILLp(av) >= AvMAX(av)) {
5301         av_extend(av, AvFILLp(av)+1);
5302     }
5303     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5304 }
5305
5306 /* delete a back-reference to ourselves from the backref magic associated
5307  * with the SV we point to.
5308  */
5309
5310 STATIC void
5311 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5312 {
5313     dVAR;
5314     AV *av = NULL;
5315     SV **svp;
5316     I32 i;
5317
5318     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5319
5320     if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5321         av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5322         /* We mustn't attempt to "fix up" the hash here by moving the
5323            backreference array back to the hv_aux structure, as that is stored
5324            in the main HvARRAY(), and hfreentries assumes that no-one
5325            reallocates HvARRAY() while it is running.  */
5326     }
5327     if (!av) {
5328         const MAGIC *const mg
5329             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5330         if (mg)
5331             av = MUTABLE_AV(mg->mg_obj);
5332     }
5333
5334     if (!av)
5335         Perl_croak(aTHX_ "panic: del_backref");
5336
5337     assert(!SvIS_FREED(av));
5338
5339     svp = AvARRAY(av);
5340     /* We shouldn't be in here more than once, but for paranoia reasons lets
5341        not assume this.  */
5342     for (i = AvFILLp(av); i >= 0; i--) {
5343         if (svp[i] == sv) {
5344             const SSize_t fill = AvFILLp(av);
5345             if (i != fill) {
5346                 /* We weren't the last entry.
5347                    An unordered list has this property that you can take the
5348                    last element off the end to fill the hole, and it's still
5349                    an unordered list :-)
5350                 */
5351                 svp[i] = svp[fill];
5352             }
5353             svp[fill] = NULL;
5354             AvFILLp(av) = fill - 1;
5355         }
5356     }
5357 }
5358
5359 int
5360 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5361 {
5362     SV **svp = AvARRAY(av);
5363
5364     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5365     PERL_UNUSED_ARG(sv);
5366
5367     assert(!svp || !SvIS_FREED(av));
5368     if (svp) {
5369         SV *const *const last = svp + AvFILLp(av);
5370
5371         while (svp <= last) {
5372             if (*svp) {
5373                 SV *const referrer = *svp;
5374                 if (SvWEAKREF(referrer)) {
5375                     /* XXX Should we check that it hasn't changed? */
5376                     SvRV_set(referrer, 0);
5377                     SvOK_off(referrer);
5378                     SvWEAKREF_off(referrer);
5379                     SvSETMAGIC(referrer);
5380                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5381                            SvTYPE(referrer) == SVt_PVLV) {
5382                     /* You lookin' at me?  */
5383                     assert(GvSTASH(referrer));
5384                     assert(GvSTASH(referrer) == (const HV *)sv);
5385                     GvSTASH(referrer) = 0;
5386                 } else {
5387                     Perl_croak(aTHX_
5388                                "panic: magic_killbackrefs (flags=%"UVxf")",
5389                                (UV)SvFLAGS(referrer));
5390                 }
5391
5392                 *svp = NULL;
5393             }
5394             svp++;
5395         }
5396     }
5397     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5398     return 0;
5399 }
5400
5401 /*
5402 =for apidoc sv_insert
5403
5404 Inserts a string at the specified offset/length within the SV. Similar to
5405 the Perl substr() function. Handles get magic.
5406
5407 =for apidoc sv_insert_flags
5408
5409 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5410
5411 =cut
5412 */
5413
5414 void
5415 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5416 {
5417     dVAR;
5418     register char *big;
5419     register char *mid;
5420     register char *midend;
5421     register char *bigend;
5422     register I32 i;
5423     STRLEN curlen;
5424
5425     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5426
5427     if (!bigstr)
5428         Perl_croak(aTHX_ "Can't modify non-existent substring");
5429     SvPV_force_flags(bigstr, curlen, flags);
5430     (void)SvPOK_only_UTF8(bigstr);
5431     if (offset + len > curlen) {
5432         SvGROW(bigstr, offset+len+1);
5433         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5434         SvCUR_set(bigstr, offset+len);
5435     }
5436
5437     SvTAINT(bigstr);
5438     i = littlelen - len;
5439     if (i > 0) {                        /* string might grow */
5440         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5441         mid = big + offset + len;
5442         midend = bigend = big + SvCUR(bigstr);
5443         bigend += i;
5444         *bigend = '\0';
5445         while (midend > mid)            /* shove everything down */
5446             *--bigend = *--midend;
5447         Move(little,big+offset,littlelen,char);
5448         SvCUR_set(bigstr, SvCUR(bigstr) + i);
5449         SvSETMAGIC(bigstr);
5450         return;
5451     }
5452     else if (i == 0) {
5453         Move(little,SvPVX(bigstr)+offset,len,char);
5454         SvSETMAGIC(bigstr);
5455         return;
5456     }
5457
5458     big = SvPVX(bigstr);
5459     mid = big + offset;
5460     midend = mid + len;
5461     bigend = big + SvCUR(bigstr);
5462
5463     if (midend > bigend)
5464         Perl_croak(aTHX_ "panic: sv_insert");
5465
5466     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5467         if (littlelen) {
5468             Move(little, mid, littlelen,char);
5469             mid += littlelen;
5470         }
5471         i = bigend - midend;
5472         if (i > 0) {
5473             Move(midend, mid, i,char);
5474             mid += i;
5475         }
5476         *mid = '\0';
5477         SvCUR_set(bigstr, mid - big);
5478     }
5479     else if ((i = mid - big)) { /* faster from front */
5480         midend -= littlelen;
5481         mid = midend;
5482         Move(big, midend - i, i, char);
5483         sv_chop(bigstr,midend-i);
5484         if (littlelen)
5485             Move(little, mid, littlelen,char);
5486     }
5487     else if (littlelen) {
5488         midend -= littlelen;
5489         sv_chop(bigstr,midend);
5490         Move(little,midend,littlelen,char);
5491     }
5492     else {
5493         sv_chop(bigstr,midend);
5494     }
5495     SvSETMAGIC(bigstr);
5496 }
5497
5498 /*
5499 =for apidoc sv_replace
5500
5501 Make the first argument a copy of the second, then delete the original.
5502 The target SV physically takes over ownership of the body of the source SV
5503 and inherits its flags; however, the target keeps any magic it owns,
5504 and any magic in the source is discarded.
5505 Note that this is a rather specialist SV copying operation; most of the
5506 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5507
5508 =cut
5509 */
5510
5511 void
5512 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5513 {
5514     dVAR;
5515     const U32 refcnt = SvREFCNT(sv);
5516
5517     PERL_ARGS_ASSERT_SV_REPLACE;
5518
5519     SV_CHECK_THINKFIRST_COW_DROP(sv);
5520     if (SvREFCNT(nsv) != 1) {
5521         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5522                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5523     }
5524     if (SvMAGICAL(sv)) {
5525         if (SvMAGICAL(nsv))
5526             mg_free(nsv);
5527         else
5528             sv_upgrade(nsv, SVt_PVMG);
5529         SvMAGIC_set(nsv, SvMAGIC(sv));
5530         SvFLAGS(nsv) |= SvMAGICAL(sv);
5531         SvMAGICAL_off(sv);
5532         SvMAGIC_set(sv, NULL);
5533     }
5534     SvREFCNT(sv) = 0;
5535     sv_clear(sv);
5536     assert(!SvREFCNT(sv));
5537 #ifdef DEBUG_LEAKING_SCALARS
5538     sv->sv_flags  = nsv->sv_flags;
5539     sv->sv_any    = nsv->sv_any;
5540     sv->sv_refcnt = nsv->sv_refcnt;
5541     sv->sv_u      = nsv->sv_u;
5542 #else
5543     StructCopy(nsv,sv,SV);
5544 #endif
5545     if(SvTYPE(sv) == SVt_IV) {
5546         SvANY(sv)
5547             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5548     }
5549
5550
5551 #ifdef PERL_OLD_COPY_ON_WRITE
5552     if (SvIsCOW_normal(nsv)) {
5553         /* We need to follow the pointers around the loop to make the
5554            previous SV point to sv, rather than nsv.  */
5555         SV *next;
5556         SV *current = nsv;
5557         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5558             assert(next);
5559             current = next;
5560             assert(SvPVX_const(current) == SvPVX_const(nsv));
5561         }
5562         /* Make the SV before us point to the SV after us.  */
5563         if (DEBUG_C_TEST) {
5564             PerlIO_printf(Perl_debug_log, "previous is\n");
5565             sv_dump(current);
5566             PerlIO_printf(Perl_debug_log,
5567                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5568                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5569         }
5570         SV_COW_NEXT_SV_SET(current, sv);
5571     }
5572 #endif
5573     SvREFCNT(sv) = refcnt;
5574     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5575     SvREFCNT(nsv) = 0;
5576     del_SV(nsv);
5577 }
5578
5579 /*
5580 =for apidoc sv_clear
5581
5582 Clear an SV: call any destructors, free up any memory used by the body,
5583 and free the body itself. The SV's head is I<not> freed, although
5584 its type is set to all 1's so that it won't inadvertently be assumed
5585 to be live during global destruction etc.
5586 This function should only be called when REFCNT is zero. Most of the time
5587 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5588 instead.
5589
5590 =cut
5591 */
5592
5593 void
5594 Perl_sv_clear(pTHX_ register SV *const sv)
5595 {
5596     dVAR;
5597     const U32 type = SvTYPE(sv);
5598     const struct body_details *const sv_type_details
5599         = bodies_by_type + type;
5600     HV *stash;
5601
5602     PERL_ARGS_ASSERT_SV_CLEAR;
5603     assert(SvREFCNT(sv) == 0);
5604     assert(SvTYPE(sv) != SVTYPEMASK);
5605
5606     if (type <= SVt_IV) {
5607         /* See the comment in sv.h about the collusion between this early
5608            return and the overloading of the NULL and IV slots in the size
5609            table.  */
5610         if (SvROK(sv)) {
5611             SV * const target = SvRV(sv);
5612             if (SvWEAKREF(sv))
5613                 sv_del_backref(target, sv);
5614             else
5615                 SvREFCNT_dec(target);
5616         }
5617         SvFLAGS(sv) &= SVf_BREAK;
5618         SvFLAGS(sv) |= SVTYPEMASK;
5619         return;
5620     }
5621
5622     if (SvOBJECT(sv)) {
5623         if (PL_defstash &&      /* Still have a symbol table? */
5624             SvDESTROYABLE(sv))
5625         {
5626             dSP;
5627             HV* stash;
5628             do {
5629                 CV* destructor;
5630                 stash = SvSTASH(sv);
5631                 destructor = StashHANDLER(stash,DESTROY);
5632                 if (destructor
5633                         /* A constant subroutine can have no side effects, so
5634                            don't bother calling it.  */
5635                         && !CvCONST(destructor)
5636                         /* Don't bother calling an empty destructor */
5637                         && (CvISXSUB(destructor)
5638                         || CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))
5639                 {
5640                     SV* const tmpref = newRV(sv);
5641                     SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
5642                     ENTER;
5643                     PUSHSTACKi(PERLSI_DESTROY);
5644                     EXTEND(SP, 2);
5645                     PUSHMARK(SP);
5646                     PUSHs(tmpref);
5647                     PUTBACK;
5648                     call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5649
5650
5651                     POPSTACK;
5652                     SPAGAIN;
5653                     LEAVE;
5654                     if(SvREFCNT(tmpref) < 2) {
5655                         /* tmpref is not kept alive! */
5656                         SvREFCNT(sv)--;
5657                         SvRV_set(tmpref, NULL);
5658                         SvROK_off(tmpref);
5659                     }
5660                     SvREFCNT_dec(tmpref);
5661                 }
5662             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5663
5664
5665             if (SvREFCNT(sv)) {
5666                 if (PL_in_clean_objs)
5667                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5668                           HvNAME_get(stash));
5669                 /* DESTROY gave object new lease on life */
5670                 return;
5671             }
5672         }
5673
5674         if (SvOBJECT(sv)) {
5675             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
5676             SvOBJECT_off(sv);   /* Curse the object. */
5677             if (type != SVt_PVIO)
5678                 --PL_sv_objcount;       /* XXX Might want something more general */
5679         }
5680     }
5681     if (type >= SVt_PVMG) {
5682         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5683             SvREFCNT_dec(SvOURSTASH(sv));
5684         } else if (SvMAGIC(sv))
5685             mg_free(sv);
5686         if (type == SVt_PVMG && SvPAD_TYPED(sv))
5687             SvREFCNT_dec(SvSTASH(sv));
5688     }
5689     switch (type) {
5690         /* case SVt_BIND: */
5691     case SVt_PVIO:
5692         if (IoIFP(sv) &&
5693             IoIFP(sv) != PerlIO_stdin() &&
5694             IoIFP(sv) != PerlIO_stdout() &&
5695             IoIFP(sv) != PerlIO_stderr())
5696         {
5697             io_close(MUTABLE_IO(sv), FALSE);
5698         }
5699         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5700             PerlDir_close(IoDIRP(sv));
5701         IoDIRP(sv) = (DIR*)NULL;
5702         Safefree(IoTOP_NAME(sv));
5703         Safefree(IoFMT_NAME(sv));
5704         Safefree(IoBOTTOM_NAME(sv));
5705         goto freescalar;
5706     case SVt_REGEXP:
5707         /* FIXME for plugins */
5708         pregfree2((REGEXP*) sv);
5709         goto freescalar;
5710     case SVt_PVCV:
5711     case SVt_PVFM:
5712         cv_undef(MUTABLE_CV(sv));
5713         goto freescalar;
5714     case SVt_PVHV:
5715         if (PL_last_swash_hv == (const HV *)sv) {
5716             PL_last_swash_hv = NULL;
5717         }
5718         Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5719         hv_undef(MUTABLE_HV(sv));
5720         break;
5721     case SVt_PVAV:
5722         if (PL_comppad == MUTABLE_AV(sv)) {
5723             PL_comppad = NULL;
5724             PL_curpad = NULL;
5725         }
5726         av_undef(MUTABLE_AV(sv));
5727         break;
5728     case SVt_PVLV:
5729         if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5730             SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5731             HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5732             PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5733         }
5734         else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
5735             SvREFCNT_dec(LvTARG(sv));
5736     case SVt_PVGV:
5737         if (isGV_with_GP(sv)) {
5738             if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5739                && HvNAME_get(stash))
5740                 mro_method_changed_in(stash);
5741             gp_free(MUTABLE_GV(sv));
5742             if (GvNAME_HEK(sv))
5743                 unshare_hek(GvNAME_HEK(sv));
5744             /* If we're in a stash, we don't own a reference to it. However it does
5745                have a back reference to us, which needs to be cleared.  */
5746             if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5747                     sv_del_backref(MUTABLE_SV(stash), sv);
5748         }
5749         /* FIXME. There are probably more unreferenced pointers to SVs in the
5750            interpreter struct that we should check and tidy in a similar
5751            fashion to this:  */
5752         if ((const GV *)sv == PL_last_in_gv)
5753             PL_last_in_gv = NULL;
5754     case SVt_PVMG:
5755     case SVt_PVNV:
5756     case SVt_PVIV:
5757     case SVt_PV:
5758       freescalar:
5759         /* Don't bother with SvOOK_off(sv); as we're only going to free it.  */
5760         if (SvOOK(sv)) {
5761             STRLEN offset;
5762             SvOOK_offset(sv, offset);
5763             SvPV_set(sv, SvPVX_mutable(sv) - offset);
5764             /* Don't even bother with turning off the OOK flag.  */
5765         }
5766         if (SvROK(sv)) {
5767             SV * const target = SvRV(sv);
5768             if (SvWEAKREF(sv))
5769                 sv_del_backref(target, sv);
5770             else
5771                 SvREFCNT_dec(target);
5772         }
5773 #ifdef PERL_OLD_COPY_ON_WRITE
5774         else if (SvPVX_const(sv)) {
5775             if (SvIsCOW(sv)) {
5776                 if (DEBUG_C_TEST) {
5777                     PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5778                     sv_dump(sv);
5779                 }
5780                 if (SvLEN(sv)) {
5781                     sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5782                 } else {
5783                     unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5784                 }
5785
5786                 SvFAKE_off(sv);
5787             } else if (SvLEN(sv)) {
5788                 Safefree(SvPVX_const(sv));
5789             }
5790         }
5791 #else
5792         else if (SvPVX_const(sv) && SvLEN(sv))
5793             Safefree(SvPVX_mutable(sv));
5794         else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5795             unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5796             SvFAKE_off(sv);
5797         }
5798 #endif
5799         break;
5800     case SVt_NV:
5801         break;
5802     }
5803
5804     SvFLAGS(sv) &= SVf_BREAK;
5805     SvFLAGS(sv) |= SVTYPEMASK;
5806
5807     if (sv_type_details->arena) {
5808         del_body(((char *)SvANY(sv) + sv_type_details->offset),
5809                  &PL_body_roots[type]);
5810     }
5811     else if (sv_type_details->body_size) {
5812         my_safefree(SvANY(sv));
5813     }
5814 }
5815
5816 /*
5817 =for apidoc sv_newref
5818
5819 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5820 instead.
5821
5822 =cut
5823 */
5824
5825 SV *
5826 Perl_sv_newref(pTHX_ SV *const sv)
5827 {
5828     PERL_UNUSED_CONTEXT;
5829     if (sv)
5830         (SvREFCNT(sv))++;
5831     return sv;
5832 }
5833
5834 /*
5835 =for apidoc sv_free
5836
5837 Decrement an SV's reference count, and if it drops to zero, call
5838 C<sv_clear> to invoke destructors and free up any memory used by
5839 the body; finally, deallocate the SV's head itself.
5840 Normally called via a wrapper macro C<SvREFCNT_dec>.
5841
5842 =cut
5843 */
5844
5845 void
5846 Perl_sv_free(pTHX_ SV *const sv)
5847 {
5848     dVAR;
5849     if (!sv)
5850         return;
5851     if (SvREFCNT(sv) == 0) {
5852         if (SvFLAGS(sv) & SVf_BREAK)
5853             /* this SV's refcnt has been artificially decremented to
5854              * trigger cleanup */
5855             return;
5856         if (PL_in_clean_all) /* All is fair */
5857             return;
5858         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5859             /* make sure SvREFCNT(sv)==0 happens very seldom */
5860             SvREFCNT(sv) = (~(U32)0)/2;
5861             return;
5862         }
5863         if (ckWARN_d(WARN_INTERNAL)) {
5864 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5865             Perl_dump_sv_child(aTHX_ sv);
5866 #else
5867   #ifdef DEBUG_LEAKING_SCALARS
5868             sv_dump(sv);
5869   #endif
5870 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5871             if (PL_warnhook == PERL_WARNHOOK_FATAL
5872                 || ckDEAD(packWARN(WARN_INTERNAL))) {
5873                 /* Don't let Perl_warner cause us to escape our fate:  */
5874                 abort();
5875             }
5876 #endif
5877             /* This may not return:  */
5878             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5879                         "Attempt to free unreferenced scalar: SV 0x%"UVxf
5880                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5881 #endif
5882         }
5883 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5884         abort();
5885 #endif
5886         return;
5887     }
5888     if (--(SvREFCNT(sv)) > 0)
5889         return;
5890     Perl_sv_free2(aTHX_ sv);
5891 }
5892
5893 void
5894 Perl_sv_free2(pTHX_ SV *const sv)
5895 {
5896     dVAR;
5897
5898     PERL_ARGS_ASSERT_SV_FREE2;
5899
5900 #ifdef DEBUGGING
5901     if (SvTEMP(sv)) {
5902         if (ckWARN_d(WARN_DEBUGGING))
5903             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5904                         "Attempt to free temp prematurely: SV 0x%"UVxf
5905                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5906         return;
5907     }
5908 #endif
5909     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5910         /* make sure SvREFCNT(sv)==0 happens very seldom */
5911         SvREFCNT(sv) = (~(U32)0)/2;
5912         return;
5913     }
5914     sv_clear(sv);
5915     if (! SvREFCNT(sv))
5916         del_SV(sv);
5917 }
5918
5919 /*
5920 =for apidoc sv_len
5921
5922 Returns the length of the string in the SV. Handles magic and type
5923 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5924
5925 =cut
5926 */
5927
5928 STRLEN
5929 Perl_sv_len(pTHX_ register SV *const sv)
5930 {
5931     STRLEN len;
5932
5933     if (!sv)
5934         return 0;
5935
5936     if (SvGMAGICAL(sv))
5937         len = mg_length(sv);
5938     else
5939         (void)SvPV_const(sv, len);
5940     return len;
5941 }
5942
5943 /*
5944 =for apidoc sv_len_utf8
5945
5946 Returns the number of characters in the string in an SV, counting wide
5947 UTF-8 bytes as a single character. Handles magic and type coercion.
5948
5949 =cut
5950 */
5951
5952 /*
5953  * The length is cached in PERL_MAGIC_utf8, in the mg_len field.  Also the
5954  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
5955  * (Note that the mg_len is not the length of the mg_ptr field.
5956  * This allows the cache to store the character length of the string without
5957  * needing to malloc() extra storage to attach to the mg_ptr.)
5958  *
5959  */
5960
5961 STRLEN
5962 Perl_sv_len_utf8(pTHX_ register SV *const sv)
5963 {
5964     if (!sv)
5965         return 0;
5966
5967     if (SvGMAGICAL(sv))
5968         return mg_length(sv);
5969     else
5970     {
5971         STRLEN len;
5972         const U8 *s = (U8*)SvPV_const(sv, len);
5973
5974         if (PL_utf8cache) {
5975             STRLEN ulen;
5976             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
5977
5978             if (mg && mg->mg_len != -1) {
5979                 ulen = mg->mg_len;
5980                 if (PL_utf8cache < 0) {
5981                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
5982                     if (real != ulen) {
5983                         /* Need to turn the assertions off otherwise we may
5984                            recurse infinitely while printing error messages.
5985                         */
5986                         SAVEI8(PL_utf8cache);
5987                         PL_utf8cache = 0;
5988                         Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
5989                                    " real %"UVuf" for %"SVf,
5990                                    (UV) ulen, (UV) real, SVfARG(sv));
5991                     }
5992                 }
5993             }
5994             else {
5995                 ulen = Perl_utf8_length(aTHX_ s, s + len);
5996                 if (!SvREADONLY(sv)) {
5997                     if (!mg) {
5998                         mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
5999                                          &PL_vtbl_utf8, 0, 0);
6000                     }
6001                     assert(mg);
6002                     mg->mg_len = ulen;
6003                 }
6004             }
6005             return ulen;
6006         }
6007         return Perl_utf8_length(aTHX_ s, s + len);
6008     }
6009 }
6010
6011 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6012    offset.  */
6013 static STRLEN
6014 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6015                       STRLEN uoffset)
6016 {
6017     const U8 *s = start;
6018
6019     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6020
6021     while (s < send && uoffset--)
6022         s += UTF8SKIP(s);
6023     if (s > send) {
6024         /* This is the existing behaviour. Possibly it should be a croak, as
6025            it's actually a bounds error  */
6026         s = send;
6027     }
6028     return s - start;
6029 }
6030
6031 /* Given the length of the string in both bytes and UTF-8 characters, decide
6032    whether to walk forwards or backwards to find the byte corresponding to
6033    the passed in UTF-8 offset.  */
6034 static STRLEN
6035 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6036                       const STRLEN uoffset, const STRLEN uend)
6037 {
6038     STRLEN backw = uend - uoffset;
6039
6040     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6041
6042     if (uoffset < 2 * backw) {
6043         /* The assumption is that going forwards is twice the speed of going
6044            forward (that's where the 2 * backw comes from).
6045            (The real figure of course depends on the UTF-8 data.)  */
6046         return sv_pos_u2b_forwards(start, send, uoffset);
6047     }
6048
6049     while (backw--) {
6050         send--;
6051         while (UTF8_IS_CONTINUATION(*send))
6052             send--;
6053     }
6054     return send - start;
6055 }
6056
6057 /* For the string representation of the given scalar, find the byte
6058    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
6059    give another position in the string, *before* the sought offset, which
6060    (which is always true, as 0, 0 is a valid pair of positions), which should
6061    help reduce the amount of linear searching.
6062    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6063    will be used to reduce the amount of linear searching. The cache will be
6064    created if necessary, and the found value offered to it for update.  */
6065 static STRLEN
6066 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6067                     const U8 *const send, const STRLEN uoffset,
6068                     STRLEN uoffset0, STRLEN boffset0)
6069 {
6070     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
6071     bool found = FALSE;
6072
6073     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6074
6075     assert (uoffset >= uoffset0);
6076
6077     if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6078         && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6079         if ((*mgp)->mg_ptr) {
6080             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6081             if (cache[0] == uoffset) {
6082                 /* An exact match. */
6083                 return cache[1];
6084             }
6085             if (cache[2] == uoffset) {
6086                 /* An exact match. */
6087                 return cache[3];
6088             }
6089
6090             if (cache[0] < uoffset) {
6091                 /* The cache already knows part of the way.   */
6092                 if (cache[0] > uoffset0) {
6093                     /* The cache knows more than the passed in pair  */
6094                     uoffset0 = cache[0];
6095                     boffset0 = cache[1];
6096                 }
6097                 if ((*mgp)->mg_len != -1) {
6098                     /* And we know the end too.  */
6099                     boffset = boffset0
6100                         + sv_pos_u2b_midway(start + boffset0, send,
6101                                               uoffset - uoffset0,
6102                                               (*mgp)->mg_len - uoffset0);
6103                 } else {
6104                     boffset = boffset0
6105                         + sv_pos_u2b_forwards(start + boffset0,
6106                                                 send, uoffset - uoffset0);
6107                 }
6108             }
6109             else if (cache[2] < uoffset) {
6110                 /* We're between the two cache entries.  */
6111                 if (cache[2] > uoffset0) {
6112                     /* and the cache knows more than the passed in pair  */
6113                     uoffset0 = cache[2];
6114                     boffset0 = cache[3];
6115                 }
6116
6117                 boffset = boffset0
6118                     + sv_pos_u2b_midway(start + boffset0,
6119                                           start + cache[1],
6120                                           uoffset - uoffset0,
6121                                           cache[0] - uoffset0);
6122             } else {
6123                 boffset = boffset0
6124                     + sv_pos_u2b_midway(start + boffset0,
6125                                           start + cache[3],
6126                                           uoffset - uoffset0,
6127                                           cache[2] - uoffset0);
6128             }
6129             found = TRUE;
6130         }
6131         else if ((*mgp)->mg_len != -1) {
6132             /* If we can take advantage of a passed in offset, do so.  */
6133             /* In fact, offset0 is either 0, or less than offset, so don't
6134                need to worry about the other possibility.  */
6135             boffset = boffset0
6136                 + sv_pos_u2b_midway(start + boffset0, send,
6137                                       uoffset - uoffset0,
6138                                       (*mgp)->mg_len - uoffset0);
6139             found = TRUE;
6140         }
6141     }
6142
6143     if (!found || PL_utf8cache < 0) {
6144         const STRLEN real_boffset
6145             = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6146                                                send, uoffset - uoffset0);
6147
6148         if (found && PL_utf8cache < 0) {
6149             if (real_boffset != boffset) {
6150                 /* Need to turn the assertions off otherwise we may recurse
6151                    infinitely while printing error messages.  */
6152                 SAVEI8(PL_utf8cache);
6153                 PL_utf8cache = 0;
6154                 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
6155                            " real %"UVuf" for %"SVf,
6156                            (UV) boffset, (UV) real_boffset, SVfARG(sv));
6157             }
6158         }
6159         boffset = real_boffset;
6160     }
6161
6162     if (PL_utf8cache)
6163         utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6164     return boffset;
6165 }
6166
6167
6168 /*
6169 =for apidoc sv_pos_u2b
6170
6171 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6172 the start of the string, to a count of the equivalent number of bytes; if
6173 lenp is non-zero, it does the same to lenp, but this time starting from
6174 the offset, rather than from the start of the string. Handles magic and
6175 type coercion.
6176
6177 =cut
6178 */
6179
6180 /*
6181  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6182  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6183  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6184  *
6185  */
6186
6187 void
6188 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6189 {
6190     const U8 *start;
6191     STRLEN len;
6192
6193     PERL_ARGS_ASSERT_SV_POS_U2B;
6194
6195     if (!sv)
6196         return;
6197
6198     start = (U8*)SvPV_const(sv, len);
6199     if (len) {
6200         STRLEN uoffset = (STRLEN) *offsetp;
6201         const U8 * const send = start + len;
6202         MAGIC *mg = NULL;
6203         const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
6204                                              uoffset, 0, 0);
6205
6206         *offsetp = (I32) boffset;
6207
6208         if (lenp) {
6209             /* Convert the relative offset to absolute.  */
6210             const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
6211             const STRLEN boffset2
6212                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6213                                       uoffset, boffset) - boffset;
6214
6215             *lenp = boffset2;
6216         }
6217     }
6218     else {
6219          *offsetp = 0;
6220          if (lenp)
6221               *lenp = 0;
6222     }
6223
6224     return;
6225 }
6226
6227 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6228    byte length pairing. The (byte) length of the total SV is passed in too,
6229    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6230    may not have updated SvCUR, so we can't rely on reading it directly.
6231
6232    The proffered utf8/byte length pairing isn't used if the cache already has
6233    two pairs, and swapping either for the proffered pair would increase the
6234    RMS of the intervals between known byte offsets.
6235
6236    The cache itself consists of 4 STRLEN values
6237    0: larger UTF-8 offset
6238    1: corresponding byte offset
6239    2: smaller UTF-8 offset
6240    3: corresponding byte offset
6241
6242    Unused cache pairs have the value 0, 0.
6243    Keeping the cache "backwards" means that the invariant of
6244    cache[0] >= cache[2] is maintained even with empty slots, which means that
6245    the code that uses it doesn't need to worry if only 1 entry has actually
6246    been set to non-zero.  It also makes the "position beyond the end of the
6247    cache" logic much simpler, as the first slot is always the one to start
6248    from.
6249 */
6250 static void
6251 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6252                            const STRLEN utf8, const STRLEN blen)
6253 {
6254     STRLEN *cache;
6255
6256     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6257
6258     if (SvREADONLY(sv))
6259         return;
6260
6261     if (!*mgp) {
6262         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6263                            0);
6264         (*mgp)->mg_len = -1;
6265     }
6266     assert(*mgp);
6267
6268     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6269         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6270         (*mgp)->mg_ptr = (char *) cache;
6271     }
6272     assert(cache);
6273
6274     if (PL_utf8cache < 0) {
6275         const U8 *start = (const U8 *) SvPVX_const(sv);
6276         const STRLEN realutf8 = utf8_length(start, start + byte);
6277
6278         if (realutf8 != utf8) {
6279             /* Need to turn the assertions off otherwise we may recurse
6280                infinitely while printing error messages.  */
6281             SAVEI8(PL_utf8cache);
6282             PL_utf8cache = 0;
6283             Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6284                        " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6285         }
6286     }
6287
6288     /* Cache is held with the later position first, to simplify the code
6289        that deals with unbounded ends.  */
6290
6291     ASSERT_UTF8_CACHE(cache);
6292     if (cache[1] == 0) {
6293         /* Cache is totally empty  */
6294         cache[0] = utf8;
6295         cache[1] = byte;
6296     } else if (cache[3] == 0) {
6297         if (byte > cache[1]) {
6298             /* New one is larger, so goes first.  */
6299             cache[2] = cache[0];
6300             cache[3] = cache[1];
6301             cache[0] = utf8;
6302             cache[1] = byte;
6303         } else {
6304             cache[2] = utf8;
6305             cache[3] = byte;
6306         }
6307     } else {
6308 #define THREEWAY_SQUARE(a,b,c,d) \
6309             ((float)((d) - (c))) * ((float)((d) - (c))) \
6310             + ((float)((c) - (b))) * ((float)((c) - (b))) \
6311                + ((float)((b) - (a))) * ((float)((b) - (a)))
6312
6313         /* Cache has 2 slots in use, and we know three potential pairs.
6314            Keep the two that give the lowest RMS distance. Do the
6315            calcualation in bytes simply because we always know the byte
6316            length.  squareroot has the same ordering as the positive value,
6317            so don't bother with the actual square root.  */
6318         const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6319         if (byte > cache[1]) {
6320             /* New position is after the existing pair of pairs.  */
6321             const float keep_earlier
6322                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6323             const float keep_later
6324                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6325
6326             if (keep_later < keep_earlier) {
6327                 if (keep_later < existing) {
6328                     cache[2] = cache[0];
6329                     cache[3] = cache[1];
6330                     cache[0] = utf8;
6331                     cache[1] = byte;
6332                 }
6333             }
6334             else {
6335                 if (keep_earlier < existing) {
6336                     cache[0] = utf8;
6337                     cache[1] = byte;
6338                 }
6339             }
6340         }
6341         else if (byte > cache[3]) {
6342             /* New position is between the existing pair of pairs.  */
6343             const float keep_earlier
6344                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6345             const float keep_later
6346                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6347
6348             if (keep_later < keep_earlier) {
6349                 if (keep_later < existing) {
6350                     cache[2] = utf8;
6351                     cache[3] = byte;
6352                 }
6353             }
6354             else {
6355                 if (keep_earlier < existing) {
6356                     cache[0] = utf8;
6357                     cache[1] = byte;
6358                 }
6359             }
6360         }
6361         else {
6362             /* New position is before the existing pair of pairs.  */
6363             const float keep_earlier
6364                 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6365             const float keep_later
6366                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6367
6368             if (keep_later < keep_earlier) {
6369                 if (keep_later < existing) {
6370                     cache[2] = utf8;
6371                     cache[3] = byte;
6372                 }
6373             }
6374             else {
6375                 if (keep_earlier < existing) {
6376                     cache[0] = cache[2];
6377                     cache[1] = cache[3];
6378                     cache[2] = utf8;
6379                     cache[3] = byte;
6380                 }
6381             }
6382         }
6383     }
6384     ASSERT_UTF8_CACHE(cache);
6385 }
6386
6387 /* We already know all of the way, now we may be able to walk back.  The same
6388    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6389    backward is half the speed of walking forward. */
6390 static STRLEN
6391 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6392                     const U8 *end, STRLEN endu)
6393 {
6394     const STRLEN forw = target - s;
6395     STRLEN backw = end - target;
6396
6397     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6398
6399     if (forw < 2 * backw) {
6400         return utf8_length(s, target);
6401     }
6402
6403     while (end > target) {
6404         end--;
6405         while (UTF8_IS_CONTINUATION(*end)) {
6406             end--;
6407         }
6408         endu--;
6409     }
6410     return endu;
6411 }
6412
6413 /*
6414 =for apidoc sv_pos_b2u
6415
6416 Converts the value pointed to by offsetp from a count of bytes from the
6417 start of the string, to a count of the equivalent number of UTF-8 chars.
6418 Handles magic and type coercion.
6419
6420 =cut
6421 */
6422
6423 /*
6424  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6425  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6426  * byte offsets.
6427  *
6428  */
6429 void
6430 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6431 {
6432     const U8* s;
6433     const STRLEN byte = *offsetp;
6434     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
6435     STRLEN blen;
6436     MAGIC* mg = NULL;
6437     const U8* send;
6438     bool found = FALSE;
6439
6440     PERL_ARGS_ASSERT_SV_POS_B2U;
6441
6442     if (!sv)
6443         return;
6444
6445     s = (const U8*)SvPV_const(sv, blen);
6446
6447     if (blen < byte)
6448         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6449
6450     send = s + byte;
6451
6452     if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6453         && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
6454         if (mg->mg_ptr) {
6455             STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6456             if (cache[1] == byte) {
6457                 /* An exact match. */
6458                 *offsetp = cache[0];
6459                 return;
6460             }
6461             if (cache[3] == byte) {
6462                 /* An exact match. */
6463                 *offsetp = cache[2];
6464                 return;
6465             }
6466
6467             if (cache[1] < byte) {
6468                 /* We already know part of the way. */
6469                 if (mg->mg_len != -1) {
6470                     /* Actually, we know the end too.  */
6471                     len = cache[0]
6472                         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6473                                               s + blen, mg->mg_len - cache[0]);
6474                 } else {
6475                     len = cache[0] + utf8_length(s + cache[1], send);
6476                 }
6477             }
6478             else if (cache[3] < byte) {
6479                 /* We're between the two cached pairs, so we do the calculation
6480                    offset by the byte/utf-8 positions for the earlier pair,
6481                    then add the utf-8 characters from the string start to
6482                    there.  */
6483                 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6484                                           s + cache[1], cache[0] - cache[2])
6485                     + cache[2];
6486
6487             }
6488             else { /* cache[3] > byte */
6489                 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6490                                           cache[2]);
6491
6492             }
6493             ASSERT_UTF8_CACHE(cache);
6494             found = TRUE;
6495         } else if (mg->mg_len != -1) {
6496             len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6497             found = TRUE;
6498         }
6499     }
6500     if (!found || PL_utf8cache < 0) {
6501         const STRLEN real_len = utf8_length(s, send);
6502
6503         if (found && PL_utf8cache < 0) {
6504             if (len != real_len) {
6505                 /* Need to turn the assertions off otherwise we may recurse
6506                    infinitely while printing error messages.  */
6507                 SAVEI8(PL_utf8cache);
6508                 PL_utf8cache = 0;
6509                 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6510                            " real %"UVuf" for %"SVf,
6511                            (UV) len, (UV) real_len, SVfARG(sv));
6512             }
6513         }
6514         len = real_len;
6515     }
6516     *offsetp = len;
6517
6518     if (PL_utf8cache)
6519         utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6520 }
6521
6522 /*
6523 =for apidoc sv_eq
6524
6525 Returns a boolean indicating whether the strings in the two SVs are
6526 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6527 coerce its args to strings if necessary.
6528
6529 =cut
6530 */
6531
6532 I32
6533 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6534 {
6535     dVAR;
6536     const char *pv1;
6537     STRLEN cur1;
6538     const char *pv2;
6539     STRLEN cur2;
6540     I32  eq     = 0;
6541     char *tpv   = NULL;
6542     SV* svrecode = NULL;
6543
6544     if (!sv1) {
6545         pv1 = "";
6546         cur1 = 0;
6547     }
6548     else {
6549         /* if pv1 and pv2 are the same, second SvPV_const call may
6550          * invalidate pv1, so we may need to make a copy */
6551         if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6552             pv1 = SvPV_const(sv1, cur1);
6553             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6554         }
6555         pv1 = SvPV_const(sv1, cur1);
6556     }
6557
6558     if (!sv2){
6559         pv2 = "";
6560         cur2 = 0;
6561     }
6562     else
6563         pv2 = SvPV_const(sv2, cur2);
6564
6565     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6566         /* Differing utf8ness.
6567          * Do not UTF8size the comparands as a side-effect. */
6568          if (PL_encoding) {
6569               if (SvUTF8(sv1)) {
6570                    svrecode = newSVpvn(pv2, cur2);
6571                    sv_recode_to_utf8(svrecode, PL_encoding);
6572                    pv2 = SvPV_const(svrecode, cur2);
6573               }
6574               else {
6575                    svrecode = newSVpvn(pv1, cur1);
6576                    sv_recode_to_utf8(svrecode, PL_encoding);
6577                    pv1 = SvPV_const(svrecode, cur1);
6578               }
6579               /* Now both are in UTF-8. */
6580               if (cur1 != cur2) {
6581                    SvREFCNT_dec(svrecode);
6582                    return FALSE;
6583               }
6584          }
6585          else {
6586               bool is_utf8 = TRUE;
6587
6588               if (SvUTF8(sv1)) {
6589                    /* sv1 is the UTF-8 one,
6590                     * if is equal it must be downgrade-able */
6591                    char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6592                                                      &cur1, &is_utf8);
6593                    if (pv != pv1)
6594                         pv1 = tpv = pv;
6595               }
6596               else {
6597                    /* sv2 is the UTF-8 one,
6598                     * if is equal it must be downgrade-able */
6599                    char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6600                                                       &cur2, &is_utf8);
6601                    if (pv != pv2)
6602                         pv2 = tpv = pv;
6603               }
6604               if (is_utf8) {
6605                    /* Downgrade not possible - cannot be eq */
6606                    assert (tpv == 0);
6607                    return FALSE;
6608               }
6609          }
6610     }
6611
6612     if (cur1 == cur2)
6613         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6614
6615     SvREFCNT_dec(svrecode);
6616     if (tpv)
6617         Safefree(tpv);
6618
6619     return eq;
6620 }
6621
6622 /*
6623 =for apidoc sv_cmp
6624
6625 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
6626 string in C<sv1> is less than, equal to, or greater than the string in
6627 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6628 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
6629
6630 =cut
6631 */
6632
6633 I32
6634 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6635 {
6636     dVAR;
6637     STRLEN cur1, cur2;
6638     const char *pv1, *pv2;
6639     char *tpv = NULL;
6640     I32  cmp;
6641     SV *svrecode = NULL;
6642
6643     if (!sv1) {
6644         pv1 = "";
6645         cur1 = 0;
6646     }
6647     else
6648         pv1 = SvPV_const(sv1, cur1);
6649
6650     if (!sv2) {
6651         pv2 = "";
6652         cur2 = 0;
6653     }
6654     else
6655         pv2 = SvPV_const(sv2, cur2);
6656
6657     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6658         /* Differing utf8ness.
6659          * Do not UTF8size the comparands as a side-effect. */
6660         if (SvUTF8(sv1)) {
6661             if (PL_encoding) {
6662                  svrecode = newSVpvn(pv2, cur2);
6663                  sv_recode_to_utf8(svrecode, PL_encoding);
6664                  pv2 = SvPV_const(svrecode, cur2);
6665             }
6666             else {
6667                  pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6668             }
6669         }
6670         else {
6671             if (PL_encoding) {
6672                  svrecode = newSVpvn(pv1, cur1);
6673                  sv_recode_to_utf8(svrecode, PL_encoding);
6674                  pv1 = SvPV_const(svrecode, cur1);
6675             }
6676             else {
6677                  pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6678             }
6679         }
6680     }
6681
6682     if (!cur1) {
6683         cmp = cur2 ? -1 : 0;
6684     } else if (!cur2) {
6685         cmp = 1;
6686     } else {
6687         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6688
6689         if (retval) {
6690             cmp = retval < 0 ? -1 : 1;
6691         } else if (cur1 == cur2) {
6692             cmp = 0;
6693         } else {
6694             cmp = cur1 < cur2 ? -1 : 1;
6695         }
6696     }
6697
6698     SvREFCNT_dec(svrecode);
6699     if (tpv)
6700         Safefree(tpv);
6701
6702     return cmp;
6703 }
6704
6705 /*
6706 =for apidoc sv_cmp_locale
6707
6708 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6709 'use bytes' aware, handles get magic, and will coerce its args to strings
6710 if necessary.  See also C<sv_cmp>.
6711
6712 =cut
6713 */
6714
6715 I32
6716 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6717 {
6718     dVAR;
6719 #ifdef USE_LOCALE_COLLATE
6720
6721     char *pv1, *pv2;
6722     STRLEN len1, len2;
6723     I32 retval;
6724
6725     if (PL_collation_standard)
6726         goto raw_compare;
6727
6728     len1 = 0;
6729     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6730     len2 = 0;
6731     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6732
6733     if (!pv1 || !len1) {
6734         if (pv2 && len2)
6735             return -1;
6736         else
6737             goto raw_compare;
6738     }
6739     else {
6740         if (!pv2 || !len2)
6741             return 1;
6742     }
6743
6744     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6745
6746     if (retval)
6747         return retval < 0 ? -1 : 1;
6748
6749     /*
6750      * When the result of collation is equality, that doesn't mean
6751      * that there are no differences -- some locales exclude some
6752      * characters from consideration.  So to avoid false equalities,
6753      * we use the raw string as a tiebreaker.
6754      */
6755
6756   raw_compare:
6757     /*FALLTHROUGH*/
6758
6759 #endif /* USE_LOCALE_COLLATE */
6760
6761     return sv_cmp(sv1, sv2);
6762 }
6763
6764
6765 #ifdef USE_LOCALE_COLLATE
6766
6767 /*
6768 =for apidoc sv_collxfrm
6769
6770 Add Collate Transform magic to an SV if it doesn't already have it.
6771
6772 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6773 scalar data of the variable, but transformed to such a format that a normal
6774 memory comparison can be used to compare the data according to the locale
6775 settings.
6776
6777 =cut
6778 */
6779
6780 char *
6781 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6782 {
6783     dVAR;
6784     MAGIC *mg;
6785
6786     PERL_ARGS_ASSERT_SV_COLLXFRM;
6787
6788     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6789     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6790         const char *s;
6791         char *xf;
6792         STRLEN len, xlen;
6793
6794         if (mg)
6795             Safefree(mg->mg_ptr);
6796         s = SvPV_const(sv, len);
6797         if ((xf = mem_collxfrm(s, len, &xlen))) {
6798             if (! mg) {
6799 #ifdef PERL_OLD_COPY_ON_WRITE
6800                 if (SvIsCOW(sv))
6801                     sv_force_normal_flags(sv, 0);
6802 #endif
6803                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6804                                  0, 0);
6805                 assert(mg);
6806             }
6807             mg->mg_ptr = xf;
6808             mg->mg_len = xlen;
6809         }
6810         else {
6811             if (mg) {
6812                 mg->mg_ptr = NULL;
6813                 mg->mg_len = -1;
6814             }
6815         }
6816     }
6817     if (mg && mg->mg_ptr) {
6818         *nxp = mg->mg_len;
6819         return mg->mg_ptr + sizeof(PL_collation_ix);
6820     }
6821     else {
6822         *nxp = 0;
6823         return NULL;
6824     }
6825 }
6826
6827 #endif /* USE_LOCALE_COLLATE */
6828
6829 /*
6830 =for apidoc sv_gets
6831
6832 Get a line from the filehandle and store it into the SV, optionally
6833 appending to the currently-stored string.
6834
6835 =cut
6836 */
6837
6838 char *
6839 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6840 {
6841     dVAR;
6842     const char *rsptr;
6843     STRLEN rslen;
6844     register STDCHAR rslast;
6845     register STDCHAR *bp;
6846     register I32 cnt;
6847     I32 i = 0;
6848     I32 rspara = 0;
6849
6850     PERL_ARGS_ASSERT_SV_GETS;
6851
6852     if (SvTHINKFIRST(sv))
6853         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6854     /* XXX. If you make this PVIV, then copy on write can copy scalars read
6855        from <>.
6856        However, perlbench says it's slower, because the existing swipe code
6857        is faster than copy on write.
6858        Swings and roundabouts.  */
6859     SvUPGRADE(sv, SVt_PV);
6860
6861     SvSCREAM_off(sv);
6862
6863     if (append) {
6864         if (PerlIO_isutf8(fp)) {
6865             if (!SvUTF8(sv)) {
6866                 sv_utf8_upgrade_nomg(sv);
6867                 sv_pos_u2b(sv,&append,0);
6868             }
6869         } else if (SvUTF8(sv)) {
6870             SV * const tsv = newSV(0);
6871             sv_gets(tsv, fp, 0);
6872             sv_utf8_upgrade_nomg(tsv);
6873             SvCUR_set(sv,append);
6874             sv_catsv(sv,tsv);
6875             sv_free(tsv);
6876             goto return_string_or_null;
6877         }
6878     }
6879
6880     SvPOK_only(sv);
6881     if (PerlIO_isutf8(fp))
6882         SvUTF8_on(sv);
6883
6884     if (IN_PERL_COMPILETIME) {
6885         /* we always read code in line mode */
6886         rsptr = "\n";
6887         rslen = 1;
6888     }
6889     else if (RsSNARF(PL_rs)) {
6890         /* If it is a regular disk file use size from stat() as estimate
6891            of amount we are going to read -- may result in mallocing
6892            more memory than we really need if the layers below reduce
6893            the size we read (e.g. CRLF or a gzip layer).
6894          */
6895         Stat_t st;
6896         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
6897             const Off_t offset = PerlIO_tell(fp);
6898             if (offset != (Off_t) -1 && st.st_size + append > offset) {
6899                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6900             }
6901         }
6902         rsptr = NULL;
6903         rslen = 0;
6904     }
6905     else if (RsRECORD(PL_rs)) {
6906       I32 bytesread;
6907       char *buffer;
6908       U32 recsize;
6909 #ifdef VMS
6910       int fd;
6911 #endif
6912
6913       /* Grab the size of the record we're getting */
6914       recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
6915       buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6916       /* Go yank in */
6917 #ifdef VMS
6918       /* VMS wants read instead of fread, because fread doesn't respect */
6919       /* RMS record boundaries. This is not necessarily a good thing to be */
6920       /* doing, but we've got no other real choice - except avoid stdio
6921          as implementation - perhaps write a :vms layer ?
6922        */
6923       fd = PerlIO_fileno(fp);
6924       if (fd == -1) { /* in-memory file from PerlIO::Scalar */
6925           bytesread = PerlIO_read(fp, buffer, recsize);
6926       }
6927       else {
6928           bytesread = PerlLIO_read(fd, buffer, recsize);
6929       }
6930 #else
6931       bytesread = PerlIO_read(fp, buffer, recsize);
6932 #endif
6933       if (bytesread < 0)
6934           bytesread = 0;
6935       SvCUR_set(sv, bytesread + append);
6936       buffer[bytesread] = '\0';
6937       goto return_string_or_null;
6938     }
6939     else if (RsPARA(PL_rs)) {
6940         rsptr = "\n\n";
6941         rslen = 2;
6942         rspara = 1;
6943     }
6944     else {
6945         /* Get $/ i.e. PL_rs into same encoding as stream wants */
6946         if (PerlIO_isutf8(fp)) {
6947             rsptr = SvPVutf8(PL_rs, rslen);
6948         }
6949         else {
6950             if (SvUTF8(PL_rs)) {
6951                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6952                     Perl_croak(aTHX_ "Wide character in $/");
6953                 }
6954             }
6955             rsptr = SvPV_const(PL_rs, rslen);
6956         }
6957     }
6958
6959     rslast = rslen ? rsptr[rslen - 1] : '\0';
6960
6961     if (rspara) {               /* have to do this both before and after */
6962         do {                    /* to make sure file boundaries work right */
6963             if (PerlIO_eof(fp))
6964                 return 0;
6965             i = PerlIO_getc(fp);
6966             if (i != '\n') {
6967                 if (i == -1)
6968                     return 0;
6969                 PerlIO_ungetc(fp,i);
6970                 break;
6971             }
6972         } while (i != EOF);
6973     }
6974
6975     /* See if we know enough about I/O mechanism to cheat it ! */
6976
6977     /* This used to be #ifdef test - it is made run-time test for ease
6978        of abstracting out stdio interface. One call should be cheap
6979        enough here - and may even be a macro allowing compile
6980        time optimization.
6981      */
6982
6983     if (PerlIO_fast_gets(fp)) {
6984
6985     /*
6986      * We're going to steal some values from the stdio struct
6987      * and put EVERYTHING in the innermost loop into registers.
6988      */
6989     register STDCHAR *ptr;
6990     STRLEN bpx;
6991     I32 shortbuffered;
6992
6993 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6994     /* An ungetc()d char is handled separately from the regular
6995      * buffer, so we getc() it back out and stuff it in the buffer.
6996      */
6997     i = PerlIO_getc(fp);
6998     if (i == EOF) return 0;
6999     *(--((*fp)->_ptr)) = (unsigned char) i;
7000     (*fp)->_cnt++;
7001 #endif
7002
7003     /* Here is some breathtakingly efficient cheating */
7004
7005     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
7006     /* make sure we have the room */
7007     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7008         /* Not room for all of it
7009            if we are looking for a separator and room for some
7010          */
7011         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7012             /* just process what we have room for */
7013             shortbuffered = cnt - SvLEN(sv) + append + 1;
7014             cnt -= shortbuffered;
7015         }
7016         else {
7017             shortbuffered = 0;
7018             /* remember that cnt can be negative */
7019             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7020         }
7021     }
7022     else
7023         shortbuffered = 0;
7024     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
7025     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7026     DEBUG_P(PerlIO_printf(Perl_debug_log,
7027         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7028     DEBUG_P(PerlIO_printf(Perl_debug_log,
7029         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7030                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7031                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7032     for (;;) {
7033       screamer:
7034         if (cnt > 0) {
7035             if (rslen) {
7036                 while (cnt > 0) {                    /* this     |  eat */
7037                     cnt--;
7038                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
7039                         goto thats_all_folks;        /* screams  |  sed :-) */
7040                 }
7041             }
7042             else {
7043                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
7044                 bp += cnt;                           /* screams  |  dust */
7045                 ptr += cnt;                          /* louder   |  sed :-) */
7046                 cnt = 0;
7047             }
7048         }
7049
7050         if (shortbuffered) {            /* oh well, must extend */
7051             cnt = shortbuffered;
7052             shortbuffered = 0;
7053             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7054             SvCUR_set(sv, bpx);
7055             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7056             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7057             continue;
7058         }
7059
7060         DEBUG_P(PerlIO_printf(Perl_debug_log,
7061                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7062                               PTR2UV(ptr),(long)cnt));
7063         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7064 #if 0
7065         DEBUG_P(PerlIO_printf(Perl_debug_log,
7066             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7067             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7068             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7069 #endif
7070         /* This used to call 'filbuf' in stdio form, but as that behaves like
7071            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7072            another abstraction.  */
7073         i   = PerlIO_getc(fp);          /* get more characters */
7074 #if 0
7075         DEBUG_P(PerlIO_printf(Perl_debug_log,
7076             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7077             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7078             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7079 #endif
7080         cnt = PerlIO_get_cnt(fp);
7081         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
7082         DEBUG_P(PerlIO_printf(Perl_debug_log,
7083             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7084
7085         if (i == EOF)                   /* all done for ever? */
7086             goto thats_really_all_folks;
7087
7088         bpx = bp - (STDCHAR*)SvPVX_const(sv);   /* box up before relocation */
7089         SvCUR_set(sv, bpx);
7090         SvGROW(sv, bpx + cnt + 2);
7091         bp = (STDCHAR*)SvPVX_const(sv) + bpx;   /* unbox after relocation */
7092
7093         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
7094
7095         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
7096             goto thats_all_folks;
7097     }
7098
7099 thats_all_folks:
7100     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7101           memNE((char*)bp - rslen, rsptr, rslen))
7102         goto screamer;                          /* go back to the fray */
7103 thats_really_all_folks:
7104     if (shortbuffered)
7105         cnt += shortbuffered;
7106         DEBUG_P(PerlIO_printf(Perl_debug_log,
7107             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7108     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
7109     DEBUG_P(PerlIO_printf(Perl_debug_log,
7110         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7111         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7112         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7113     *bp = '\0';
7114     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));      /* set length */
7115     DEBUG_P(PerlIO_printf(Perl_debug_log,
7116         "Screamer: done, len=%ld, string=|%.*s|\n",
7117         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7118     }
7119    else
7120     {
7121        /*The big, slow, and stupid way. */
7122 #ifdef USE_HEAP_INSTEAD_OF_STACK        /* Even slower way. */
7123         STDCHAR *buf = NULL;
7124         Newx(buf, 8192, STDCHAR);
7125         assert(buf);
7126 #else
7127         STDCHAR buf[8192];
7128 #endif
7129
7130 screamer2:
7131         if (rslen) {
7132             register const STDCHAR * const bpe = buf + sizeof(buf);
7133             bp = buf;
7134             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7135                 ; /* keep reading */
7136             cnt = bp - buf;
7137         }
7138         else {
7139             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7140             /* Accomodate broken VAXC compiler, which applies U8 cast to
7141              * both args of ?: operator, causing EOF to change into 255
7142              */
7143             if (cnt > 0)
7144                  i = (U8)buf[cnt - 1];
7145             else
7146                  i = EOF;
7147         }
7148
7149         if (cnt < 0)
7150             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
7151         if (append)
7152              sv_catpvn(sv, (char *) buf, cnt);
7153         else
7154              sv_setpvn(sv, (char *) buf, cnt);
7155
7156         if (i != EOF &&                 /* joy */
7157             (!rslen ||
7158              SvCUR(sv) < rslen ||
7159              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7160         {
7161             append = -1;
7162             /*
7163              * If we're reading from a TTY and we get a short read,
7164              * indicating that the user hit his EOF character, we need
7165              * to notice it now, because if we try to read from the TTY
7166              * again, the EOF condition will disappear.
7167              *
7168              * The comparison of cnt to sizeof(buf) is an optimization
7169              * that prevents unnecessary calls to feof().
7170              *
7171              * - jik 9/25/96
7172              */
7173             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7174                 goto screamer2;
7175         }
7176
7177 #ifdef USE_HEAP_INSTEAD_OF_STACK
7178         Safefree(buf);
7179 #endif
7180     }
7181
7182     if (rspara) {               /* have to do this both before and after */
7183         while (i != EOF) {      /* to make sure file boundaries work right */
7184             i = PerlIO_getc(fp);
7185             if (i != '\n') {
7186                 PerlIO_ungetc(fp,i);
7187                 break;
7188             }
7189         }
7190     }
7191
7192 return_string_or_null:
7193     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7194 }
7195
7196 /*
7197 =for apidoc sv_inc
7198
7199 Auto-increment of the value in the SV, doing string to numeric conversion
7200 if necessary. Handles 'get' magic.
7201
7202 =cut
7203 */
7204
7205 void
7206 Perl_sv_inc(pTHX_ register SV *const sv)
7207 {
7208     dVAR;
7209     register char *d;
7210     int flags;
7211
7212     if (!sv)
7213         return;
7214     SvGETMAGIC(sv);
7215     if (SvTHINKFIRST(sv)) {
7216         if (SvIsCOW(sv))
7217             sv_force_normal_flags(sv, 0);
7218         if (SvREADONLY(sv)) {
7219             if (IN_PERL_RUNTIME)
7220                 Perl_croak(aTHX_ "%s", PL_no_modify);
7221         }
7222         if (SvROK(sv)) {
7223             IV i;
7224             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7225                 return;
7226             i = PTR2IV(SvRV(sv));
7227             sv_unref(sv);
7228             sv_setiv(sv, i);
7229         }
7230     }
7231     flags = SvFLAGS(sv);
7232     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7233         /* It's (privately or publicly) a float, but not tested as an
7234            integer, so test it to see. */
7235         (void) SvIV(sv);
7236         flags = SvFLAGS(sv);
7237     }
7238     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7239         /* It's publicly an integer, or privately an integer-not-float */
7240 #ifdef PERL_PRESERVE_IVUV
7241       oops_its_int:
7242 #endif
7243         if (SvIsUV(sv)) {
7244             if (SvUVX(sv) == UV_MAX)
7245                 sv_setnv(sv, UV_MAX_P1);
7246             else
7247                 (void)SvIOK_only_UV(sv);
7248                 SvUV_set(sv, SvUVX(sv) + 1);
7249         } else {
7250             if (SvIVX(sv) == IV_MAX)
7251                 sv_setuv(sv, (UV)IV_MAX + 1);
7252             else {
7253                 (void)SvIOK_only(sv);
7254                 SvIV_set(sv, SvIVX(sv) + 1);
7255             }
7256         }
7257         return;
7258     }
7259     if (flags & SVp_NOK) {
7260         const NV was = SvNVX(sv);
7261         if (NV_OVERFLOWS_INTEGERS_AT &&
7262             was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7263             Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7264                         "Lost precision when incrementing %" NVff " by 1",
7265                         was);
7266         }
7267         (void)SvNOK_only(sv);
7268         SvNV_set(sv, was + 1.0);
7269         return;
7270     }
7271
7272     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7273         if ((flags & SVTYPEMASK) < SVt_PVIV)
7274             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7275         (void)SvIOK_only(sv);
7276         SvIV_set(sv, 1);
7277         return;
7278     }
7279     d = SvPVX(sv);
7280     while (isALPHA(*d)) d++;
7281     while (isDIGIT(*d)) d++;
7282     if (*d) {
7283 #ifdef PERL_PRESERVE_IVUV
7284         /* Got to punt this as an integer if needs be, but we don't issue
7285            warnings. Probably ought to make the sv_iv_please() that does
7286            the conversion if possible, and silently.  */
7287         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7288         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7289             /* Need to try really hard to see if it's an integer.
7290                9.22337203685478e+18 is an integer.
7291                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7292                so $a="9.22337203685478e+18"; $a+0; $a++
7293                needs to be the same as $a="9.22337203685478e+18"; $a++
7294                or we go insane. */
7295
7296             (void) sv_2iv(sv);
7297             if (SvIOK(sv))
7298                 goto oops_its_int;
7299
7300             /* sv_2iv *should* have made this an NV */
7301             if (flags & SVp_NOK) {
7302                 (void)SvNOK_only(sv);
7303                 SvNV_set(sv, SvNVX(sv) + 1.0);
7304                 return;
7305             }
7306             /* I don't think we can get here. Maybe I should assert this
7307                And if we do get here I suspect that sv_setnv will croak. NWC
7308                Fall through. */
7309 #if defined(USE_LONG_DOUBLE)
7310             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",
7311                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7312 #else
7313             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7314                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7315 #endif
7316         }
7317 #endif /* PERL_PRESERVE_IVUV */
7318         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7319         return;
7320     }
7321     d--;
7322     while (d >= SvPVX_const(sv)) {
7323         if (isDIGIT(*d)) {
7324             if (++*d <= '9')
7325                 return;
7326             *(d--) = '0';
7327         }
7328         else {
7329 #ifdef EBCDIC
7330             /* MKS: The original code here died if letters weren't consecutive.
7331              * at least it didn't have to worry about non-C locales.  The
7332              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7333              * arranged in order (although not consecutively) and that only
7334              * [A-Za-z] are accepted by isALPHA in the C locale.
7335              */
7336             if (*d != 'z' && *d != 'Z') {
7337                 do { ++*d; } while (!isALPHA(*d));
7338                 return;
7339             }
7340             *(d--) -= 'z' - 'a';
7341 #else
7342             ++*d;
7343             if (isALPHA(*d))
7344                 return;
7345             *(d--) -= 'z' - 'a' + 1;
7346 #endif
7347         }
7348     }
7349     /* oh,oh, the number grew */
7350     SvGROW(sv, SvCUR(sv) + 2);
7351     SvCUR_set(sv, SvCUR(sv) + 1);
7352     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7353         *d = d[-1];
7354     if (isDIGIT(d[1]))
7355         *d = '1';
7356     else
7357         *d = d[1];
7358 }
7359
7360 /*
7361 =for apidoc sv_dec
7362
7363 Auto-decrement of the value in the SV, doing string to numeric conversion
7364 if necessary. Handles 'get' magic.
7365
7366 =cut
7367 */
7368
7369 void
7370 Perl_sv_dec(pTHX_ register SV *const sv)
7371 {
7372     dVAR;
7373     int flags;
7374
7375     if (!sv)
7376         return;
7377     SvGETMAGIC(sv);
7378     if (SvTHINKFIRST(sv)) {
7379         if (SvIsCOW(sv))
7380             sv_force_normal_flags(sv, 0);
7381         if (SvREADONLY(sv)) {
7382             if (IN_PERL_RUNTIME)
7383                 Perl_croak(aTHX_ "%s", PL_no_modify);
7384         }
7385         if (SvROK(sv)) {
7386             IV i;
7387             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7388                 return;
7389             i = PTR2IV(SvRV(sv));
7390             sv_unref(sv);
7391             sv_setiv(sv, i);
7392         }
7393     }
7394     /* Unlike sv_inc we don't have to worry about string-never-numbers
7395        and keeping them magic. But we mustn't warn on punting */
7396     flags = SvFLAGS(sv);
7397     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7398         /* It's publicly an integer, or privately an integer-not-float */
7399 #ifdef PERL_PRESERVE_IVUV
7400       oops_its_int:
7401 #endif
7402         if (SvIsUV(sv)) {
7403             if (SvUVX(sv) == 0) {
7404                 (void)SvIOK_only(sv);
7405                 SvIV_set(sv, -1);
7406             }
7407             else {
7408                 (void)SvIOK_only_UV(sv);
7409                 SvUV_set(sv, SvUVX(sv) - 1);
7410             }
7411         } else {
7412             if (SvIVX(sv) == IV_MIN) {
7413                 sv_setnv(sv, (NV)IV_MIN);
7414                 goto oops_its_num;
7415             }
7416             else {
7417                 (void)SvIOK_only(sv);
7418                 SvIV_set(sv, SvIVX(sv) - 1);
7419             }
7420         }
7421         return;
7422     }
7423     if (flags & SVp_NOK) {
7424     oops_its_num:
7425         {
7426             const NV was = SvNVX(sv);
7427             if (NV_OVERFLOWS_INTEGERS_AT &&
7428                 was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7429                 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7430                             "Lost precision when decrementing %" NVff " by 1",
7431                             was);
7432             }
7433             (void)SvNOK_only(sv);
7434             SvNV_set(sv, was - 1.0);
7435             return;
7436         }
7437     }
7438     if (!(flags & SVp_POK)) {
7439         if ((flags & SVTYPEMASK) < SVt_PVIV)
7440             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7441         SvIV_set(sv, -1);
7442         (void)SvIOK_only(sv);
7443         return;
7444     }
7445 #ifdef PERL_PRESERVE_IVUV
7446     {
7447         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7448         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7449             /* Need to try really hard to see if it's an integer.
7450                9.22337203685478e+18 is an integer.
7451                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7452                so $a="9.22337203685478e+18"; $a+0; $a--
7453                needs to be the same as $a="9.22337203685478e+18"; $a--
7454                or we go insane. */
7455
7456             (void) sv_2iv(sv);
7457             if (SvIOK(sv))
7458                 goto oops_its_int;
7459
7460             /* sv_2iv *should* have made this an NV */
7461             if (flags & SVp_NOK) {
7462                 (void)SvNOK_only(sv);
7463                 SvNV_set(sv, SvNVX(sv) - 1.0);
7464                 return;
7465             }
7466             /* I don't think we can get here. Maybe I should assert this
7467                And if we do get here I suspect that sv_setnv will croak. NWC
7468                Fall through. */
7469 #if defined(USE_LONG_DOUBLE)
7470             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",
7471                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7472 #else
7473             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7474                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7475 #endif
7476         }
7477     }
7478 #endif /* PERL_PRESERVE_IVUV */
7479     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);   /* punt */
7480 }
7481
7482 /*
7483 =for apidoc sv_mortalcopy
7484
7485 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7486 The new SV is marked as mortal. It will be destroyed "soon", either by an
7487 explicit call to FREETMPS, or by an implicit call at places such as
7488 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
7489
7490 =cut
7491 */
7492
7493 /* Make a string that will exist for the duration of the expression
7494  * evaluation.  Actually, it may have to last longer than that, but
7495  * hopefully we won't free it until it has been assigned to a
7496  * permanent location. */
7497
7498 SV *
7499 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7500 {
7501     dVAR;
7502     register SV *sv;
7503
7504     new_SV(sv);
7505     sv_setsv(sv,oldstr);
7506     EXTEND_MORTAL(1);
7507     PL_tmps_stack[++PL_tmps_ix] = sv;
7508     SvTEMP_on(sv);
7509     return sv;
7510 }
7511
7512 /*
7513 =for apidoc sv_newmortal
7514
7515 Creates a new null SV which is mortal.  The reference count of the SV is
7516 set to 1. It will be destroyed "soon", either by an explicit call to
7517 FREETMPS, or by an implicit call at places such as statement boundaries.
7518 See also C<sv_mortalcopy> and C<sv_2mortal>.
7519
7520 =cut
7521 */
7522
7523 SV *
7524 Perl_sv_newmortal(pTHX)
7525 {
7526     dVAR;
7527     register SV *sv;
7528
7529     new_SV(sv);
7530     SvFLAGS(sv) = SVs_TEMP;
7531     EXTEND_MORTAL(1);
7532     PL_tmps_stack[++PL_tmps_ix] = sv;
7533     return sv;
7534 }
7535
7536
7537 /*
7538 =for apidoc newSVpvn_flags
7539
7540 Creates a new SV and copies a string into it.  The reference count for the
7541 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7542 string.  You are responsible for ensuring that the source string is at least
7543 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7544 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7545 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7546 returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
7547 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7548
7549     #define newSVpvn_utf8(s, len, u)                    \
7550         newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7551
7552 =cut
7553 */
7554
7555 SV *
7556 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7557 {
7558     dVAR;
7559     register SV *sv;
7560
7561     /* All the flags we don't support must be zero.
7562        And we're new code so I'm going to assert this from the start.  */
7563     assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7564     new_SV(sv);
7565     sv_setpvn(sv,s,len);
7566     SvFLAGS(sv) |= (flags & SVf_UTF8);
7567     return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
7568 }
7569
7570 /*
7571 =for apidoc sv_2mortal
7572
7573 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
7574 by an explicit call to FREETMPS, or by an implicit call at places such as
7575 statement boundaries.  SvTEMP() is turned on which means that the SV's
7576 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7577 and C<sv_mortalcopy>.
7578
7579 =cut
7580 */
7581
7582 SV *
7583 Perl_sv_2mortal(pTHX_ register SV *const sv)
7584 {
7585     dVAR;
7586     if (!sv)
7587         return NULL;
7588     if (SvREADONLY(sv) && SvIMMORTAL(sv))
7589         return sv;
7590     EXTEND_MORTAL(1);
7591     PL_tmps_stack[++PL_tmps_ix] = sv;
7592     SvTEMP_on(sv);
7593     return sv;
7594 }
7595
7596 /*
7597 =for apidoc newSVpv
7598
7599 Creates a new SV and copies a string into it.  The reference count for the
7600 SV is set to 1.  If C<len> is zero, Perl will compute the length using
7601 strlen().  For efficiency, consider using C<newSVpvn> instead.
7602
7603 =cut
7604 */
7605
7606 SV *
7607 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7608 {
7609     dVAR;
7610     register SV *sv;
7611
7612     new_SV(sv);
7613     sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7614     return sv;
7615 }
7616
7617 /*
7618 =for apidoc newSVpvn
7619
7620 Creates a new SV and copies a string into it.  The reference count for the
7621 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7622 string.  You are responsible for ensuring that the source string is at least
7623 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7624
7625 =cut
7626 */
7627
7628 SV *
7629 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7630 {
7631     dVAR;
7632     register SV *sv;
7633
7634     new_SV(sv);
7635     sv_setpvn(sv,s,len);
7636     return sv;
7637 }
7638
7639 /*
7640 =for apidoc newSVhek
7641
7642 Creates a new SV from the hash key structure.  It will generate scalars that
7643 point to the shared string table where possible. Returns a new (undefined)
7644 SV if the hek is NULL.
7645
7646 =cut
7647 */
7648
7649 SV *
7650 Perl_newSVhek(pTHX_ const HEK *const hek)
7651 {
7652     dVAR;
7653     if (!hek) {
7654         SV *sv;
7655
7656         new_SV(sv);
7657         return sv;
7658     }
7659
7660     if (HEK_LEN(hek) == HEf_SVKEY) {
7661         return newSVsv(*(SV**)HEK_KEY(hek));
7662     } else {
7663         const int flags = HEK_FLAGS(hek);
7664         if (flags & HVhek_WASUTF8) {
7665             /* Trouble :-)
7666                Andreas would like keys he put in as utf8 to come back as utf8
7667             */
7668             STRLEN utf8_len = HEK_LEN(hek);
7669             const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7670             SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7671
7672             SvUTF8_on (sv);
7673             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7674             return sv;
7675         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7676             /* We don't have a pointer to the hv, so we have to replicate the
7677                flag into every HEK. This hv is using custom a hasing
7678                algorithm. Hence we can't return a shared string scalar, as
7679                that would contain the (wrong) hash value, and might get passed
7680                into an hv routine with a regular hash.
7681                Similarly, a hash that isn't using shared hash keys has to have
7682                the flag in every key so that we know not to try to call
7683                share_hek_kek on it.  */
7684
7685             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7686             if (HEK_UTF8(hek))
7687                 SvUTF8_on (sv);
7688             return sv;
7689         }
7690         /* This will be overwhelminly the most common case.  */
7691         {
7692             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7693                more efficient than sharepvn().  */
7694             SV *sv;
7695
7696             new_SV(sv);
7697             sv_upgrade(sv, SVt_PV);
7698             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7699             SvCUR_set(sv, HEK_LEN(hek));
7700             SvLEN_set(sv, 0);
7701             SvREADONLY_on(sv);
7702             SvFAKE_on(sv);
7703             SvPOK_on(sv);
7704             if (HEK_UTF8(hek))
7705                 SvUTF8_on(sv);
7706             return sv;
7707         }
7708     }
7709 }
7710
7711 /*
7712 =for apidoc newSVpvn_share
7713
7714 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7715 table. If the string does not already exist in the table, it is created
7716 first.  Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7717 value is used; otherwise the hash is computed. The string's hash can be later
7718 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7719 that as the string table is used for shared hash keys these strings will have
7720 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7721
7722 =cut
7723 */
7724
7725 SV *
7726 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7727 {
7728     dVAR;
7729     register SV *sv;
7730     bool is_utf8 = FALSE;
7731     const char *const orig_src = src;
7732
7733     if (len < 0) {
7734         STRLEN tmplen = -len;
7735         is_utf8 = TRUE;
7736         /* See the note in hv.c:hv_fetch() --jhi */
7737         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7738         len = tmplen;
7739     }
7740     if (!hash)
7741         PERL_HASH(hash, src, len);
7742     new_SV(sv);
7743     /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7744        changes here, update it there too.  */
7745     sv_upgrade(sv, SVt_PV);
7746     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7747     SvCUR_set(sv, len);
7748     SvLEN_set(sv, 0);
7749     SvREADONLY_on(sv);
7750     SvFAKE_on(sv);
7751     SvPOK_on(sv);
7752     if (is_utf8)
7753         SvUTF8_on(sv);
7754     if (src != orig_src)
7755         Safefree(src);
7756     return sv;
7757 }
7758
7759
7760 #if defined(PERL_IMPLICIT_CONTEXT)
7761
7762 /* pTHX_ magic can't cope with varargs, so this is a no-context
7763  * version of the main function, (which may itself be aliased to us).
7764  * Don't access this version directly.
7765  */
7766
7767 SV *
7768 Perl_newSVpvf_nocontext(const char *const pat, ...)
7769 {
7770     dTHX;
7771     register SV *sv;
7772     va_list args;
7773
7774     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7775
7776     va_start(args, pat);
7777     sv = vnewSVpvf(pat, &args);
7778     va_end(args);
7779     return sv;
7780 }
7781 #endif
7782
7783 /*
7784 =for apidoc newSVpvf
7785
7786 Creates a new SV and initializes it with the string formatted like
7787 C<sprintf>.
7788
7789 =cut
7790 */
7791
7792 SV *
7793 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7794 {
7795     register SV *sv;
7796     va_list args;
7797
7798     PERL_ARGS_ASSERT_NEWSVPVF;
7799
7800     va_start(args, pat);
7801     sv = vnewSVpvf(pat, &args);
7802     va_end(args);
7803     return sv;
7804 }
7805
7806 /* backend for newSVpvf() and newSVpvf_nocontext() */
7807
7808 SV *
7809 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7810 {
7811     dVAR;
7812     register SV *sv;
7813
7814     PERL_ARGS_ASSERT_VNEWSVPVF;
7815
7816     new_SV(sv);
7817     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7818     return sv;
7819 }
7820
7821 /*
7822 =for apidoc newSVnv
7823
7824 Creates a new SV and copies a floating point value into it.
7825 The reference count for the SV is set to 1.
7826
7827 =cut
7828 */
7829
7830 SV *
7831 Perl_newSVnv(pTHX_ const NV n)
7832 {
7833     dVAR;
7834     register SV *sv;
7835
7836     new_SV(sv);
7837     sv_setnv(sv,n);
7838     return sv;
7839 }
7840
7841 /*
7842 =for apidoc newSViv
7843
7844 Creates a new SV and copies an integer into it.  The reference count for the
7845 SV is set to 1.
7846
7847 =cut
7848 */
7849
7850 SV *
7851 Perl_newSViv(pTHX_ const IV i)
7852 {
7853     dVAR;
7854     register SV *sv;
7855
7856     new_SV(sv);
7857     sv_setiv(sv,i);
7858     return sv;
7859 }
7860
7861 /*
7862 =for apidoc newSVuv
7863
7864 Creates a new SV and copies an unsigned integer into it.
7865 The reference count for the SV is set to 1.
7866
7867 =cut
7868 */
7869
7870 SV *
7871 Perl_newSVuv(pTHX_ const UV u)
7872 {
7873     dVAR;
7874     register SV *sv;
7875
7876     new_SV(sv);
7877     sv_setuv(sv,u);
7878     return sv;
7879 }
7880
7881 /*
7882 =for apidoc newSV_type
7883
7884 Creates a new SV, of the type specified.  The reference count for the new SV
7885 is set to 1.
7886
7887 =cut
7888 */
7889
7890 SV *
7891 Perl_newSV_type(pTHX_ const svtype type)
7892 {
7893     register SV *sv;
7894
7895     new_SV(sv);
7896     sv_upgrade(sv, type);
7897     return sv;
7898 }
7899
7900 /*
7901 =for apidoc newRV_noinc
7902
7903 Creates an RV wrapper for an SV.  The reference count for the original
7904 SV is B<not> incremented.
7905
7906 =cut
7907 */
7908
7909 SV *
7910 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
7911 {
7912     dVAR;
7913     register SV *sv = newSV_type(SVt_IV);
7914
7915     PERL_ARGS_ASSERT_NEWRV_NOINC;
7916
7917     SvTEMP_off(tmpRef);
7918     SvRV_set(sv, tmpRef);
7919     SvROK_on(sv);
7920     return sv;
7921 }
7922
7923 /* newRV_inc is the official function name to use now.
7924  * newRV_inc is in fact #defined to newRV in sv.h
7925  */
7926
7927 SV *
7928 Perl_newRV(pTHX_ SV *const sv)
7929 {
7930     dVAR;
7931
7932     PERL_ARGS_ASSERT_NEWRV;
7933
7934     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
7935 }
7936
7937 /*
7938 =for apidoc newSVsv
7939
7940 Creates a new SV which is an exact duplicate of the original SV.
7941 (Uses C<sv_setsv>).
7942
7943 =cut
7944 */
7945
7946 SV *
7947 Perl_newSVsv(pTHX_ register SV *const old)
7948 {
7949     dVAR;
7950     register SV *sv;
7951
7952     if (!old)
7953         return NULL;
7954     if (SvTYPE(old) == SVTYPEMASK) {
7955         if (ckWARN_d(WARN_INTERNAL))
7956             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7957         return NULL;
7958     }
7959     new_SV(sv);
7960     /* SV_GMAGIC is the default for sv_setv()
7961        SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7962        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
7963     sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7964     return sv;
7965 }
7966
7967 /*
7968 =for apidoc sv_reset
7969
7970 Underlying implementation for the C<reset> Perl function.
7971 Note that the perl-level function is vaguely deprecated.
7972
7973 =cut
7974 */
7975
7976 void
7977 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
7978 {
7979     dVAR;
7980     char todo[PERL_UCHAR_MAX+1];
7981
7982     PERL_ARGS_ASSERT_SV_RESET;
7983
7984     if (!stash)
7985         return;
7986
7987     if (!*s) {          /* reset ?? searches */
7988         MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
7989         if (mg) {
7990             const U32 count = mg->mg_len / sizeof(PMOP**);
7991             PMOP **pmp = (PMOP**) mg->mg_ptr;
7992             PMOP *const *const end = pmp + count;
7993
7994             while (pmp < end) {
7995 #ifdef USE_ITHREADS
7996                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
7997 #else
7998                 (*pmp)->op_pmflags &= ~PMf_USED;
7999 #endif
8000                 ++pmp;
8001             }
8002         }
8003         return;
8004     }
8005
8006     /* reset variables */
8007
8008     if (!HvARRAY(stash))
8009         return;
8010
8011     Zero(todo, 256, char);
8012     while (*s) {
8013         I32 max;
8014         I32 i = (unsigned char)*s;
8015         if (s[1] == '-') {
8016             s += 2;
8017         }
8018         max = (unsigned char)*s++;
8019         for ( ; i <= max; i++) {
8020             todo[i] = 1;
8021         }
8022         for (i = 0; i <= (I32) HvMAX(stash); i++) {
8023             HE *entry;
8024             for (entry = HvARRAY(stash)[i];
8025                  entry;
8026                  entry = HeNEXT(entry))
8027             {
8028                 register GV *gv;
8029                 register SV *sv;
8030
8031                 if (!todo[(U8)*HeKEY(entry)])
8032                     continue;
8033                 gv = MUTABLE_GV(HeVAL(entry));
8034                 sv = GvSV(gv);
8035                 if (sv) {
8036                     if (SvTHINKFIRST(sv)) {
8037                         if (!SvREADONLY(sv) && SvROK(sv))
8038                             sv_unref(sv);
8039                         /* XXX Is this continue a bug? Why should THINKFIRST
8040                            exempt us from resetting arrays and hashes?  */
8041                         continue;
8042                     }
8043                     SvOK_off(sv);
8044                     if (SvTYPE(sv) >= SVt_PV) {
8045                         SvCUR_set(sv, 0);
8046                         if (SvPVX_const(sv) != NULL)
8047                             *SvPVX(sv) = '\0';
8048                         SvTAINT(sv);
8049                     }
8050                 }
8051                 if (GvAV(gv)) {
8052                     av_clear(GvAV(gv));
8053                 }
8054                 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8055 #if defined(VMS)
8056                     Perl_die(aTHX_ "Can't reset %%ENV on this system");
8057 #else /* ! VMS */
8058                     hv_clear(GvHV(gv));
8059 #  if defined(USE_ENVIRON_ARRAY)
8060                     if (gv == PL_envgv)
8061                         my_clearenv();
8062 #  endif /* USE_ENVIRON_ARRAY */
8063 #endif /* VMS */
8064                 }
8065             }
8066         }
8067     }
8068 }
8069
8070 /*
8071 =for apidoc sv_2io
8072
8073 Using various gambits, try to get an IO from an SV: the IO slot if its a
8074 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8075 named after the PV if we're a string.
8076
8077 =cut
8078 */
8079
8080 IO*
8081 Perl_sv_2io(pTHX_ SV *const sv)
8082 {
8083     IO* io;
8084     GV* gv;
8085
8086     PERL_ARGS_ASSERT_SV_2IO;
8087
8088     switch (SvTYPE(sv)) {
8089     case SVt_PVIO:
8090         io = MUTABLE_IO(sv);
8091         break;
8092     case SVt_PVGV:
8093         if (isGV_with_GP(sv)) {
8094             gv = MUTABLE_GV(sv);
8095             io = GvIO(gv);
8096             if (!io)
8097                 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8098             break;
8099         }
8100         /* FALL THROUGH */
8101     default:
8102         if (!SvOK(sv))
8103             Perl_croak(aTHX_ PL_no_usym, "filehandle");
8104         if (SvROK(sv))
8105             return sv_2io(SvRV(sv));
8106         gv = gv_fetchsv(sv, 0, SVt_PVIO);
8107         if (gv)
8108             io = GvIO(gv);
8109         else
8110             io = 0;
8111         if (!io)
8112             Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8113         break;
8114     }
8115     return io;
8116 }
8117
8118 /*
8119 =for apidoc sv_2cv
8120
8121 Using various gambits, try to get a CV from an SV; in addition, try if
8122 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8123 The flags in C<lref> are passed to sv_fetchsv.
8124
8125 =cut
8126 */
8127
8128 CV *
8129 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8130 {
8131     dVAR;
8132     GV *gv = NULL;
8133     CV *cv = NULL;
8134
8135     PERL_ARGS_ASSERT_SV_2CV;
8136
8137     if (!sv) {
8138         *st = NULL;
8139         *gvp = NULL;
8140         return NULL;
8141     }
8142     switch (SvTYPE(sv)) {
8143     case SVt_PVCV:
8144         *st = CvSTASH(sv);
8145         *gvp = NULL;
8146         return MUTABLE_CV(sv);
8147     case SVt_PVHV:
8148     case SVt_PVAV:
8149         *st = NULL;
8150         *gvp = NULL;
8151         return NULL;
8152     case SVt_PVGV:
8153         if (isGV_with_GP(sv)) {
8154             gv = MUTABLE_GV(sv);
8155             *gvp = gv;
8156             *st = GvESTASH(gv);
8157             goto fix_gv;
8158         }
8159         /* FALL THROUGH */
8160
8161     default:
8162         if (SvROK(sv)) {
8163             SV * const *sp = &sv;       /* Used in tryAMAGICunDEREF macro. */
8164             SvGETMAGIC(sv);
8165             tryAMAGICunDEREF(to_cv);
8166
8167             sv = SvRV(sv);
8168             if (SvTYPE(sv) == SVt_PVCV) {
8169                 cv = MUTABLE_CV(sv);
8170                 *gvp = NULL;
8171                 *st = CvSTASH(cv);
8172                 return cv;
8173             }
8174             else if(isGV_with_GP(sv))
8175                 gv = MUTABLE_GV(sv);
8176             else
8177                 Perl_croak(aTHX_ "Not a subroutine reference");
8178         }
8179         else if (isGV_with_GP(sv)) {
8180             SvGETMAGIC(sv);
8181             gv = MUTABLE_GV(sv);
8182         }
8183         else
8184             gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8185         *gvp = gv;
8186         if (!gv) {
8187             *st = NULL;
8188             return NULL;
8189         }
8190         /* Some flags to gv_fetchsv mean don't really create the GV  */
8191         if (!isGV_with_GP(gv)) {
8192             *st = NULL;
8193             return NULL;
8194         }
8195         *st = GvESTASH(gv);
8196     fix_gv:
8197         if (lref && !GvCVu(gv)) {
8198             SV *tmpsv;
8199             ENTER;
8200             tmpsv = newSV(0);
8201             gv_efullname3(tmpsv, gv, NULL);
8202             /* XXX this is probably not what they think they're getting.
8203              * It has the same effect as "sub name;", i.e. just a forward
8204              * declaration! */
8205             newSUB(start_subparse(FALSE, 0),
8206                    newSVOP(OP_CONST, 0, tmpsv),
8207                    NULL, NULL);
8208             LEAVE;
8209             if (!GvCVu(gv))
8210                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8211                            SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8212         }
8213         return GvCVu(gv);
8214     }
8215 }
8216
8217 /*
8218 =for apidoc sv_true
8219
8220 Returns true if the SV has a true value by Perl's rules.
8221 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8222 instead use an in-line version.
8223
8224 =cut
8225 */
8226
8227 I32
8228 Perl_sv_true(pTHX_ register SV *const sv)
8229 {
8230     if (!sv)
8231         return 0;
8232     if (SvPOK(sv)) {
8233         register const XPV* const tXpv = (XPV*)SvANY(sv);
8234         if (tXpv &&
8235                 (tXpv->xpv_cur > 1 ||
8236                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8237             return 1;
8238         else
8239             return 0;
8240     }
8241     else {
8242         if (SvIOK(sv))
8243             return SvIVX(sv) != 0;
8244         else {
8245             if (SvNOK(sv))
8246                 return SvNVX(sv) != 0.0;
8247             else
8248                 return sv_2bool(sv);
8249         }
8250     }
8251 }
8252
8253 /*
8254 =for apidoc sv_pvn_force
8255
8256 Get a sensible string out of the SV somehow.
8257 A private implementation of the C<SvPV_force> macro for compilers which
8258 can't cope with complex macro expressions. Always use the macro instead.
8259
8260 =for apidoc sv_pvn_force_flags
8261
8262 Get a sensible string out of the SV somehow.
8263 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8264 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8265 implemented in terms of this function.
8266 You normally want to use the various wrapper macros instead: see
8267 C<SvPV_force> and C<SvPV_force_nomg>
8268
8269 =cut
8270 */
8271
8272 char *
8273 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8274 {
8275     dVAR;
8276
8277     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8278
8279     if (SvTHINKFIRST(sv) && !SvROK(sv))
8280         sv_force_normal_flags(sv, 0);
8281
8282     if (SvPOK(sv)) {
8283         if (lp)
8284             *lp = SvCUR(sv);
8285     }
8286     else {
8287         char *s;
8288         STRLEN len;
8289
8290         if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8291             const char * const ref = sv_reftype(sv,0);
8292             if (PL_op)
8293                 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8294                            ref, OP_NAME(PL_op));
8295             else
8296                 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8297         }
8298         if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8299             || isGV_with_GP(sv))
8300             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8301                 OP_NAME(PL_op));
8302         s = sv_2pv_flags(sv, &len, flags);
8303         if (lp)
8304             *lp = len;
8305
8306         if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
8307             if (SvROK(sv))
8308                 sv_unref(sv);
8309             SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
8310             SvGROW(sv, len + 1);
8311             Move(s,SvPVX(sv),len,char);
8312             SvCUR_set(sv, len);
8313             SvPVX(sv)[len] = '\0';
8314         }
8315         if (!SvPOK(sv)) {
8316             SvPOK_on(sv);               /* validate pointer */
8317             SvTAINT(sv);
8318             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8319                                   PTR2UV(sv),SvPVX_const(sv)));
8320         }
8321     }
8322     return SvPVX_mutable(sv);
8323 }
8324
8325 /*
8326 =for apidoc sv_pvbyten_force
8327
8328 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8329
8330 =cut
8331 */
8332
8333 char *
8334 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8335 {
8336     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8337
8338     sv_pvn_force(sv,lp);
8339     sv_utf8_downgrade(sv,0);
8340     *lp = SvCUR(sv);
8341     return SvPVX(sv);
8342 }
8343
8344 /*
8345 =for apidoc sv_pvutf8n_force
8346
8347 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8348
8349 =cut
8350 */
8351
8352 char *
8353 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8354 {
8355     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8356
8357     sv_pvn_force(sv,lp);
8358     sv_utf8_upgrade(sv);
8359     *lp = SvCUR(sv);
8360     return SvPVX(sv);
8361 }
8362
8363 /*
8364 =for apidoc sv_reftype
8365
8366 Returns a string describing what the SV is a reference to.
8367
8368 =cut
8369 */
8370
8371 const char *
8372 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8373 {
8374     PERL_ARGS_ASSERT_SV_REFTYPE;
8375
8376     /* The fact that I don't need to downcast to char * everywhere, only in ?:
8377        inside return suggests a const propagation bug in g++.  */
8378     if (ob && SvOBJECT(sv)) {
8379         char * const name = HvNAME_get(SvSTASH(sv));
8380         return name ? name : (char *) "__ANON__";
8381     }
8382     else {
8383         switch (SvTYPE(sv)) {
8384         case SVt_NULL:
8385         case SVt_IV:
8386         case SVt_NV:
8387         case SVt_PV:
8388         case SVt_PVIV:
8389         case SVt_PVNV:
8390         case SVt_PVMG:
8391                                 if (SvVOK(sv))
8392                                     return "VSTRING";
8393                                 if (SvROK(sv))
8394                                     return "REF";
8395                                 else
8396                                     return "SCALAR";
8397
8398         case SVt_PVLV:          return (char *)  (SvROK(sv) ? "REF"
8399                                 /* tied lvalues should appear to be
8400                                  * scalars for backwards compatitbility */
8401                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8402                                     ? "SCALAR" : "LVALUE");
8403         case SVt_PVAV:          return "ARRAY";
8404         case SVt_PVHV:          return "HASH";
8405         case SVt_PVCV:          return "CODE";
8406         case SVt_PVGV:          return (char *) (isGV_with_GP(sv)
8407                                     ? "GLOB" : "SCALAR");
8408         case SVt_PVFM:          return "FORMAT";
8409         case SVt_PVIO:          return "IO";
8410         case SVt_BIND:          return "BIND";
8411         case SVt_REGEXP:        return "REGEXP";
8412         default:                return "UNKNOWN";
8413         }
8414     }
8415 }
8416
8417 /*
8418 =for apidoc sv_isobject
8419
8420 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8421 object.  If the SV is not an RV, or if the object is not blessed, then this
8422 will return false.
8423
8424 =cut
8425 */
8426
8427 int
8428 Perl_sv_isobject(pTHX_ SV *sv)
8429 {
8430     if (!sv)
8431         return 0;
8432     SvGETMAGIC(sv);
8433     if (!SvROK(sv))
8434         return 0;
8435     sv = SvRV(sv);
8436     if (!SvOBJECT(sv))
8437         return 0;
8438     return 1;
8439 }
8440
8441 /*
8442 =for apidoc sv_isa
8443
8444 Returns a boolean indicating whether the SV is blessed into the specified
8445 class.  This does not check for subtypes; use C<sv_derived_from> to verify
8446 an inheritance relationship.
8447
8448 =cut
8449 */
8450
8451 int
8452 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8453 {
8454     const char *hvname;
8455
8456     PERL_ARGS_ASSERT_SV_ISA;
8457
8458     if (!sv)
8459         return 0;
8460     SvGETMAGIC(sv);
8461     if (!SvROK(sv))
8462         return 0;
8463     sv = SvRV(sv);
8464     if (!SvOBJECT(sv))
8465         return 0;
8466     hvname = HvNAME_get(SvSTASH(sv));
8467     if (!hvname)
8468         return 0;
8469
8470     return strEQ(hvname, name);
8471 }
8472
8473 /*
8474 =for apidoc newSVrv
8475
8476 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
8477 it will be upgraded to one.  If C<classname> is non-null then the new SV will
8478 be blessed in the specified package.  The new SV is returned and its
8479 reference count is 1.
8480
8481 =cut
8482 */
8483
8484 SV*
8485 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8486 {
8487     dVAR;
8488     SV *sv;
8489
8490     PERL_ARGS_ASSERT_NEWSVRV;
8491
8492     new_SV(sv);
8493
8494     SV_CHECK_THINKFIRST_COW_DROP(rv);
8495     (void)SvAMAGIC_off(rv);
8496
8497     if (SvTYPE(rv) >= SVt_PVMG) {
8498         const U32 refcnt = SvREFCNT(rv);
8499         SvREFCNT(rv) = 0;
8500         sv_clear(rv);
8501         SvFLAGS(rv) = 0;
8502         SvREFCNT(rv) = refcnt;
8503
8504         sv_upgrade(rv, SVt_IV);
8505     } else if (SvROK(rv)) {
8506         SvREFCNT_dec(SvRV(rv));
8507     } else {
8508         prepare_SV_for_RV(rv);
8509     }
8510
8511     SvOK_off(rv);
8512     SvRV_set(rv, sv);
8513     SvROK_on(rv);
8514
8515     if (classname) {
8516         HV* const stash = gv_stashpv(classname, GV_ADD);
8517         (void)sv_bless(rv, stash);
8518     }
8519     return sv;
8520 }
8521
8522 /*
8523 =for apidoc sv_setref_pv
8524
8525 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
8526 argument will be upgraded to an RV.  That RV will be modified to point to
8527 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8528 into the SV.  The C<classname> argument indicates the package for the
8529 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8530 will have a reference count of 1, and the RV will be returned.
8531
8532 Do not use with other Perl types such as HV, AV, SV, CV, because those
8533 objects will become corrupted by the pointer copy process.
8534
8535 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8536
8537 =cut
8538 */
8539
8540 SV*
8541 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8542 {
8543     dVAR;
8544
8545     PERL_ARGS_ASSERT_SV_SETREF_PV;
8546
8547     if (!pv) {
8548         sv_setsv(rv, &PL_sv_undef);
8549         SvSETMAGIC(rv);
8550     }
8551     else
8552         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8553     return rv;
8554 }
8555
8556 /*
8557 =for apidoc sv_setref_iv
8558
8559 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
8560 argument will be upgraded to an RV.  That RV will be modified to point to
8561 the new SV.  The C<classname> argument indicates the package for the
8562 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8563 will have a reference count of 1, and the RV will be returned.
8564
8565 =cut
8566 */
8567
8568 SV*
8569 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8570 {
8571     PERL_ARGS_ASSERT_SV_SETREF_IV;
8572
8573     sv_setiv(newSVrv(rv,classname), iv);
8574     return rv;
8575 }
8576
8577 /*
8578 =for apidoc sv_setref_uv
8579
8580 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
8581 argument will be upgraded to an RV.  That RV will be modified to point to
8582 the new SV.  The C<classname> argument indicates the package for the
8583 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8584 will have a reference count of 1, and the RV will be returned.
8585
8586 =cut
8587 */
8588
8589 SV*
8590 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8591 {
8592     PERL_ARGS_ASSERT_SV_SETREF_UV;
8593
8594     sv_setuv(newSVrv(rv,classname), uv);
8595     return rv;
8596 }
8597
8598 /*
8599 =for apidoc sv_setref_nv
8600
8601 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
8602 argument will be upgraded to an RV.  That RV will be modified to point to
8603 the new SV.  The C<classname> argument indicates the package for the
8604 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8605 will have a reference count of 1, and the RV will be returned.
8606
8607 =cut
8608 */
8609
8610 SV*
8611 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8612 {
8613     PERL_ARGS_ASSERT_SV_SETREF_NV;
8614
8615     sv_setnv(newSVrv(rv,classname), nv);
8616     return rv;
8617 }
8618
8619 /*
8620 =for apidoc sv_setref_pvn
8621
8622 Copies a string into a new SV, optionally blessing the SV.  The length of the
8623 string must be specified with C<n>.  The C<rv> argument will be upgraded to
8624 an RV.  That RV will be modified to point to the new SV.  The C<classname>
8625 argument indicates the package for the blessing.  Set C<classname> to
8626 C<NULL> to avoid the blessing.  The new SV will have a reference count
8627 of 1, and the RV will be returned.
8628
8629 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8630
8631 =cut
8632 */
8633
8634 SV*
8635 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8636                    const char *const pv, const STRLEN n)
8637 {
8638     PERL_ARGS_ASSERT_SV_SETREF_PVN;
8639
8640     sv_setpvn(newSVrv(rv,classname), pv, n);
8641     return rv;
8642 }
8643
8644 /*
8645 =for apidoc sv_bless
8646
8647 Blesses an SV into a specified package.  The SV must be an RV.  The package
8648 must be designated by its stash (see C<gv_stashpv()>).  The reference count
8649 of the SV is unaffected.
8650
8651 =cut
8652 */
8653
8654 SV*
8655 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8656 {
8657     dVAR;
8658     SV *tmpRef;
8659
8660     PERL_ARGS_ASSERT_SV_BLESS;
8661
8662     if (!SvROK(sv))
8663         Perl_croak(aTHX_ "Can't bless non-reference value");
8664     tmpRef = SvRV(sv);
8665     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8666         if (SvIsCOW(tmpRef))
8667             sv_force_normal_flags(tmpRef, 0);
8668         if (SvREADONLY(tmpRef))
8669             Perl_croak(aTHX_ "%s", PL_no_modify);
8670         if (SvOBJECT(tmpRef)) {
8671             if (SvTYPE(tmpRef) != SVt_PVIO)
8672                 --PL_sv_objcount;
8673             SvREFCNT_dec(SvSTASH(tmpRef));
8674         }
8675     }
8676     SvOBJECT_on(tmpRef);
8677     if (SvTYPE(tmpRef) != SVt_PVIO)
8678         ++PL_sv_objcount;
8679     SvUPGRADE(tmpRef, SVt_PVMG);
8680     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8681
8682     if (Gv_AMG(stash))
8683         SvAMAGIC_on(sv);
8684     else
8685         (void)SvAMAGIC_off(sv);
8686
8687     if(SvSMAGICAL(tmpRef))
8688         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8689             mg_set(tmpRef);
8690
8691
8692
8693     return sv;
8694 }
8695
8696 /* Downgrades a PVGV to a PVMG.
8697  */
8698
8699 STATIC void
8700 S_sv_unglob(pTHX_ SV *const sv)
8701 {
8702     dVAR;
8703     void *xpvmg;
8704     HV *stash;
8705     SV * const temp = sv_newmortal();
8706
8707     PERL_ARGS_ASSERT_SV_UNGLOB;
8708
8709     assert(SvTYPE(sv) == SVt_PVGV);
8710     SvFAKE_off(sv);
8711     gv_efullname3(temp, MUTABLE_GV(sv), "*");
8712
8713     if (GvGP(sv)) {
8714         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
8715            && HvNAME_get(stash))
8716             mro_method_changed_in(stash);
8717         gp_free(MUTABLE_GV(sv));
8718     }
8719     if (GvSTASH(sv)) {
8720         sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
8721         GvSTASH(sv) = NULL;
8722     }
8723     GvMULTI_off(sv);
8724     if (GvNAME_HEK(sv)) {
8725         unshare_hek(GvNAME_HEK(sv));
8726     }
8727     isGV_with_GP_off(sv);
8728
8729     /* need to keep SvANY(sv) in the right arena */
8730     xpvmg = new_XPVMG();
8731     StructCopy(SvANY(sv), xpvmg, XPVMG);
8732     del_XPVGV(SvANY(sv));
8733     SvANY(sv) = xpvmg;
8734
8735     SvFLAGS(sv) &= ~SVTYPEMASK;
8736     SvFLAGS(sv) |= SVt_PVMG;
8737
8738     /* Intentionally not calling any local SET magic, as this isn't so much a
8739        set operation as merely an internal storage change.  */
8740     sv_setsv_flags(sv, temp, 0);
8741 }
8742
8743 /*
8744 =for apidoc sv_unref_flags
8745
8746 Unsets the RV status of the SV, and decrements the reference count of
8747 whatever was being referenced by the RV.  This can almost be thought of
8748 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
8749 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8750 (otherwise the decrementing is conditional on the reference count being
8751 different from one or the reference being a readonly SV).
8752 See C<SvROK_off>.
8753
8754 =cut
8755 */
8756
8757 void
8758 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8759 {
8760     SV* const target = SvRV(ref);
8761
8762     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8763
8764     if (SvWEAKREF(ref)) {
8765         sv_del_backref(target, ref);
8766         SvWEAKREF_off(ref);
8767         SvRV_set(ref, NULL);
8768         return;
8769     }
8770     SvRV_set(ref, NULL);
8771     SvROK_off(ref);
8772     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8773        assigned to as BEGIN {$a = \"Foo"} will fail.  */
8774     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8775         SvREFCNT_dec(target);
8776     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8777         sv_2mortal(target);     /* Schedule for freeing later */
8778 }
8779
8780 /*
8781 =for apidoc sv_untaint
8782
8783 Untaint an SV. Use C<SvTAINTED_off> instead.
8784 =cut
8785 */
8786
8787 void
8788 Perl_sv_untaint(pTHX_ SV *const sv)
8789 {
8790     PERL_ARGS_ASSERT_SV_UNTAINT;
8791
8792     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8793         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8794         if (mg)
8795             mg->mg_len &= ~1;
8796     }
8797 }
8798
8799 /*
8800 =for apidoc sv_tainted
8801
8802 Test an SV for taintedness. Use C<SvTAINTED> instead.
8803 =cut
8804 */
8805
8806 bool
8807 Perl_sv_tainted(pTHX_ SV *const sv)
8808 {
8809     PERL_ARGS_ASSERT_SV_TAINTED;
8810
8811     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8812         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8813         if (mg && (mg->mg_len & 1) )
8814             return TRUE;
8815     }
8816     return FALSE;
8817 }
8818
8819 /*
8820 =for apidoc sv_setpviv
8821
8822 Copies an integer into the given SV, also updating its string value.
8823 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
8824
8825 =cut
8826 */
8827
8828 void
8829 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8830 {
8831     char buf[TYPE_CHARS(UV)];
8832     char *ebuf;
8833     char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8834
8835     PERL_ARGS_ASSERT_SV_SETPVIV;
8836
8837     sv_setpvn(sv, ptr, ebuf - ptr);
8838 }
8839
8840 /*
8841 =for apidoc sv_setpviv_mg
8842
8843 Like C<sv_setpviv>, but also handles 'set' magic.
8844
8845 =cut
8846 */
8847
8848 void
8849 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8850 {
8851     PERL_ARGS_ASSERT_SV_SETPVIV_MG;
8852
8853     sv_setpviv(sv, iv);
8854     SvSETMAGIC(sv);
8855 }
8856
8857 #if defined(PERL_IMPLICIT_CONTEXT)
8858
8859 /* pTHX_ magic can't cope with varargs, so this is a no-context
8860  * version of the main function, (which may itself be aliased to us).
8861  * Don't access this version directly.
8862  */
8863
8864 void
8865 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
8866 {
8867     dTHX;
8868     va_list args;
8869
8870     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
8871
8872     va_start(args, pat);
8873     sv_vsetpvf(sv, pat, &args);
8874     va_end(args);
8875 }
8876
8877 /* pTHX_ magic can't cope with varargs, so this is a no-context
8878  * version of the main function, (which may itself be aliased to us).
8879  * Don't access this version directly.
8880  */
8881
8882 void
8883 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8884 {
8885     dTHX;
8886     va_list args;
8887
8888     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
8889
8890     va_start(args, pat);
8891     sv_vsetpvf_mg(sv, pat, &args);
8892     va_end(args);
8893 }
8894 #endif
8895
8896 /*
8897 =for apidoc sv_setpvf
8898
8899 Works like C<sv_catpvf> but copies the text into the SV instead of
8900 appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
8901
8902 =cut
8903 */
8904
8905 void
8906 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
8907 {
8908     va_list args;
8909
8910     PERL_ARGS_ASSERT_SV_SETPVF;
8911
8912     va_start(args, pat);
8913     sv_vsetpvf(sv, pat, &args);
8914     va_end(args);
8915 }
8916
8917 /*
8918 =for apidoc sv_vsetpvf
8919
8920 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8921 appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
8922
8923 Usually used via its frontend C<sv_setpvf>.
8924
8925 =cut
8926 */
8927
8928 void
8929 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8930 {
8931     PERL_ARGS_ASSERT_SV_VSETPVF;
8932
8933     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8934 }
8935
8936 /*
8937 =for apidoc sv_setpvf_mg
8938
8939 Like C<sv_setpvf>, but also handles 'set' magic.
8940
8941 =cut
8942 */
8943
8944 void
8945 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8946 {
8947     va_list args;
8948
8949     PERL_ARGS_ASSERT_SV_SETPVF_MG;
8950
8951     va_start(args, pat);
8952     sv_vsetpvf_mg(sv, pat, &args);
8953     va_end(args);
8954 }
8955
8956 /*
8957 =for apidoc sv_vsetpvf_mg
8958
8959 Like C<sv_vsetpvf>, but also handles 'set' magic.
8960
8961 Usually used via its frontend C<sv_setpvf_mg>.
8962
8963 =cut
8964 */
8965
8966 void
8967 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8968 {
8969     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
8970
8971     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8972     SvSETMAGIC(sv);
8973 }
8974
8975 #if defined(PERL_IMPLICIT_CONTEXT)
8976
8977 /* pTHX_ magic can't cope with varargs, so this is a no-context
8978  * version of the main function, (which may itself be aliased to us).
8979  * Don't access this version directly.
8980  */
8981
8982 void
8983 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
8984 {
8985     dTHX;
8986     va_list args;
8987
8988     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
8989
8990     va_start(args, pat);
8991     sv_vcatpvf(sv, pat, &args);
8992     va_end(args);
8993 }
8994
8995 /* pTHX_ magic can't cope with varargs, so this is a no-context
8996  * version of the main function, (which may itself be aliased to us).
8997  * Don't access this version directly.
8998  */
8999
9000 void
9001 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9002 {
9003     dTHX;
9004     va_list args;
9005
9006     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9007
9008     va_start(args, pat);
9009     sv_vcatpvf_mg(sv, pat, &args);
9010     va_end(args);
9011 }
9012 #endif
9013
9014 /*
9015 =for apidoc sv_catpvf
9016
9017 Processes its arguments like C<sprintf> and appends the formatted
9018 output to an SV.  If the appended data contains "wide" characters
9019 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9020 and characters >255 formatted with %c), the original SV might get
9021 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
9022 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9023 valid UTF-8; if the original SV was bytes, the pattern should be too.
9024
9025 =cut */
9026
9027 void
9028 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9029 {
9030     va_list args;
9031
9032     PERL_ARGS_ASSERT_SV_CATPVF;
9033
9034     va_start(args, pat);
9035     sv_vcatpvf(sv, pat, &args);
9036     va_end(args);
9037 }
9038
9039 /*
9040 =for apidoc sv_vcatpvf
9041
9042 Processes its arguments like C<vsprintf> and appends the formatted output
9043 to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
9044
9045 Usually used via its frontend C<sv_catpvf>.
9046
9047 =cut
9048 */
9049
9050 void
9051 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9052 {
9053     PERL_ARGS_ASSERT_SV_VCATPVF;
9054
9055     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9056 }
9057
9058 /*
9059 =for apidoc sv_catpvf_mg
9060
9061 Like C<sv_catpvf>, but also handles 'set' magic.
9062
9063 =cut
9064 */
9065
9066 void
9067 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9068 {
9069     va_list args;
9070
9071     PERL_ARGS_ASSERT_SV_CATPVF_MG;
9072
9073     va_start(args, pat);
9074     sv_vcatpvf_mg(sv, pat, &args);
9075     va_end(args);
9076 }
9077
9078 /*
9079 =for apidoc sv_vcatpvf_mg
9080
9081 Like C<sv_vcatpvf>, but also handles 'set' magic.
9082
9083 Usually used via its frontend C<sv_catpvf_mg>.
9084
9085 =cut
9086 */
9087
9088 void
9089 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9090 {
9091     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9092
9093     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9094     SvSETMAGIC(sv);
9095 }
9096
9097 /*
9098 =for apidoc sv_vsetpvfn
9099
9100 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9101 appending it.
9102
9103 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9104
9105 =cut
9106 */
9107
9108 void
9109 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9110                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9111 {
9112     PERL_ARGS_ASSERT_SV_VSETPVFN;
9113
9114     sv_setpvs(sv, "");
9115     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9116 }
9117
9118 STATIC I32
9119 S_expect_number(pTHX_ char **const pattern)
9120 {
9121     dVAR;
9122     I32 var = 0;
9123
9124     PERL_ARGS_ASSERT_EXPECT_NUMBER;
9125
9126     switch (**pattern) {
9127     case '1': case '2': case '3':
9128     case '4': case '5': case '6':
9129     case '7': case '8': case '9':
9130         var = *(*pattern)++ - '0';
9131         while (isDIGIT(**pattern)) {
9132             const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9133             if (tmp < var)
9134                 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
9135             var = tmp;
9136         }
9137     }
9138     return var;
9139 }
9140
9141 STATIC char *
9142 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9143 {
9144     const int neg = nv < 0;
9145     UV uv;
9146
9147     PERL_ARGS_ASSERT_F0CONVERT;
9148
9149     if (neg)
9150         nv = -nv;
9151     if (nv < UV_MAX) {
9152         char *p = endbuf;
9153         nv += 0.5;
9154         uv = (UV)nv;
9155         if (uv & 1 && uv == nv)
9156             uv--;                       /* Round to even */
9157         do {
9158             const unsigned dig = uv % 10;
9159             *--p = '0' + dig;
9160         } while (uv /= 10);
9161         if (neg)
9162             *--p = '-';
9163         *len = endbuf - p;
9164         return p;
9165     }
9166     return NULL;
9167 }
9168
9169
9170 /*
9171 =for apidoc sv_vcatpvfn
9172
9173 Processes its arguments like C<vsprintf> and appends the formatted output
9174 to an SV.  Uses an array of SVs if the C style variable argument list is
9175 missing (NULL).  When running with taint checks enabled, indicates via
9176 C<maybe_tainted> if results are untrustworthy (often due to the use of
9177 locales).
9178
9179 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9180
9181 =cut
9182 */
9183
9184
9185 #define VECTORIZE_ARGS  vecsv = va_arg(*args, SV*);\
9186                         vecstr = (U8*)SvPV_const(vecsv,veclen);\
9187                         vec_utf8 = DO_UTF8(vecsv);
9188
9189 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9190
9191 void
9192 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9193                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9194 {
9195     dVAR;
9196     char *p;
9197     char *q;
9198     const char *patend;
9199     STRLEN origlen;
9200     I32 svix = 0;
9201     static const char nullstr[] = "(null)";
9202     SV *argsv = NULL;
9203     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
9204     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9205     SV *nsv = NULL;
9206     /* Times 4: a decimal digit takes more than 3 binary digits.
9207      * NV_DIG: mantissa takes than many decimal digits.
9208      * Plus 32: Playing safe. */
9209     char ebuf[IV_DIG * 4 + NV_DIG + 32];
9210     /* large enough for "%#.#f" --chip */
9211     /* what about long double NVs? --jhi */
9212
9213     PERL_ARGS_ASSERT_SV_VCATPVFN;
9214     PERL_UNUSED_ARG(maybe_tainted);
9215
9216     /* no matter what, this is a string now */
9217     (void)SvPV_force(sv, origlen);
9218
9219     /* special-case "", "%s", and "%-p" (SVf - see below) */
9220     if (patlen == 0)
9221         return;
9222     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9223         if (args) {
9224             const char * const s = va_arg(*args, char*);
9225             sv_catpv(sv, s ? s : nullstr);
9226         }
9227         else if (svix < svmax) {
9228             sv_catsv(sv, *svargs);
9229         }
9230         return;
9231     }
9232     if (args && patlen == 3 && pat[0] == '%' &&
9233                 pat[1] == '-' && pat[2] == 'p') {
9234         argsv = MUTABLE_SV(va_arg(*args, void*));
9235         sv_catsv(sv, argsv);
9236         return;
9237     }
9238
9239 #ifndef USE_LONG_DOUBLE
9240     /* special-case "%.<number>[gf]" */
9241     if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9242          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9243         unsigned digits = 0;
9244         const char *pp;
9245
9246         pp = pat + 2;
9247         while (*pp >= '0' && *pp <= '9')
9248             digits = 10 * digits + (*pp++ - '0');
9249         if (pp - pat == (int)patlen - 1) {
9250             NV nv;
9251
9252             if (svix < svmax)
9253                 nv = SvNV(*svargs);
9254             else
9255                 return;
9256             if (*pp == 'g') {
9257                 /* Add check for digits != 0 because it seems that some
9258                    gconverts are buggy in this case, and we don't yet have
9259                    a Configure test for this.  */
9260                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9261                      /* 0, point, slack */
9262                     Gconvert(nv, (int)digits, 0, ebuf);
9263                     sv_catpv(sv, ebuf);
9264                     if (*ebuf)  /* May return an empty string for digits==0 */
9265                         return;
9266                 }
9267             } else if (!digits) {
9268                 STRLEN l;
9269
9270                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9271                     sv_catpvn(sv, p, l);
9272                     return;
9273                 }
9274             }
9275         }
9276     }
9277 #endif /* !USE_LONG_DOUBLE */
9278
9279     if (!args && svix < svmax && DO_UTF8(*svargs))
9280         has_utf8 = TRUE;
9281
9282     patend = (char*)pat + patlen;
9283     for (p = (char*)pat; p < patend; p = q) {
9284         bool alt = FALSE;
9285         bool left = FALSE;
9286         bool vectorize = FALSE;
9287         bool vectorarg = FALSE;
9288         bool vec_utf8 = FALSE;
9289         char fill = ' ';
9290         char plus = 0;
9291         char intsize = 0;
9292         STRLEN width = 0;
9293         STRLEN zeros = 0;
9294         bool has_precis = FALSE;
9295         STRLEN precis = 0;
9296         const I32 osvix = svix;
9297         bool is_utf8 = FALSE;  /* is this item utf8?   */
9298 #ifdef HAS_LDBL_SPRINTF_BUG
9299         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9300            with sfio - Allen <allens@cpan.org> */
9301         bool fix_ldbl_sprintf_bug = FALSE;
9302 #endif
9303
9304         char esignbuf[4];
9305         U8 utf8buf[UTF8_MAXBYTES+1];
9306         STRLEN esignlen = 0;
9307
9308         const char *eptr = NULL;
9309         const char *fmtstart;
9310         STRLEN elen = 0;
9311         SV *vecsv = NULL;
9312         const U8 *vecstr = NULL;
9313         STRLEN veclen = 0;
9314         char c = 0;
9315         int i;
9316         unsigned base = 0;
9317         IV iv = 0;
9318         UV uv = 0;
9319         /* we need a long double target in case HAS_LONG_DOUBLE but
9320            not USE_LONG_DOUBLE
9321         */
9322 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9323         long double nv;
9324 #else
9325         NV nv;
9326 #endif
9327         STRLEN have;
9328         STRLEN need;
9329         STRLEN gap;
9330         const char *dotstr = ".";
9331         STRLEN dotstrlen = 1;
9332         I32 efix = 0; /* explicit format parameter index */
9333         I32 ewix = 0; /* explicit width index */
9334         I32 epix = 0; /* explicit precision index */
9335         I32 evix = 0; /* explicit vector index */
9336         bool asterisk = FALSE;
9337
9338         /* echo everything up to the next format specification */
9339         for (q = p; q < patend && *q != '%'; ++q) ;
9340         if (q > p) {
9341             if (has_utf8 && !pat_utf8)
9342                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9343             else
9344                 sv_catpvn(sv, p, q - p);
9345             p = q;
9346         }
9347         if (q++ >= patend)
9348             break;
9349
9350         fmtstart = q;
9351
9352 /*
9353     We allow format specification elements in this order:
9354         \d+\$              explicit format parameter index
9355         [-+ 0#]+           flags
9356         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
9357         0                  flag (as above): repeated to allow "v02"
9358         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
9359         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9360         [hlqLV]            size
9361     [%bcdefginopsuxDFOUX] format (mandatory)
9362 */
9363
9364         if (args) {
9365 /*
9366         As of perl5.9.3, printf format checking is on by default.
9367         Internally, perl uses %p formats to provide an escape to
9368         some extended formatting.  This block deals with those
9369         extensions: if it does not match, (char*)q is reset and
9370         the normal format processing code is used.
9371
9372         Currently defined extensions are:
9373                 %p              include pointer address (standard)
9374                 %-p     (SVf)   include an SV (previously %_)
9375                 %-<num>p        include an SV with precision <num>
9376                 %<num>p         reserved for future extensions
9377
9378         Robin Barker 2005-07-14
9379
9380                 %1p     (VDf)   removed.  RMB 2007-10-19
9381 */
9382             char* r = q;
9383             bool sv = FALSE;
9384             STRLEN n = 0;
9385             if (*q == '-')
9386                 sv = *q++;
9387             n = expect_number(&q);
9388             if (*q++ == 'p') {
9389                 if (sv) {                       /* SVf */
9390                     if (n) {
9391                         precis = n;
9392                         has_precis = TRUE;
9393                     }
9394                     argsv = MUTABLE_SV(va_arg(*args, void*));
9395                     eptr = SvPV_const(argsv, elen);
9396                     if (DO_UTF8(argsv))
9397                         is_utf8 = TRUE;
9398                     goto string;
9399                 }
9400                 else if (n) {
9401                     if (ckWARN_d(WARN_INTERNAL))
9402                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9403                         "internal %%<num>p might conflict with future printf extensions");
9404                 }
9405             }
9406             q = r;
9407         }
9408
9409         if ( (width = expect_number(&q)) ) {
9410             if (*q == '$') {
9411                 ++q;
9412                 efix = width;
9413             } else {
9414                 goto gotwidth;
9415             }
9416         }
9417
9418         /* FLAGS */
9419
9420         while (*q) {
9421             switch (*q) {
9422             case ' ':
9423             case '+':
9424                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9425                     q++;
9426                 else
9427                     plus = *q++;
9428                 continue;
9429
9430             case '-':
9431                 left = TRUE;
9432                 q++;
9433                 continue;
9434
9435             case '0':
9436                 fill = *q++;
9437                 continue;
9438
9439             case '#':
9440                 alt = TRUE;
9441                 q++;
9442                 continue;
9443
9444             default:
9445                 break;
9446             }
9447             break;
9448         }
9449
9450       tryasterisk:
9451         if (*q == '*') {
9452             q++;
9453             if ( (ewix = expect_number(&q)) )
9454                 if (*q++ != '$')
9455                     goto unknown;
9456             asterisk = TRUE;
9457         }
9458         if (*q == 'v') {
9459             q++;
9460             if (vectorize)
9461                 goto unknown;
9462             if ((vectorarg = asterisk)) {
9463                 evix = ewix;
9464                 ewix = 0;
9465                 asterisk = FALSE;
9466             }
9467             vectorize = TRUE;
9468             goto tryasterisk;
9469         }
9470
9471         if (!asterisk)
9472         {
9473             if( *q == '0' )
9474                 fill = *q++;
9475             width = expect_number(&q);
9476         }
9477
9478         if (vectorize) {
9479             if (vectorarg) {
9480                 if (args)
9481                     vecsv = va_arg(*args, SV*);
9482                 else if (evix) {
9483                     vecsv = (evix > 0 && evix <= svmax)
9484                         ? svargs[evix-1] : &PL_sv_undef;
9485                 } else {
9486                     vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
9487                 }
9488                 dotstr = SvPV_const(vecsv, dotstrlen);
9489                 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9490                    bad with tied or overloaded values that return UTF8.  */
9491                 if (DO_UTF8(vecsv))
9492                     is_utf8 = TRUE;
9493                 else if (has_utf8) {
9494                     vecsv = sv_mortalcopy(vecsv);
9495                     sv_utf8_upgrade(vecsv);
9496                     dotstr = SvPV_const(vecsv, dotstrlen);
9497                     is_utf8 = TRUE;
9498                 }
9499             }
9500             if (args) {
9501                 VECTORIZE_ARGS
9502             }
9503             else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9504                 vecsv = svargs[efix ? efix-1 : svix++];
9505                 vecstr = (U8*)SvPV_const(vecsv,veclen);
9506                 vec_utf8 = DO_UTF8(vecsv);
9507
9508                 /* if this is a version object, we need to convert
9509                  * back into v-string notation and then let the
9510                  * vectorize happen normally
9511                  */
9512                 if (sv_derived_from(vecsv, "version")) {
9513                     char *version = savesvpv(vecsv);
9514                     if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9515                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9516                         "vector argument not supported with alpha versions");
9517                         goto unknown;
9518                     }
9519                     vecsv = sv_newmortal();
9520                     scan_vstring(version, version + veclen, vecsv);
9521                     vecstr = (U8*)SvPV_const(vecsv, veclen);
9522                     vec_utf8 = DO_UTF8(vecsv);
9523                     Safefree(version);
9524                 }
9525             }
9526             else {
9527                 vecstr = (U8*)"";
9528                 veclen = 0;
9529             }
9530         }
9531
9532         if (asterisk) {
9533             if (args)
9534                 i = va_arg(*args, int);
9535             else
9536                 i = (ewix ? ewix <= svmax : svix < svmax) ?
9537                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9538             left |= (i < 0);
9539             width = (i < 0) ? -i : i;
9540         }
9541       gotwidth:
9542
9543         /* PRECISION */
9544
9545         if (*q == '.') {
9546             q++;
9547             if (*q == '*') {
9548                 q++;
9549                 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9550                     goto unknown;
9551                 /* XXX: todo, support specified precision parameter */
9552                 if (epix)
9553                     goto unknown;
9554                 if (args)
9555                     i = va_arg(*args, int);
9556                 else
9557                     i = (ewix ? ewix <= svmax : svix < svmax)
9558                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9559                 precis = i;
9560                 has_precis = !(i < 0);
9561             }
9562             else {
9563                 precis = 0;
9564                 while (isDIGIT(*q))
9565                     precis = precis * 10 + (*q++ - '0');
9566                 has_precis = TRUE;
9567             }
9568         }
9569
9570         /* SIZE */
9571
9572         switch (*q) {
9573 #ifdef WIN32
9574         case 'I':                       /* Ix, I32x, and I64x */
9575 #  ifdef WIN64
9576             if (q[1] == '6' && q[2] == '4') {
9577                 q += 3;
9578                 intsize = 'q';
9579                 break;
9580             }
9581 #  endif
9582             if (q[1] == '3' && q[2] == '2') {
9583                 q += 3;
9584                 break;
9585             }
9586 #  ifdef WIN64
9587             intsize = 'q';
9588 #  endif
9589             q++;
9590             break;
9591 #endif
9592 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9593         case 'L':                       /* Ld */
9594             /*FALLTHROUGH*/
9595 #ifdef HAS_QUAD
9596         case 'q':                       /* qd */
9597 #endif
9598             intsize = 'q';
9599             q++;
9600             break;
9601 #endif
9602         case 'l':
9603 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9604             if (*(q + 1) == 'l') {      /* lld, llf */
9605                 intsize = 'q';
9606                 q += 2;
9607                 break;
9608              }
9609 #endif
9610             /*FALLTHROUGH*/
9611         case 'h':
9612             /*FALLTHROUGH*/
9613         case 'V':
9614             intsize = *q++;
9615             break;
9616         }
9617
9618         /* CONVERSION */
9619
9620         if (*q == '%') {
9621             eptr = q++;
9622             elen = 1;
9623             if (vectorize) {
9624                 c = '%';
9625                 goto unknown;
9626             }
9627             goto string;
9628         }
9629
9630         if (!vectorize && !args) {
9631             if (efix) {
9632                 const I32 i = efix-1;
9633                 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
9634             } else {
9635                 argsv = (svix >= 0 && svix < svmax)
9636                     ? svargs[svix++] : &PL_sv_undef;
9637             }
9638         }
9639
9640         switch (c = *q++) {
9641
9642             /* STRINGS */
9643
9644         case 'c':
9645             if (vectorize)
9646                 goto unknown;
9647             uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9648             if ((uv > 255 ||
9649                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9650                 && !IN_BYTES) {
9651                 eptr = (char*)utf8buf;
9652                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9653                 is_utf8 = TRUE;
9654             }
9655             else {
9656                 c = (char)uv;
9657                 eptr = &c;
9658                 elen = 1;
9659             }
9660             goto string;
9661
9662         case 's':
9663             if (vectorize)
9664                 goto unknown;
9665             if (args) {
9666                 eptr = va_arg(*args, char*);
9667                 if (eptr)
9668                     elen = strlen(eptr);
9669                 else {
9670                     eptr = (char *)nullstr;
9671                     elen = sizeof nullstr - 1;
9672                 }
9673             }
9674             else {
9675                 eptr = SvPV_const(argsv, elen);
9676                 if (DO_UTF8(argsv)) {
9677                     STRLEN old_precis = precis;
9678                     if (has_precis && precis < elen) {
9679                         STRLEN ulen = sv_len_utf8(argsv);
9680                         I32 p = precis > ulen ? ulen : precis;
9681                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9682                         precis = p;
9683                     }
9684                     if (width) { /* fudge width (can't fudge elen) */
9685                         if (has_precis && precis < elen)
9686                             width += precis - old_precis;
9687                         else
9688                             width += elen - sv_len_utf8(argsv);
9689                     }
9690                     is_utf8 = TRUE;
9691                 }
9692             }
9693
9694         string:
9695             if (has_precis && precis < elen)
9696                 elen = precis;
9697             break;
9698
9699             /* INTEGERS */
9700
9701         case 'p':
9702             if (alt || vectorize)
9703                 goto unknown;
9704             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9705             base = 16;
9706             goto integer;
9707
9708         case 'D':
9709 #ifdef IV_IS_QUAD
9710             intsize = 'q';
9711 #else
9712             intsize = 'l';
9713 #endif
9714             /*FALLTHROUGH*/
9715         case 'd':
9716         case 'i':
9717 #if vdNUMBER
9718         format_vd:
9719 #endif
9720             if (vectorize) {
9721                 STRLEN ulen;
9722                 if (!veclen)
9723                     continue;
9724                 if (vec_utf8)
9725                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9726                                         UTF8_ALLOW_ANYUV);
9727                 else {
9728                     uv = *vecstr;
9729                     ulen = 1;
9730                 }
9731                 vecstr += ulen;
9732                 veclen -= ulen;
9733                 if (plus)
9734                      esignbuf[esignlen++] = plus;
9735             }
9736             else if (args) {
9737                 switch (intsize) {
9738                 case 'h':       iv = (short)va_arg(*args, int); break;
9739                 case 'l':       iv = va_arg(*args, long); break;
9740                 case 'V':       iv = va_arg(*args, IV); break;
9741                 default:        iv = va_arg(*args, int); break;
9742                 case 'q':
9743 #ifdef HAS_QUAD
9744                                 iv = va_arg(*args, Quad_t); break;
9745 #else
9746                                 goto unknown;
9747 #endif
9748                 }
9749             }
9750             else {
9751                 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9752                 switch (intsize) {
9753                 case 'h':       iv = (short)tiv; break;
9754                 case 'l':       iv = (long)tiv; break;
9755                 case 'V':
9756                 default:        iv = tiv; break;
9757                 case 'q':
9758 #ifdef HAS_QUAD
9759                                 iv = (Quad_t)tiv; break;
9760 #else
9761                                 goto unknown;
9762 #endif
9763                 }
9764             }
9765             if ( !vectorize )   /* we already set uv above */
9766             {
9767                 if (iv >= 0) {
9768                     uv = iv;
9769                     if (plus)
9770                         esignbuf[esignlen++] = plus;
9771                 }
9772                 else {
9773                     uv = -iv;
9774                     esignbuf[esignlen++] = '-';
9775                 }
9776             }
9777             base = 10;
9778             goto integer;
9779
9780         case 'U':
9781 #ifdef IV_IS_QUAD
9782             intsize = 'q';
9783 #else
9784             intsize = 'l';
9785 #endif
9786             /*FALLTHROUGH*/
9787         case 'u':
9788             base = 10;
9789             goto uns_integer;
9790
9791         case 'B':
9792         case 'b':
9793             base = 2;
9794             goto uns_integer;
9795
9796         case 'O':
9797 #ifdef IV_IS_QUAD
9798             intsize = 'q';
9799 #else
9800             intsize = 'l';
9801 #endif
9802             /*FALLTHROUGH*/
9803         case 'o':
9804             base = 8;
9805             goto uns_integer;
9806
9807         case 'X':
9808         case 'x':
9809             base = 16;
9810
9811         uns_integer:
9812             if (vectorize) {
9813                 STRLEN ulen;
9814         vector:
9815                 if (!veclen)
9816                     continue;
9817                 if (vec_utf8)
9818                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9819                                         UTF8_ALLOW_ANYUV);
9820                 else {
9821                     uv = *vecstr;
9822                     ulen = 1;
9823                 }
9824                 vecstr += ulen;
9825                 veclen -= ulen;
9826             }
9827             else if (args) {
9828                 switch (intsize) {
9829                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
9830                 case 'l':  uv = va_arg(*args, unsigned long); break;
9831                 case 'V':  uv = va_arg(*args, UV); break;
9832                 default:   uv = va_arg(*args, unsigned); break;
9833                 case 'q':
9834 #ifdef HAS_QUAD
9835                            uv = va_arg(*args, Uquad_t); break;
9836 #else
9837                            goto unknown;
9838 #endif
9839                 }
9840             }
9841             else {
9842                 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9843                 switch (intsize) {
9844                 case 'h':       uv = (unsigned short)tuv; break;
9845                 case 'l':       uv = (unsigned long)tuv; break;
9846                 case 'V':
9847                 default:        uv = tuv; break;
9848                 case 'q':
9849 #ifdef HAS_QUAD
9850                                 uv = (Uquad_t)tuv; break;
9851 #else
9852                                 goto unknown;
9853 #endif
9854                 }
9855             }
9856
9857         integer:
9858             {
9859                 char *ptr = ebuf + sizeof ebuf;
9860                 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
9861                 zeros = 0;
9862
9863                 switch (base) {
9864                     unsigned dig;
9865                 case 16:
9866                     p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
9867                     do {
9868                         dig = uv & 15;
9869                         *--ptr = p[dig];
9870                     } while (uv >>= 4);
9871                     if (tempalt) {
9872                         esignbuf[esignlen++] = '0';
9873                         esignbuf[esignlen++] = c;  /* 'x' or 'X' */
9874                     }
9875                     break;
9876                 case 8:
9877                     do {
9878                         dig = uv & 7;
9879                         *--ptr = '0' + dig;
9880                     } while (uv >>= 3);
9881                     if (alt && *ptr != '0')
9882                         *--ptr = '0';
9883                     break;
9884                 case 2:
9885                     do {
9886                         dig = uv & 1;
9887                         *--ptr = '0' + dig;
9888                     } while (uv >>= 1);
9889                     if (tempalt) {
9890                         esignbuf[esignlen++] = '0';
9891                         esignbuf[esignlen++] = c;
9892                     }
9893                     break;
9894                 default:                /* it had better be ten or less */
9895                     do {
9896                         dig = uv % base;
9897                         *--ptr = '0' + dig;
9898                     } while (uv /= base);
9899                     break;
9900                 }
9901                 elen = (ebuf + sizeof ebuf) - ptr;
9902                 eptr = ptr;
9903                 if (has_precis) {
9904                     if (precis > elen)
9905                         zeros = precis - elen;
9906                     else if (precis == 0 && elen == 1 && *eptr == '0'
9907                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
9908                         elen = 0;
9909
9910                 /* a precision nullifies the 0 flag. */
9911                     if (fill == '0')
9912                         fill = ' ';
9913                 }
9914             }
9915             break;
9916
9917             /* FLOATING POINT */
9918
9919         case 'F':
9920             c = 'f';            /* maybe %F isn't supported here */
9921             /*FALLTHROUGH*/
9922         case 'e': case 'E':
9923         case 'f':
9924         case 'g': case 'G':
9925             if (vectorize)
9926                 goto unknown;
9927
9928             /* This is evil, but floating point is even more evil */
9929
9930             /* for SV-style calling, we can only get NV
9931                for C-style calling, we assume %f is double;
9932                for simplicity we allow any of %Lf, %llf, %qf for long double
9933             */
9934             switch (intsize) {
9935             case 'V':
9936 #if defined(USE_LONG_DOUBLE)
9937                 intsize = 'q';
9938 #endif
9939                 break;
9940 /* [perl #20339] - we should accept and ignore %lf rather than die */
9941             case 'l':
9942                 /*FALLTHROUGH*/
9943             default:
9944 #if defined(USE_LONG_DOUBLE)
9945                 intsize = args ? 0 : 'q';
9946 #endif
9947                 break;
9948             case 'q':
9949 #if defined(HAS_LONG_DOUBLE)
9950                 break;
9951 #else
9952                 /*FALLTHROUGH*/
9953 #endif
9954             case 'h':
9955                 goto unknown;
9956             }
9957
9958             /* now we need (long double) if intsize == 'q', else (double) */
9959             nv = (args) ?
9960 #if LONG_DOUBLESIZE > DOUBLESIZE
9961                 intsize == 'q' ?
9962                     va_arg(*args, long double) :
9963                     va_arg(*args, double)
9964 #else
9965                     va_arg(*args, double)
9966 #endif
9967                 : SvNV(argsv);
9968
9969             need = 0;
9970             /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
9971                else. frexp() has some unspecified behaviour for those three */
9972             if (c != 'e' && c != 'E' && (nv * 0) == 0) {
9973                 i = PERL_INT_MIN;
9974                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9975                    will cast our (long double) to (double) */
9976                 (void)Perl_frexp(nv, &i);
9977                 if (i == PERL_INT_MIN)
9978                     Perl_die(aTHX_ "panic: frexp");
9979                 if (i > 0)
9980                     need = BIT_DIGITS(i);
9981             }
9982             need += has_precis ? precis : 6; /* known default */
9983
9984             if (need < width)
9985                 need = width;
9986
9987 #ifdef HAS_LDBL_SPRINTF_BUG
9988             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9989                with sfio - Allen <allens@cpan.org> */
9990
9991 #  ifdef DBL_MAX
9992 #    define MY_DBL_MAX DBL_MAX
9993 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9994 #    if DOUBLESIZE >= 8
9995 #      define MY_DBL_MAX 1.7976931348623157E+308L
9996 #    else
9997 #      define MY_DBL_MAX 3.40282347E+38L
9998 #    endif
9999 #  endif
10000
10001 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10002 #    define MY_DBL_MAX_BUG 1L
10003 #  else
10004 #    define MY_DBL_MAX_BUG MY_DBL_MAX
10005 #  endif
10006
10007 #  ifdef DBL_MIN
10008 #    define MY_DBL_MIN DBL_MIN
10009 #  else  /* XXX guessing! -Allen */
10010 #    if DOUBLESIZE >= 8
10011 #      define MY_DBL_MIN 2.2250738585072014E-308L
10012 #    else
10013 #      define MY_DBL_MIN 1.17549435E-38L
10014 #    endif
10015 #  endif
10016
10017             if ((intsize == 'q') && (c == 'f') &&
10018                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10019                 (need < DBL_DIG)) {
10020                 /* it's going to be short enough that
10021                  * long double precision is not needed */
10022
10023                 if ((nv <= 0L) && (nv >= -0L))
10024                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10025                 else {
10026                     /* would use Perl_fp_class as a double-check but not
10027                      * functional on IRIX - see perl.h comments */
10028
10029                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10030                         /* It's within the range that a double can represent */
10031 #if defined(DBL_MAX) && !defined(DBL_MIN)
10032                         if ((nv >= ((long double)1/DBL_MAX)) ||
10033                             (nv <= (-(long double)1/DBL_MAX)))
10034 #endif
10035                         fix_ldbl_sprintf_bug = TRUE;
10036                     }
10037                 }
10038                 if (fix_ldbl_sprintf_bug == TRUE) {
10039                     double temp;
10040
10041                     intsize = 0;
10042                     temp = (double)nv;
10043                     nv = (NV)temp;
10044                 }
10045             }
10046
10047 #  undef MY_DBL_MAX
10048 #  undef MY_DBL_MAX_BUG
10049 #  undef MY_DBL_MIN
10050
10051 #endif /* HAS_LDBL_SPRINTF_BUG */
10052
10053             need += 20; /* fudge factor */
10054             if (PL_efloatsize < need) {
10055                 Safefree(PL_efloatbuf);
10056                 PL_efloatsize = need + 20; /* more fudge */
10057                 Newx(PL_efloatbuf, PL_efloatsize, char);
10058                 PL_efloatbuf[0] = '\0';
10059             }
10060
10061             if ( !(width || left || plus || alt) && fill != '0'
10062                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
10063                 /* See earlier comment about buggy Gconvert when digits,
10064                    aka precis is 0  */
10065                 if ( c == 'g' && precis) {
10066                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10067                     /* May return an empty string for digits==0 */
10068                     if (*PL_efloatbuf) {
10069                         elen = strlen(PL_efloatbuf);
10070                         goto float_converted;
10071                     }
10072                 } else if ( c == 'f' && !precis) {
10073                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10074                         break;
10075                 }
10076             }
10077             {
10078                 char *ptr = ebuf + sizeof ebuf;
10079                 *--ptr = '\0';
10080                 *--ptr = c;
10081                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10082 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10083                 if (intsize == 'q') {
10084                     /* Copy the one or more characters in a long double
10085                      * format before the 'base' ([efgEFG]) character to
10086                      * the format string. */
10087                     static char const prifldbl[] = PERL_PRIfldbl;
10088                     char const *p = prifldbl + sizeof(prifldbl) - 3;
10089                     while (p >= prifldbl) { *--ptr = *p--; }
10090                 }
10091 #endif
10092                 if (has_precis) {
10093                     base = precis;
10094                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10095                     *--ptr = '.';
10096                 }
10097                 if (width) {
10098                     base = width;
10099                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10100                 }
10101                 if (fill == '0')
10102                     *--ptr = fill;
10103                 if (left)
10104                     *--ptr = '-';
10105                 if (plus)
10106                     *--ptr = plus;
10107                 if (alt)
10108                     *--ptr = '#';
10109                 *--ptr = '%';
10110
10111                 /* No taint.  Otherwise we are in the strange situation
10112                  * where printf() taints but print($float) doesn't.
10113                  * --jhi */
10114 #if defined(HAS_LONG_DOUBLE)
10115                 elen = ((intsize == 'q')
10116                         ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10117                         : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10118 #else
10119                 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10120 #endif
10121             }
10122         float_converted:
10123             eptr = PL_efloatbuf;
10124             break;
10125
10126             /* SPECIAL */
10127
10128         case 'n':
10129             if (vectorize)
10130                 goto unknown;
10131             i = SvCUR(sv) - origlen;
10132             if (args) {
10133                 switch (intsize) {
10134                 case 'h':       *(va_arg(*args, short*)) = i; break;
10135                 default:        *(va_arg(*args, int*)) = i; break;
10136                 case 'l':       *(va_arg(*args, long*)) = i; break;
10137                 case 'V':       *(va_arg(*args, IV*)) = i; break;
10138                 case 'q':
10139 #ifdef HAS_QUAD
10140                                 *(va_arg(*args, Quad_t*)) = i; break;
10141 #else
10142                                 goto unknown;
10143 #endif
10144                 }
10145             }
10146             else
10147                 sv_setuv_mg(argsv, (UV)i);
10148             continue;   /* not "break" */
10149
10150             /* UNKNOWN */
10151
10152         default:
10153       unknown:
10154             if (!args
10155                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10156                 && ckWARN(WARN_PRINTF))
10157             {
10158                 SV * const msg = sv_newmortal();
10159                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10160                           (PL_op->op_type == OP_PRTF) ? "" : "s");
10161                 if (fmtstart < patend) {
10162                     const char * const fmtend = q < patend ? q : patend;
10163                     const char * f;
10164                     sv_catpvs(msg, "\"%");
10165                     for (f = fmtstart; f < fmtend; f++) {
10166                         if (isPRINT(*f)) {
10167                             sv_catpvn(msg, f, 1);
10168                         } else {
10169                             Perl_sv_catpvf(aTHX_ msg,
10170                                            "\\%03"UVof, (UV)*f & 0xFF);
10171                         }
10172                     }
10173                     sv_catpvs(msg, "\"");
10174                 } else {
10175                     sv_catpvs(msg, "end of string");
10176                 }
10177                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10178             }
10179
10180             /* output mangled stuff ... */
10181             if (c == '\0')
10182                 --q;
10183             eptr = p;
10184             elen = q - p;
10185
10186             /* ... right here, because formatting flags should not apply */
10187             SvGROW(sv, SvCUR(sv) + elen + 1);
10188             p = SvEND(sv);
10189             Copy(eptr, p, elen, char);
10190             p += elen;
10191             *p = '\0';
10192             SvCUR_set(sv, p - SvPVX_const(sv));
10193             svix = osvix;
10194             continue;   /* not "break" */
10195         }
10196
10197         if (is_utf8 != has_utf8) {
10198             if (is_utf8) {
10199                 if (SvCUR(sv))
10200                     sv_utf8_upgrade(sv);
10201             }
10202             else {
10203                 const STRLEN old_elen = elen;
10204                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10205                 sv_utf8_upgrade(nsv);
10206                 eptr = SvPVX_const(nsv);
10207                 elen = SvCUR(nsv);
10208
10209                 if (width) { /* fudge width (can't fudge elen) */
10210                     width += elen - old_elen;
10211                 }
10212                 is_utf8 = TRUE;
10213             }
10214         }
10215
10216         have = esignlen + zeros + elen;
10217         if (have < zeros)
10218             Perl_croak_nocontext("%s", PL_memory_wrap);
10219
10220         need = (have > width ? have : width);
10221         gap = need - have;
10222
10223         if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10224             Perl_croak_nocontext("%s", PL_memory_wrap);
10225         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10226         p = SvEND(sv);
10227         if (esignlen && fill == '0') {
10228             int i;
10229             for (i = 0; i < (int)esignlen; i++)
10230                 *p++ = esignbuf[i];
10231         }
10232         if (gap && !left) {
10233             memset(p, fill, gap);
10234             p += gap;
10235         }
10236         if (esignlen && fill != '0') {
10237             int i;
10238             for (i = 0; i < (int)esignlen; i++)
10239                 *p++ = esignbuf[i];
10240         }
10241         if (zeros) {
10242             int i;
10243             for (i = zeros; i; i--)
10244                 *p++ = '0';
10245         }
10246         if (elen) {
10247             Copy(eptr, p, elen, char);
10248             p += elen;
10249         }
10250         if (gap && left) {
10251             memset(p, ' ', gap);
10252             p += gap;
10253         }
10254         if (vectorize) {
10255             if (veclen) {
10256                 Copy(dotstr, p, dotstrlen, char);
10257                 p += dotstrlen;
10258             }
10259             else
10260                 vectorize = FALSE;              /* done iterating over vecstr */
10261         }
10262         if (is_utf8)
10263             has_utf8 = TRUE;
10264         if (has_utf8)
10265             SvUTF8_on(sv);
10266         *p = '\0';
10267         SvCUR_set(sv, p - SvPVX_const(sv));
10268         if (vectorize) {
10269             esignlen = 0;
10270             goto vector;
10271         }
10272     }
10273 }
10274
10275 /* =========================================================================
10276
10277 =head1 Cloning an interpreter
10278
10279 All the macros and functions in this section are for the private use of
10280 the main function, perl_clone().
10281
10282 The foo_dup() functions make an exact copy of an existing foo thingy.
10283 During the course of a cloning, a hash table is used to map old addresses
10284 to new addresses. The table is created and manipulated with the
10285 ptr_table_* functions.
10286
10287 =cut
10288
10289  * =========================================================================*/
10290
10291
10292 #if defined(USE_ITHREADS)
10293
10294 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10295 #ifndef GpREFCNT_inc
10296 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10297 #endif
10298
10299
10300 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10301    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10302    If this changes, please unmerge ss_dup.
10303    Likewise, sv_dup_inc_multiple() relies on this fact.  */
10304 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10305 #define sv_dup_inc_NN(s,t)      SvREFCNT_inc_NN(sv_dup(s,t))
10306 #define av_dup(s,t)     MUTABLE_AV(sv_dup((const SV *)s,t))
10307 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10308 #define hv_dup(s,t)     MUTABLE_HV(sv_dup((const SV *)s,t))
10309 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10310 #define cv_dup(s,t)     MUTABLE_CV(sv_dup((const SV *)s,t))
10311 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10312 #define io_dup(s,t)     MUTABLE_IO(sv_dup((const SV *)s,t))
10313 #define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10314 #define gv_dup(s,t)     MUTABLE_GV(sv_dup((const SV *)s,t))
10315 #define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10316 #define SAVEPV(p)       ((p) ? savepv(p) : NULL)
10317 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
10318
10319 /* clone a parser */
10320
10321 yy_parser *
10322 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10323 {
10324     yy_parser *parser;
10325
10326     PERL_ARGS_ASSERT_PARSER_DUP;
10327
10328     if (!proto)
10329         return NULL;
10330
10331     /* look for it in the table first */
10332     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10333     if (parser)
10334         return parser;
10335
10336     /* create anew and remember what it is */
10337     Newxz(parser, 1, yy_parser);
10338     ptr_table_store(PL_ptr_table, proto, parser);
10339
10340     parser->yyerrstatus = 0;
10341     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
10342
10343     /* XXX these not yet duped */
10344     parser->old_parser = NULL;
10345     parser->stack = NULL;
10346     parser->ps = NULL;
10347     parser->stack_size = 0;
10348     /* XXX parser->stack->state = 0; */
10349
10350     /* XXX eventually, just Copy() most of the parser struct ? */
10351
10352     parser->lex_brackets = proto->lex_brackets;
10353     parser->lex_casemods = proto->lex_casemods;
10354     parser->lex_brackstack = savepvn(proto->lex_brackstack,
10355                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10356     parser->lex_casestack = savepvn(proto->lex_casestack,
10357                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10358     parser->lex_defer   = proto->lex_defer;
10359     parser->lex_dojoin  = proto->lex_dojoin;
10360     parser->lex_expect  = proto->lex_expect;
10361     parser->lex_formbrack = proto->lex_formbrack;
10362     parser->lex_inpat   = proto->lex_inpat;
10363     parser->lex_inwhat  = proto->lex_inwhat;
10364     parser->lex_op      = proto->lex_op;
10365     parser->lex_repl    = sv_dup_inc(proto->lex_repl, param);
10366     parser->lex_starts  = proto->lex_starts;
10367     parser->lex_stuff   = sv_dup_inc(proto->lex_stuff, param);
10368     parser->multi_close = proto->multi_close;
10369     parser->multi_open  = proto->multi_open;
10370     parser->multi_start = proto->multi_start;
10371     parser->multi_end   = proto->multi_end;
10372     parser->pending_ident = proto->pending_ident;
10373     parser->preambled   = proto->preambled;
10374     parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10375     parser->linestr     = sv_dup_inc(proto->linestr, param);
10376     parser->expect      = proto->expect;
10377     parser->copline     = proto->copline;
10378     parser->last_lop_op = proto->last_lop_op;
10379     parser->lex_state   = proto->lex_state;
10380     parser->rsfp        = fp_dup(proto->rsfp, '<', param);
10381     /* rsfp_filters entries have fake IoDIRP() */
10382     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10383     parser->in_my       = proto->in_my;
10384     parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10385     parser->error_count = proto->error_count;
10386
10387
10388     parser->linestr     = sv_dup_inc(proto->linestr, param);
10389
10390     {
10391         char * const ols = SvPVX(proto->linestr);
10392         char * const ls  = SvPVX(parser->linestr);
10393
10394         parser->bufptr      = ls + (proto->bufptr >= ols ?
10395                                     proto->bufptr -  ols : 0);
10396         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
10397                                     proto->oldbufptr -  ols : 0);
10398         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10399                                     proto->oldoldbufptr -  ols : 0);
10400         parser->linestart   = ls + (proto->linestart >= ols ?
10401                                     proto->linestart -  ols : 0);
10402         parser->last_uni    = ls + (proto->last_uni >= ols ?
10403                                     proto->last_uni -  ols : 0);
10404         parser->last_lop    = ls + (proto->last_lop >= ols ?
10405                                     proto->last_lop -  ols : 0);
10406
10407         parser->bufend      = ls + SvCUR(parser->linestr);
10408     }
10409
10410     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10411
10412
10413 #ifdef PERL_MAD
10414     parser->endwhite    = proto->endwhite;
10415     parser->faketokens  = proto->faketokens;
10416     parser->lasttoke    = proto->lasttoke;
10417     parser->nextwhite   = proto->nextwhite;
10418     parser->realtokenstart = proto->realtokenstart;
10419     parser->skipwhite   = proto->skipwhite;
10420     parser->thisclose   = proto->thisclose;
10421     parser->thismad     = proto->thismad;
10422     parser->thisopen    = proto->thisopen;
10423     parser->thisstuff   = proto->thisstuff;
10424     parser->thistoken   = proto->thistoken;
10425     parser->thiswhite   = proto->thiswhite;
10426
10427     Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10428     parser->curforce    = proto->curforce;
10429 #else
10430     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10431     Copy(proto->nexttype, parser->nexttype, 5,  I32);
10432     parser->nexttoke    = proto->nexttoke;
10433 #endif
10434     return parser;
10435 }
10436
10437
10438 /* duplicate a file handle */
10439
10440 PerlIO *
10441 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10442 {
10443     PerlIO *ret;
10444
10445     PERL_ARGS_ASSERT_FP_DUP;
10446     PERL_UNUSED_ARG(type);
10447
10448     if (!fp)
10449         return (PerlIO*)NULL;
10450
10451     /* look for it in the table first */
10452     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10453     if (ret)
10454         return ret;
10455
10456     /* create anew and remember what it is */
10457     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10458     ptr_table_store(PL_ptr_table, fp, ret);
10459     return ret;
10460 }
10461
10462 /* duplicate a directory handle */
10463
10464 DIR *
10465 Perl_dirp_dup(pTHX_ DIR *const dp)
10466 {
10467     PERL_UNUSED_CONTEXT;
10468     if (!dp)
10469         return (DIR*)NULL;
10470     /* XXX TODO */
10471     return dp;
10472 }
10473
10474 /* duplicate a typeglob */
10475
10476 GP *
10477 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10478 {
10479     GP *ret;
10480
10481     PERL_ARGS_ASSERT_GP_DUP;
10482
10483     if (!gp)
10484         return (GP*)NULL;
10485     /* look for it in the table first */
10486     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10487     if (ret)
10488         return ret;
10489
10490     /* create anew and remember what it is */
10491     Newxz(ret, 1, GP);
10492     ptr_table_store(PL_ptr_table, gp, ret);
10493
10494     /* clone */
10495     /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
10496        on Newxz() to do this for us.  */
10497     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
10498     ret->gp_io          = io_dup_inc(gp->gp_io, param);
10499     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
10500     ret->gp_av          = av_dup_inc(gp->gp_av, param);
10501     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
10502     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10503     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
10504     ret->gp_cvgen       = gp->gp_cvgen;
10505     ret->gp_line        = gp->gp_line;
10506     ret->gp_file_hek    = hek_dup(gp->gp_file_hek, param);
10507     return ret;
10508 }
10509
10510 /* duplicate a chain of magic */
10511
10512 MAGIC *
10513 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10514 {
10515     MAGIC *mgret = NULL;
10516     MAGIC **mgprev_p = &mgret;
10517
10518     PERL_ARGS_ASSERT_MG_DUP;
10519
10520     for (; mg; mg = mg->mg_moremagic) {
10521         MAGIC *nmg;
10522         Newx(nmg, 1, MAGIC);
10523         *mgprev_p = nmg;
10524         mgprev_p = &(nmg->mg_moremagic);
10525
10526         /* There was a comment "XXX copy dynamic vtable?" but as we don't have
10527            dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
10528            from the original commit adding Perl_mg_dup() - revision 4538.
10529            Similarly there is the annotation "XXX random ptr?" next to the
10530            assignment to nmg->mg_ptr.  */
10531         *nmg = *mg;
10532
10533         /* FIXME for plugins
10534         if (nmg->mg_type == PERL_MAGIC_qr) {
10535             nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
10536         }
10537         else
10538         */
10539         if(nmg->mg_type == PERL_MAGIC_backref) {
10540             /* The backref AV has its reference count deliberately bumped by
10541                1.  */
10542             nmg->mg_obj
10543                 = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param));
10544         }
10545         else {
10546             nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
10547                               ? sv_dup_inc(nmg->mg_obj, param)
10548                               : sv_dup(nmg->mg_obj, param);
10549         }
10550
10551         if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
10552             if (nmg->mg_len > 0) {
10553                 nmg->mg_ptr     = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
10554                 if (nmg->mg_type == PERL_MAGIC_overload_table &&
10555                         AMT_AMAGIC((AMT*)nmg->mg_ptr))
10556                 {
10557                     AMT * const namtp = (AMT*)nmg->mg_ptr;
10558                     sv_dup_inc_multiple((SV**)(namtp->table),
10559                                         (SV**)(namtp->table), NofAMmeth, param);
10560                 }
10561             }
10562             else if (nmg->mg_len == HEf_SVKEY)
10563                 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
10564         }
10565         if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
10566             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10567         }
10568     }
10569     return mgret;
10570 }
10571
10572 #endif /* USE_ITHREADS */
10573
10574 /* create a new pointer-mapping table */
10575
10576 PTR_TBL_t *
10577 Perl_ptr_table_new(pTHX)
10578 {
10579     PTR_TBL_t *tbl;
10580     PERL_UNUSED_CONTEXT;
10581
10582     Newx(tbl, 1, PTR_TBL_t);
10583     tbl->tbl_max        = 511;
10584     tbl->tbl_items      = 0;
10585     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10586     return tbl;
10587 }
10588
10589 #define PTR_TABLE_HASH(ptr) \
10590   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10591
10592 /*
10593    we use the PTE_SVSLOT 'reservation' made above, both here (in the
10594    following define) and at call to new_body_inline made below in
10595    Perl_ptr_table_store()
10596  */
10597
10598 #define del_pte(p)     del_body_type(p, PTE_SVSLOT)
10599
10600 /* map an existing pointer using a table */
10601
10602 STATIC PTR_TBL_ENT_t *
10603 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10604 {
10605     PTR_TBL_ENT_t *tblent;
10606     const UV hash = PTR_TABLE_HASH(sv);
10607
10608     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10609
10610     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10611     for (; tblent; tblent = tblent->next) {
10612         if (tblent->oldval == sv)
10613             return tblent;
10614     }
10615     return NULL;
10616 }
10617
10618 void *
10619 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10620 {
10621     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10622
10623     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10624     PERL_UNUSED_CONTEXT;
10625
10626     return tblent ? tblent->newval : NULL;
10627 }
10628
10629 /* add a new entry to a pointer-mapping table */
10630
10631 void
10632 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10633 {
10634     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10635
10636     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10637     PERL_UNUSED_CONTEXT;
10638
10639     if (tblent) {
10640         tblent->newval = newsv;
10641     } else {
10642         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10643
10644         new_body_inline(tblent, PTE_SVSLOT);
10645
10646         tblent->oldval = oldsv;
10647         tblent->newval = newsv;
10648         tblent->next = tbl->tbl_ary[entry];
10649         tbl->tbl_ary[entry] = tblent;
10650         tbl->tbl_items++;
10651         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10652             ptr_table_split(tbl);
10653     }
10654 }
10655
10656 /* double the hash bucket size of an existing ptr table */
10657
10658 void
10659 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10660 {
10661     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10662     const UV oldsize = tbl->tbl_max + 1;
10663     UV newsize = oldsize * 2;
10664     UV i;
10665
10666     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10667     PERL_UNUSED_CONTEXT;
10668
10669     Renew(ary, newsize, PTR_TBL_ENT_t*);
10670     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10671     tbl->tbl_max = --newsize;
10672     tbl->tbl_ary = ary;
10673     for (i=0; i < oldsize; i++, ary++) {
10674         PTR_TBL_ENT_t **curentp, **entp, *ent;
10675         if (!*ary)
10676             continue;
10677         curentp = ary + oldsize;
10678         for (entp = ary, ent = *ary; ent; ent = *entp) {
10679             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10680                 *entp = ent->next;
10681                 ent->next = *curentp;
10682                 *curentp = ent;
10683                 continue;
10684             }
10685             else
10686                 entp = &ent->next;
10687         }
10688     }
10689 }
10690
10691 /* remove all the entries from a ptr table */
10692
10693 void
10694 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10695 {
10696     if (tbl && tbl->tbl_items) {
10697         register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
10698         UV riter = tbl->tbl_max;
10699
10700         do {
10701             PTR_TBL_ENT_t *entry = array[riter];
10702
10703             while (entry) {
10704                 PTR_TBL_ENT_t * const oentry = entry;
10705                 entry = entry->next;
10706                 del_pte(oentry);
10707             }
10708         } while (riter--);
10709
10710         tbl->tbl_items = 0;
10711     }
10712 }
10713
10714 /* clear and free a ptr table */
10715
10716 void
10717 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10718 {
10719     if (!tbl) {
10720         return;
10721     }
10722     ptr_table_clear(tbl);
10723     Safefree(tbl->tbl_ary);
10724     Safefree(tbl);
10725 }
10726
10727 #if defined(USE_ITHREADS)
10728
10729 void
10730 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10731 {
10732     PERL_ARGS_ASSERT_RVPV_DUP;
10733
10734     if (SvROK(sstr)) {
10735         SvRV_set(dstr, SvWEAKREF(sstr)
10736                        ? sv_dup(SvRV_const(sstr), param)
10737                        : sv_dup_inc(SvRV_const(sstr), param));
10738
10739     }
10740     else if (SvPVX_const(sstr)) {
10741         /* Has something there */
10742         if (SvLEN(sstr)) {
10743             /* Normal PV - clone whole allocated space */
10744             SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10745             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10746                 /* Not that normal - actually sstr is copy on write.
10747                    But we are a true, independant SV, so:  */
10748                 SvREADONLY_off(dstr);
10749                 SvFAKE_off(dstr);
10750             }
10751         }
10752         else {
10753             /* Special case - not normally malloced for some reason */
10754             if (isGV_with_GP(sstr)) {
10755                 /* Don't need to do anything here.  */
10756             }
10757             else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10758                 /* A "shared" PV - clone it as "shared" PV */
10759                 SvPV_set(dstr,
10760                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10761                                          param)));
10762             }
10763             else {
10764                 /* Some other special case - random pointer */
10765                 SvPV_set(dstr, (char *) SvPVX_const(sstr));
10766             }
10767         }
10768     }
10769     else {
10770         /* Copy the NULL */
10771         SvPV_set(dstr, NULL);
10772     }
10773 }
10774
10775 /* duplicate a list of SVs. source and dest may point to the same memory.  */
10776 static SV **
10777 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
10778                       SSize_t items, CLONE_PARAMS *const param)
10779 {
10780     PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
10781
10782     while (items-- > 0) {
10783         *dest++ = sv_dup_inc(*source++, param);
10784     }
10785
10786     return dest;
10787 }
10788
10789 /* duplicate an SV of any type (including AV, HV etc) */
10790
10791 SV *
10792 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10793 {
10794     dVAR;
10795     SV *dstr;
10796
10797     PERL_ARGS_ASSERT_SV_DUP;
10798
10799     if (!sstr)
10800         return NULL;
10801     if (SvTYPE(sstr) == SVTYPEMASK) {
10802 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10803         abort();
10804 #endif
10805         return NULL;
10806     }
10807     /* look for it in the table first */
10808     dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
10809     if (dstr)
10810         return dstr;
10811
10812     if(param->flags & CLONEf_JOIN_IN) {
10813         /** We are joining here so we don't want do clone
10814             something that is bad **/
10815         if (SvTYPE(sstr) == SVt_PVHV) {
10816             const HEK * const hvname = HvNAME_HEK(sstr);
10817             if (hvname)
10818                 /** don't clone stashes if they already exist **/
10819                 return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
10820         }
10821     }
10822
10823     /* create anew and remember what it is */
10824     new_SV(dstr);
10825
10826 #ifdef DEBUG_LEAKING_SCALARS
10827     dstr->sv_debug_optype = sstr->sv_debug_optype;
10828     dstr->sv_debug_line = sstr->sv_debug_line;
10829     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10830     dstr->sv_debug_cloned = 1;
10831     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10832 #endif
10833
10834     ptr_table_store(PL_ptr_table, sstr, dstr);
10835
10836     /* clone */
10837     SvFLAGS(dstr)       = SvFLAGS(sstr);
10838     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
10839     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
10840
10841 #ifdef DEBUGGING
10842     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10843         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10844                       (void*)PL_watch_pvx, SvPVX_const(sstr));
10845 #endif
10846
10847     /* don't clone objects whose class has asked us not to */
10848     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10849         SvFLAGS(dstr) = 0;
10850         return dstr;
10851     }
10852
10853     switch (SvTYPE(sstr)) {
10854     case SVt_NULL:
10855         SvANY(dstr)     = NULL;
10856         break;
10857     case SVt_IV:
10858         SvANY(dstr)     = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10859         if(SvROK(sstr)) {
10860             Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10861         } else {
10862             SvIV_set(dstr, SvIVX(sstr));
10863         }
10864         break;
10865     case SVt_NV:
10866         SvANY(dstr)     = new_XNV();
10867         SvNV_set(dstr, SvNVX(sstr));
10868         break;
10869         /* case SVt_BIND: */
10870     default:
10871         {
10872             /* These are all the types that need complex bodies allocating.  */
10873             void *new_body;
10874             const svtype sv_type = SvTYPE(sstr);
10875             const struct body_details *const sv_type_details
10876                 = bodies_by_type + sv_type;
10877
10878             switch (sv_type) {
10879             default:
10880                 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10881                 break;
10882
10883             case SVt_PVGV:
10884             case SVt_PVIO:
10885             case SVt_PVFM:
10886             case SVt_PVHV:
10887             case SVt_PVAV:
10888             case SVt_PVCV:
10889             case SVt_PVLV:
10890             case SVt_REGEXP:
10891             case SVt_PVMG:
10892             case SVt_PVNV:
10893             case SVt_PVIV:
10894             case SVt_PV:
10895                 assert(sv_type_details->body_size);
10896                 if (sv_type_details->arena) {
10897                     new_body_inline(new_body, sv_type);
10898                     new_body
10899                         = (void*)((char*)new_body - sv_type_details->offset);
10900                 } else {
10901                     new_body = new_NOARENA(sv_type_details);
10902                 }
10903             }
10904             assert(new_body);
10905             SvANY(dstr) = new_body;
10906
10907 #ifndef PURIFY
10908             Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
10909                  ((char*)SvANY(dstr)) + sv_type_details->offset,
10910                  sv_type_details->copy, char);
10911 #else
10912             Copy(((char*)SvANY(sstr)),
10913                  ((char*)SvANY(dstr)),
10914                  sv_type_details->body_size + sv_type_details->offset, char);
10915 #endif
10916
10917             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
10918                 && !isGV_with_GP(dstr))
10919                 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10920
10921             /* The Copy above means that all the source (unduplicated) pointers
10922                are now in the destination.  We can check the flags and the
10923                pointers in either, but it's possible that there's less cache
10924                missing by always going for the destination.
10925                FIXME - instrument and check that assumption  */
10926             if (sv_type >= SVt_PVMG) {
10927                 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
10928                     SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
10929                 } else if (SvMAGIC(dstr))
10930                     SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10931                 if (SvSTASH(dstr))
10932                     SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10933             }
10934
10935             /* The cast silences a GCC warning about unhandled types.  */
10936             switch ((int)sv_type) {
10937             case SVt_PV:
10938                 break;
10939             case SVt_PVIV:
10940                 break;
10941             case SVt_PVNV:
10942                 break;
10943             case SVt_PVMG:
10944                 break;
10945             case SVt_REGEXP:
10946                 /* FIXME for plugins */
10947                 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
10948                 break;
10949             case SVt_PVLV:
10950                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10951                 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10952                     LvTARG(dstr) = dstr;
10953                 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10954                     LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
10955                 else
10956                     LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10957             case SVt_PVGV:
10958                 if(isGV_with_GP(sstr)) {
10959                     GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
10960                     /* Don't call sv_add_backref here as it's going to be
10961                        created as part of the magic cloning of the symbol
10962                        table.  */
10963                     /* Danger Will Robinson - GvGP(dstr) isn't initialised
10964                        at the point of this comment.  */
10965                     GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10966                     GvGP(dstr)  = gp_dup(GvGP(sstr), param);
10967                     (void)GpREFCNT_inc(GvGP(dstr));
10968                 } else
10969                     Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10970                 break;
10971             case SVt_PVIO:
10972                 IoIFP(dstr)     = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10973                 if (IoOFP(dstr) == IoIFP(sstr))
10974                     IoOFP(dstr) = IoIFP(dstr);
10975                 else
10976                     IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10977                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
10978                 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10979                     /* I have no idea why fake dirp (rsfps)
10980                        should be treated differently but otherwise
10981                        we end up with leaks -- sky*/
10982                     IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
10983                     IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
10984                     IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10985                 } else {
10986                     IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
10987                     IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
10988                     IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
10989                     if (IoDIRP(dstr)) {
10990                         IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr));
10991                     } else {
10992                         NOOP;
10993                         /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
10994                     }
10995                 }
10996                 IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
10997                 IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
10998                 IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
10999                 break;
11000             case SVt_PVAV:
11001                 /* avoid cloning an empty array */
11002                 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11003                     SV **dst_ary, **src_ary;
11004                     SSize_t items = AvFILLp((const AV *)sstr) + 1;
11005
11006                     src_ary = AvARRAY((const AV *)sstr);
11007                     Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11008                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11009                     AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11010                     AvALLOC((const AV *)dstr) = dst_ary;
11011                     if (AvREAL((const AV *)sstr)) {
11012                         dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11013                                                       param);
11014                     }
11015                     else {
11016                         while (items-- > 0)
11017                             *dst_ary++ = sv_dup(*src_ary++, param);
11018                     }
11019                     items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11020                     while (items-- > 0) {
11021                         *dst_ary++ = &PL_sv_undef;
11022                     }
11023                 }
11024                 else {
11025                     AvARRAY(MUTABLE_AV(dstr))   = NULL;
11026                     AvALLOC((const AV *)dstr)   = (SV**)NULL;
11027                     AvMAX(  (const AV *)dstr)   = -1;
11028                     AvFILLp((const AV *)dstr)   = -1;
11029                 }
11030                 break;
11031             case SVt_PVHV:
11032                 if (HvARRAY((const HV *)sstr)) {
11033                     STRLEN i = 0;
11034                     const bool sharekeys = !!HvSHAREKEYS(sstr);
11035                     XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11036                     XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11037                     char *darray;
11038                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11039                         + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11040                         char);
11041                     HvARRAY(dstr) = (HE**)darray;
11042                     while (i <= sxhv->xhv_max) {
11043                         const HE * const source = HvARRAY(sstr)[i];
11044                         HvARRAY(dstr)[i] = source
11045                             ? he_dup(source, sharekeys, param) : 0;
11046                         ++i;
11047                     }
11048                     if (SvOOK(sstr)) {
11049                         HEK *hvname;
11050                         const struct xpvhv_aux * const saux = HvAUX(sstr);
11051                         struct xpvhv_aux * const daux = HvAUX(dstr);
11052                         /* This flag isn't copied.  */
11053                         /* SvOOK_on(hv) attacks the IV flags.  */
11054                         SvFLAGS(dstr) |= SVf_OOK;
11055
11056                         hvname = saux->xhv_name;
11057                         daux->xhv_name = hek_dup(hvname, param);
11058
11059                         daux->xhv_riter = saux->xhv_riter;
11060                         daux->xhv_eiter = saux->xhv_eiter
11061                             ? he_dup(saux->xhv_eiter,
11062                                         (bool)!!HvSHAREKEYS(sstr), param) : 0;
11063                         /* backref array needs refcnt=2; see sv_add_backref */
11064                         daux->xhv_backreferences =
11065                             saux->xhv_backreferences
11066                             ? MUTABLE_AV(SvREFCNT_inc(
11067                                                       sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
11068                                 : 0;
11069
11070                         daux->xhv_mro_meta = saux->xhv_mro_meta
11071                             ? mro_meta_dup(saux->xhv_mro_meta, param)
11072                             : 0;
11073
11074                         /* Record stashes for possible cloning in Perl_clone(). */
11075                         if (hvname)
11076                             av_push(param->stashes, dstr);
11077                     }
11078                 }
11079                 else
11080                     HvARRAY(MUTABLE_HV(dstr)) = NULL;
11081                 break;
11082             case SVt_PVCV:
11083                 if (!(param->flags & CLONEf_COPY_STACKS)) {
11084                     CvDEPTH(dstr) = 0;
11085                 }
11086             case SVt_PVFM:
11087                 /* NOTE: not refcounted */
11088                 CvSTASH(dstr)   = hv_dup(CvSTASH(dstr), param);
11089                 OP_REFCNT_LOCK;
11090                 if (!CvISXSUB(dstr))
11091                     CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11092                 OP_REFCNT_UNLOCK;
11093                 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11094                     CvXSUBANY(dstr).any_ptr =
11095                         sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11096                 }
11097                 /* don't dup if copying back - CvGV isn't refcounted, so the
11098                  * duped GV may never be freed. A bit of a hack! DAPM */
11099                 CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
11100                     NULL : gv_dup(CvGV(dstr), param) ;
11101                 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11102                 CvOUTSIDE(dstr) =
11103                     CvWEAKOUTSIDE(sstr)
11104                     ? cv_dup(    CvOUTSIDE(dstr), param)
11105                     : cv_dup_inc(CvOUTSIDE(dstr), param);
11106                 if (!CvISXSUB(dstr))
11107                     CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11108                 break;
11109             }
11110         }
11111     }
11112
11113     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11114         ++PL_sv_objcount;
11115
11116     return dstr;
11117  }
11118
11119 /* duplicate a context */
11120
11121 PERL_CONTEXT *
11122 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11123 {
11124     PERL_CONTEXT *ncxs;
11125
11126     PERL_ARGS_ASSERT_CX_DUP;
11127
11128     if (!cxs)
11129         return (PERL_CONTEXT*)NULL;
11130
11131     /* look for it in the table first */
11132     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11133     if (ncxs)
11134         return ncxs;
11135
11136     /* create anew and remember what it is */
11137     Newx(ncxs, max + 1, PERL_CONTEXT);
11138     ptr_table_store(PL_ptr_table, cxs, ncxs);
11139     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11140
11141     while (ix >= 0) {
11142         PERL_CONTEXT * const ncx = &ncxs[ix];
11143         if (CxTYPE(ncx) == CXt_SUBST) {
11144             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11145         }
11146         else {
11147             switch (CxTYPE(ncx)) {
11148             case CXt_SUB:
11149                 ncx->blk_sub.cv         = (ncx->blk_sub.olddepth == 0
11150                                            ? cv_dup_inc(ncx->blk_sub.cv, param)
11151                                            : cv_dup(ncx->blk_sub.cv,param));
11152                 ncx->blk_sub.argarray   = (CxHASARGS(ncx)
11153                                            ? av_dup_inc(ncx->blk_sub.argarray,
11154                                                         param)
11155                                            : NULL);
11156                 ncx->blk_sub.savearray  = av_dup_inc(ncx->blk_sub.savearray,
11157                                                      param);
11158                 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11159                                            ncx->blk_sub.oldcomppad);
11160                 break;
11161             case CXt_EVAL:
11162                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11163                                                       param);
11164                 ncx->blk_eval.cur_text  = sv_dup(ncx->blk_eval.cur_text, param);
11165                 break;
11166             case CXt_LOOP_LAZYSV:
11167                 ncx->blk_loop.state_u.lazysv.end
11168                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11169                 /* We are taking advantage of av_dup_inc and sv_dup_inc
11170                    actually being the same function, and order equivalance of
11171                    the two unions.
11172                    We can assert the later [but only at run time :-(]  */
11173                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11174                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
11175             case CXt_LOOP_FOR:
11176                 ncx->blk_loop.state_u.ary.ary
11177                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11178             case CXt_LOOP_LAZYIV:
11179             case CXt_LOOP_PLAIN:
11180                 if (CxPADLOOP(ncx)) {
11181                     ncx->blk_loop.oldcomppad
11182                         = (PAD*)ptr_table_fetch(PL_ptr_table,
11183                                                 ncx->blk_loop.oldcomppad);
11184                 } else {
11185                     ncx->blk_loop.oldcomppad
11186                         = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
11187                                        param);
11188                 }
11189                 break;
11190             case CXt_FORMAT:
11191                 ncx->blk_format.cv      = cv_dup(ncx->blk_format.cv, param);
11192                 ncx->blk_format.gv      = gv_dup(ncx->blk_format.gv, param);
11193                 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11194                                                      param);
11195                 break;
11196             case CXt_BLOCK:
11197             case CXt_NULL:
11198                 break;
11199             }
11200         }
11201         --ix;
11202     }
11203     return ncxs;
11204 }
11205
11206 /* duplicate a stack info structure */
11207
11208 PERL_SI *
11209 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11210 {
11211     PERL_SI *nsi;
11212
11213     PERL_ARGS_ASSERT_SI_DUP;
11214
11215     if (!si)
11216         return (PERL_SI*)NULL;
11217
11218     /* look for it in the table first */
11219     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11220     if (nsi)
11221         return nsi;
11222
11223     /* create anew and remember what it is */
11224     Newxz(nsi, 1, PERL_SI);
11225     ptr_table_store(PL_ptr_table, si, nsi);
11226
11227     nsi->si_stack       = av_dup_inc(si->si_stack, param);
11228     nsi->si_cxix        = si->si_cxix;
11229     nsi->si_cxmax       = si->si_cxmax;
11230     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11231     nsi->si_type        = si->si_type;
11232     nsi->si_prev        = si_dup(si->si_prev, param);
11233     nsi->si_next        = si_dup(si->si_next, param);
11234     nsi->si_markoff     = si->si_markoff;
11235
11236     return nsi;
11237 }
11238
11239 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
11240 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
11241 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
11242 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
11243 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
11244 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
11245 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
11246 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
11247 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
11248 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
11249 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
11250 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
11251 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11252 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11253
11254 /* XXXXX todo */
11255 #define pv_dup_inc(p)   SAVEPV(p)
11256 #define pv_dup(p)       SAVEPV(p)
11257 #define svp_dup_inc(p,pp)       any_dup(p,pp)
11258
11259 /* map any object to the new equivent - either something in the
11260  * ptr table, or something in the interpreter structure
11261  */
11262
11263 void *
11264 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11265 {
11266     void *ret;
11267
11268     PERL_ARGS_ASSERT_ANY_DUP;
11269
11270     if (!v)
11271         return (void*)NULL;
11272
11273     /* look for it in the table first */
11274     ret = ptr_table_fetch(PL_ptr_table, v);
11275     if (ret)
11276         return ret;
11277
11278     /* see if it is part of the interpreter structure */
11279     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11280         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11281     else {
11282         ret = v;
11283     }
11284
11285     return ret;
11286 }
11287
11288 /* duplicate the save stack */
11289
11290 ANY *
11291 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11292 {
11293     dVAR;
11294     ANY * const ss      = proto_perl->Isavestack;
11295     const I32 max       = proto_perl->Isavestack_max;
11296     I32 ix              = proto_perl->Isavestack_ix;
11297     ANY *nss;
11298     const SV *sv;
11299     const GV *gv;
11300     const AV *av;
11301     const HV *hv;
11302     void* ptr;
11303     int intval;
11304     long longval;
11305     GP *gp;
11306     IV iv;
11307     I32 i;
11308     char *c = NULL;
11309     void (*dptr) (void*);
11310     void (*dxptr) (pTHX_ void*);
11311
11312     PERL_ARGS_ASSERT_SS_DUP;
11313
11314     Newxz(nss, max, ANY);
11315
11316     while (ix > 0) {
11317         const I32 type = POPINT(ss,ix);
11318         TOPINT(nss,ix) = type;
11319         switch (type) {
11320         case SAVEt_HELEM:               /* hash element */
11321             sv = (const SV *)POPPTR(ss,ix);
11322             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11323             /* fall through */
11324         case SAVEt_ITEM:                        /* normal string */
11325         case SAVEt_SV:                          /* scalar reference */
11326             sv = (const SV *)POPPTR(ss,ix);
11327             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11328             /* fall through */
11329         case SAVEt_FREESV:
11330         case SAVEt_MORTALIZESV:
11331             sv = (const SV *)POPPTR(ss,ix);
11332             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11333             break;
11334         case SAVEt_SHARED_PVREF:                /* char* in shared space */
11335             c = (char*)POPPTR(ss,ix);
11336             TOPPTR(nss,ix) = savesharedpv(c);
11337             ptr = POPPTR(ss,ix);
11338             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11339             break;
11340         case SAVEt_GENERIC_SVREF:               /* generic sv */
11341         case SAVEt_SVREF:                       /* scalar reference */
11342             sv = (const SV *)POPPTR(ss,ix);
11343             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11344             ptr = POPPTR(ss,ix);
11345             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11346             break;
11347         case SAVEt_HV:                          /* hash reference */
11348         case SAVEt_AV:                          /* array reference */
11349             sv = (const SV *) POPPTR(ss,ix);
11350             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11351             /* fall through */
11352         case SAVEt_COMPPAD:
11353         case SAVEt_NSTAB:
11354             sv = (const SV *) POPPTR(ss,ix);
11355             TOPPTR(nss,ix) = sv_dup(sv, param);
11356             break;
11357         case SAVEt_INT:                         /* int reference */
11358             ptr = POPPTR(ss,ix);
11359             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11360             intval = (int)POPINT(ss,ix);
11361             TOPINT(nss,ix) = intval;
11362             break;
11363         case SAVEt_LONG:                        /* long reference */
11364             ptr = POPPTR(ss,ix);
11365             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11366             /* fall through */
11367         case SAVEt_CLEARSV:
11368             longval = (long)POPLONG(ss,ix);
11369             TOPLONG(nss,ix) = longval;
11370             break;
11371         case SAVEt_I32:                         /* I32 reference */
11372         case SAVEt_I16:                         /* I16 reference */
11373         case SAVEt_I8:                          /* I8 reference */
11374         case SAVEt_COP_ARYBASE:                 /* call CopARYBASE_set */
11375             ptr = POPPTR(ss,ix);
11376             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11377             i = POPINT(ss,ix);
11378             TOPINT(nss,ix) = i;
11379             break;
11380         case SAVEt_IV:                          /* IV reference */
11381             ptr = POPPTR(ss,ix);
11382             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11383             iv = POPIV(ss,ix);
11384             TOPIV(nss,ix) = iv;
11385             break;
11386         case SAVEt_HPTR:                        /* HV* reference */
11387         case SAVEt_APTR:                        /* AV* reference */
11388         case SAVEt_SPTR:                        /* SV* reference */
11389             ptr = POPPTR(ss,ix);
11390             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11391             sv = (const SV *)POPPTR(ss,ix);
11392             TOPPTR(nss,ix) = sv_dup(sv, param);
11393             break;
11394         case SAVEt_VPTR:                        /* random* reference */
11395             ptr = POPPTR(ss,ix);
11396             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11397             ptr = POPPTR(ss,ix);
11398             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11399             break;
11400         case SAVEt_GENERIC_PVREF:               /* generic char* */
11401         case SAVEt_PPTR:                        /* char* reference */
11402             ptr = POPPTR(ss,ix);
11403             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11404             c = (char*)POPPTR(ss,ix);
11405             TOPPTR(nss,ix) = pv_dup(c);
11406             break;
11407         case SAVEt_GP:                          /* scalar reference */
11408             gp = (GP*)POPPTR(ss,ix);
11409             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11410             (void)GpREFCNT_inc(gp);
11411             gv = (const GV *)POPPTR(ss,ix);
11412             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11413             break;
11414         case SAVEt_FREEOP:
11415             ptr = POPPTR(ss,ix);
11416             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11417                 /* these are assumed to be refcounted properly */
11418                 OP *o;
11419                 switch (((OP*)ptr)->op_type) {
11420                 case OP_LEAVESUB:
11421                 case OP_LEAVESUBLV:
11422                 case OP_LEAVEEVAL:
11423                 case OP_LEAVE:
11424                 case OP_SCOPE:
11425                 case OP_LEAVEWRITE:
11426                     TOPPTR(nss,ix) = ptr;
11427                     o = (OP*)ptr;
11428                     OP_REFCNT_LOCK;
11429                     (void) OpREFCNT_inc(o);
11430                     OP_REFCNT_UNLOCK;
11431                     break;
11432                 default:
11433                     TOPPTR(nss,ix) = NULL;
11434                     break;
11435                 }
11436             }
11437             else
11438                 TOPPTR(nss,ix) = NULL;
11439             break;
11440         case SAVEt_DELETE:
11441             hv = (const HV *)POPPTR(ss,ix);
11442             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11443             i = POPINT(ss,ix);
11444             TOPINT(nss,ix) = i;
11445             /* Fall through */
11446         case SAVEt_FREEPV:
11447             c = (char*)POPPTR(ss,ix);
11448             TOPPTR(nss,ix) = pv_dup_inc(c);
11449             break;
11450         case SAVEt_STACK_POS:           /* Position on Perl stack */
11451             i = POPINT(ss,ix);
11452             TOPINT(nss,ix) = i;
11453             break;
11454         case SAVEt_DESTRUCTOR:
11455             ptr = POPPTR(ss,ix);
11456             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11457             dptr = POPDPTR(ss,ix);
11458             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11459                                         any_dup(FPTR2DPTR(void *, dptr),
11460                                                 proto_perl));
11461             break;
11462         case SAVEt_DESTRUCTOR_X:
11463             ptr = POPPTR(ss,ix);
11464             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11465             dxptr = POPDXPTR(ss,ix);
11466             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11467                                          any_dup(FPTR2DPTR(void *, dxptr),
11468                                                  proto_perl));
11469             break;
11470         case SAVEt_REGCONTEXT:
11471         case SAVEt_ALLOC:
11472             i = POPINT(ss,ix);
11473             TOPINT(nss,ix) = i;
11474             ix -= i;
11475             break;
11476         case SAVEt_AELEM:               /* array element */
11477             sv = (const SV *)POPPTR(ss,ix);
11478             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11479             i = POPINT(ss,ix);
11480             TOPINT(nss,ix) = i;
11481             av = (const AV *)POPPTR(ss,ix);
11482             TOPPTR(nss,ix) = av_dup_inc(av, param);
11483             break;
11484         case SAVEt_OP:
11485             ptr = POPPTR(ss,ix);
11486             TOPPTR(nss,ix) = ptr;
11487             break;
11488         case SAVEt_HINTS:
11489             ptr = POPPTR(ss,ix);
11490             if (ptr) {
11491                 HINTS_REFCNT_LOCK;
11492                 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11493                 HINTS_REFCNT_UNLOCK;
11494             }
11495             TOPPTR(nss,ix) = ptr;
11496             i = POPINT(ss,ix);
11497             TOPINT(nss,ix) = i;
11498             if (i & HINT_LOCALIZE_HH) {
11499                 hv = (const HV *)POPPTR(ss,ix);
11500                 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11501             }
11502             break;
11503         case SAVEt_PADSV_AND_MORTALIZE:
11504             longval = (long)POPLONG(ss,ix);
11505             TOPLONG(nss,ix) = longval;
11506             ptr = POPPTR(ss,ix);
11507             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11508             sv = (const SV *)POPPTR(ss,ix);
11509             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11510             break;
11511         case SAVEt_BOOL:
11512             ptr = POPPTR(ss,ix);
11513             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11514             longval = (long)POPBOOL(ss,ix);
11515             TOPBOOL(nss,ix) = (bool)longval;
11516             break;
11517         case SAVEt_SET_SVFLAGS:
11518             i = POPINT(ss,ix);
11519             TOPINT(nss,ix) = i;
11520             i = POPINT(ss,ix);
11521             TOPINT(nss,ix) = i;
11522             sv = (const SV *)POPPTR(ss,ix);
11523             TOPPTR(nss,ix) = sv_dup(sv, param);
11524             break;
11525         case SAVEt_RE_STATE:
11526             {
11527                 const struct re_save_state *const old_state
11528                     = (struct re_save_state *)
11529                     (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11530                 struct re_save_state *const new_state
11531                     = (struct re_save_state *)
11532                     (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11533
11534                 Copy(old_state, new_state, 1, struct re_save_state);
11535                 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11536
11537                 new_state->re_state_bostr
11538                     = pv_dup(old_state->re_state_bostr);
11539                 new_state->re_state_reginput
11540                     = pv_dup(old_state->re_state_reginput);
11541                 new_state->re_state_regeol
11542                     = pv_dup(old_state->re_state_regeol);
11543                 new_state->re_state_regoffs
11544                     = (regexp_paren_pair*)
11545                         any_dup(old_state->re_state_regoffs, proto_perl);
11546                 new_state->re_state_reglastparen
11547                     = (U32*) any_dup(old_state->re_state_reglastparen,
11548                               proto_perl);
11549                 new_state->re_state_reglastcloseparen
11550                     = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11551                               proto_perl);
11552                 /* XXX This just has to be broken. The old save_re_context
11553                    code did SAVEGENERICPV(PL_reg_start_tmp);
11554                    PL_reg_start_tmp is char **.
11555                    Look above to what the dup code does for
11556                    SAVEt_GENERIC_PVREF
11557                    It can never have worked.
11558                    So this is merely a faithful copy of the exiting bug:  */
11559                 new_state->re_state_reg_start_tmp
11560                     = (char **) pv_dup((char *)
11561                                       old_state->re_state_reg_start_tmp);
11562                 /* I assume that it only ever "worked" because no-one called
11563                    (pseudo)fork while the regexp engine had re-entered itself.
11564                 */
11565 #ifdef PERL_OLD_COPY_ON_WRITE
11566                 new_state->re_state_nrs
11567                     = sv_dup(old_state->re_state_nrs, param);
11568 #endif
11569                 new_state->re_state_reg_magic
11570                     = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11571                                proto_perl);
11572                 new_state->re_state_reg_oldcurpm
11573                     = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11574                               proto_perl);
11575                 new_state->re_state_reg_curpm
11576                     = (PMOP*)  any_dup(old_state->re_state_reg_curpm,
11577                                proto_perl);
11578                 new_state->re_state_reg_oldsaved
11579                     = pv_dup(old_state->re_state_reg_oldsaved);
11580                 new_state->re_state_reg_poscache
11581                     = pv_dup(old_state->re_state_reg_poscache);
11582                 new_state->re_state_reg_starttry
11583                     = pv_dup(old_state->re_state_reg_starttry);
11584                 break;
11585             }
11586         case SAVEt_COMPILE_WARNINGS:
11587             ptr = POPPTR(ss,ix);
11588             TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11589             break;
11590         case SAVEt_PARSER:
11591             ptr = POPPTR(ss,ix);
11592             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11593             break;
11594         default:
11595             Perl_croak(aTHX_
11596                        "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11597         }
11598     }
11599
11600     return nss;
11601 }
11602
11603
11604 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11605  * flag to the result. This is done for each stash before cloning starts,
11606  * so we know which stashes want their objects cloned */
11607
11608 static void
11609 do_mark_cloneable_stash(pTHX_ SV *const sv)
11610 {
11611     const HEK * const hvname = HvNAME_HEK((const HV *)sv);
11612     if (hvname) {
11613         GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
11614         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11615         if (cloner && GvCV(cloner)) {
11616             dSP;
11617             UV status;
11618
11619             ENTER;
11620             SAVETMPS;
11621             PUSHMARK(SP);
11622             mXPUSHs(newSVhek(hvname));
11623             PUTBACK;
11624             call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
11625             SPAGAIN;
11626             status = POPu;
11627             PUTBACK;
11628             FREETMPS;
11629             LEAVE;
11630             if (status)
11631                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11632         }
11633     }
11634 }
11635
11636
11637
11638 /*
11639 =for apidoc perl_clone
11640
11641 Create and return a new interpreter by cloning the current one.
11642
11643 perl_clone takes these flags as parameters:
11644
11645 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11646 without it we only clone the data and zero the stacks,
11647 with it we copy the stacks and the new perl interpreter is
11648 ready to run at the exact same point as the previous one.
11649 The pseudo-fork code uses COPY_STACKS while the
11650 threads->create doesn't.
11651
11652 CLONEf_KEEP_PTR_TABLE
11653 perl_clone keeps a ptr_table with the pointer of the old
11654 variable as a key and the new variable as a value,
11655 this allows it to check if something has been cloned and not
11656 clone it again but rather just use the value and increase the
11657 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11658 the ptr_table using the function
11659 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11660 reason to keep it around is if you want to dup some of your own
11661 variable who are outside the graph perl scans, example of this
11662 code is in threads.xs create
11663
11664 CLONEf_CLONE_HOST
11665 This is a win32 thing, it is ignored on unix, it tells perls
11666 win32host code (which is c++) to clone itself, this is needed on
11667 win32 if you want to run two threads at the same time,
11668 if you just want to do some stuff in a separate perl interpreter
11669 and then throw it away and return to the original one,
11670 you don't need to do anything.
11671
11672 =cut
11673 */
11674
11675 /* XXX the above needs expanding by someone who actually understands it ! */
11676 EXTERN_C PerlInterpreter *
11677 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11678
11679 PerlInterpreter *
11680 perl_clone(PerlInterpreter *proto_perl, UV flags)
11681 {
11682    dVAR;
11683 #ifdef PERL_IMPLICIT_SYS
11684
11685     PERL_ARGS_ASSERT_PERL_CLONE;
11686
11687    /* perlhost.h so we need to call into it
11688    to clone the host, CPerlHost should have a c interface, sky */
11689
11690    if (flags & CLONEf_CLONE_HOST) {
11691        return perl_clone_host(proto_perl,flags);
11692    }
11693    return perl_clone_using(proto_perl, flags,
11694                             proto_perl->IMem,
11695                             proto_perl->IMemShared,
11696                             proto_perl->IMemParse,
11697                             proto_perl->IEnv,
11698                             proto_perl->IStdIO,
11699                             proto_perl->ILIO,
11700                             proto_perl->IDir,
11701                             proto_perl->ISock,
11702                             proto_perl->IProc);
11703 }
11704
11705 PerlInterpreter *
11706 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11707                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
11708                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11709                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11710                  struct IPerlDir* ipD, struct IPerlSock* ipS,
11711                  struct IPerlProc* ipP)
11712 {
11713     /* XXX many of the string copies here can be optimized if they're
11714      * constants; they need to be allocated as common memory and just
11715      * their pointers copied. */
11716
11717     IV i;
11718     CLONE_PARAMS clone_params;
11719     CLONE_PARAMS* const param = &clone_params;
11720
11721     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11722
11723     PERL_ARGS_ASSERT_PERL_CLONE_USING;
11724
11725     /* for each stash, determine whether its objects should be cloned */
11726     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11727     PERL_SET_THX(my_perl);
11728
11729 #  ifdef DEBUGGING
11730     PoisonNew(my_perl, 1, PerlInterpreter);
11731     PL_op = NULL;
11732     PL_curcop = NULL;
11733     PL_markstack = 0;
11734     PL_scopestack = 0;
11735     PL_savestack = 0;
11736     PL_savestack_ix = 0;
11737     PL_savestack_max = -1;
11738     PL_sig_pending = 0;
11739     PL_parser = NULL;
11740     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11741 #  else /* !DEBUGGING */
11742     Zero(my_perl, 1, PerlInterpreter);
11743 #  endif        /* DEBUGGING */
11744
11745     /* host pointers */
11746     PL_Mem              = ipM;
11747     PL_MemShared        = ipMS;
11748     PL_MemParse         = ipMP;
11749     PL_Env              = ipE;
11750     PL_StdIO            = ipStd;
11751     PL_LIO              = ipLIO;
11752     PL_Dir              = ipD;
11753     PL_Sock             = ipS;
11754     PL_Proc             = ipP;
11755 #else           /* !PERL_IMPLICIT_SYS */
11756     IV i;
11757     CLONE_PARAMS clone_params;
11758     CLONE_PARAMS* param = &clone_params;
11759     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11760
11761     PERL_ARGS_ASSERT_PERL_CLONE;
11762
11763     /* for each stash, determine whether its objects should be cloned */
11764     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11765     PERL_SET_THX(my_perl);
11766
11767 #    ifdef DEBUGGING
11768     PoisonNew(my_perl, 1, PerlInterpreter);
11769     PL_op = NULL;
11770     PL_curcop = NULL;
11771     PL_markstack = 0;
11772     PL_scopestack = 0;
11773     PL_savestack = 0;
11774     PL_savestack_ix = 0;
11775     PL_savestack_max = -1;
11776     PL_sig_pending = 0;
11777     PL_parser = NULL;
11778     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11779 #    else       /* !DEBUGGING */
11780     Zero(my_perl, 1, PerlInterpreter);
11781 #    endif      /* DEBUGGING */
11782 #endif          /* PERL_IMPLICIT_SYS */
11783     param->flags = flags;
11784     param->proto_perl = proto_perl;
11785
11786     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11787
11788     PL_body_arenas = NULL;
11789     Zero(&PL_body_roots, 1, PL_body_roots);
11790
11791     PL_nice_chunk       = NULL;
11792     PL_nice_chunk_size  = 0;
11793     PL_sv_count         = 0;
11794     PL_sv_objcount      = 0;
11795     PL_sv_root          = NULL;
11796     PL_sv_arenaroot     = NULL;
11797
11798     PL_debug            = proto_perl->Idebug;
11799
11800     PL_hash_seed        = proto_perl->Ihash_seed;
11801     PL_rehash_seed      = proto_perl->Irehash_seed;
11802
11803 #ifdef USE_REENTRANT_API
11804     /* XXX: things like -Dm will segfault here in perlio, but doing
11805      *  PERL_SET_CONTEXT(proto_perl);
11806      * breaks too many other things
11807      */
11808     Perl_reentrant_init(aTHX);
11809 #endif
11810
11811     /* create SV map for pointer relocation */
11812     PL_ptr_table = ptr_table_new();
11813
11814     /* initialize these special pointers as early as possible */
11815     SvANY(&PL_sv_undef)         = NULL;
11816     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
11817     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
11818     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11819
11820     SvANY(&PL_sv_no)            = new_XPVNV();
11821     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
11822     SvFLAGS(&PL_sv_no)          = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11823                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11824     SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
11825     SvCUR_set(&PL_sv_no, 0);
11826     SvLEN_set(&PL_sv_no, 1);
11827     SvIV_set(&PL_sv_no, 0);
11828     SvNV_set(&PL_sv_no, 0);
11829     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11830
11831     SvANY(&PL_sv_yes)           = new_XPVNV();
11832     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
11833     SvFLAGS(&PL_sv_yes)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11834                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11835     SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
11836     SvCUR_set(&PL_sv_yes, 1);
11837     SvLEN_set(&PL_sv_yes, 2);
11838     SvIV_set(&PL_sv_yes, 1);
11839     SvNV_set(&PL_sv_yes, 1);
11840     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11841
11842     /* create (a non-shared!) shared string table */
11843     PL_strtab           = newHV();
11844     HvSHAREKEYS_off(PL_strtab);
11845     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11846     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11847
11848     PL_compiling = proto_perl->Icompiling;
11849
11850     /* These two PVs will be free'd special way so must set them same way op.c does */
11851     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11852     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11853
11854     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
11855     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11856
11857     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11858     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
11859     if (PL_compiling.cop_hints_hash) {
11860         HINTS_REFCNT_LOCK;
11861         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
11862         HINTS_REFCNT_UNLOCK;
11863     }
11864     PL_curcop           = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
11865 #ifdef PERL_DEBUG_READONLY_OPS
11866     PL_slabs = NULL;
11867     PL_slab_count = 0;
11868 #endif
11869
11870     /* pseudo environmental stuff */
11871     PL_origargc         = proto_perl->Iorigargc;
11872     PL_origargv         = proto_perl->Iorigargv;
11873
11874     param->stashes      = newAV();  /* Setup array of objects to call clone on */
11875
11876     /* Set tainting stuff before PerlIO_debug can possibly get called */
11877     PL_tainting         = proto_perl->Itainting;
11878     PL_taint_warn       = proto_perl->Itaint_warn;
11879
11880 #ifdef PERLIO_LAYERS
11881     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11882     PerlIO_clone(aTHX_ proto_perl, param);
11883 #endif
11884
11885     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
11886     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
11887     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
11888     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
11889     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
11890     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
11891
11892     /* switches */
11893     PL_minus_c          = proto_perl->Iminus_c;
11894     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
11895     PL_localpatches     = proto_perl->Ilocalpatches;
11896     PL_splitstr         = proto_perl->Isplitstr;
11897     PL_minus_n          = proto_perl->Iminus_n;
11898     PL_minus_p          = proto_perl->Iminus_p;
11899     PL_minus_l          = proto_perl->Iminus_l;
11900     PL_minus_a          = proto_perl->Iminus_a;
11901     PL_minus_E          = proto_perl->Iminus_E;
11902     PL_minus_F          = proto_perl->Iminus_F;
11903     PL_doswitches       = proto_perl->Idoswitches;
11904     PL_dowarn           = proto_perl->Idowarn;
11905     PL_doextract        = proto_perl->Idoextract;
11906     PL_sawampersand     = proto_perl->Isawampersand;
11907     PL_unsafe           = proto_perl->Iunsafe;
11908     PL_inplace          = SAVEPV(proto_perl->Iinplace);
11909     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
11910     PL_perldb           = proto_perl->Iperldb;
11911     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11912     PL_exit_flags       = proto_perl->Iexit_flags;
11913
11914     /* magical thingies */
11915     /* XXX time(&PL_basetime) when asked for? */
11916     PL_basetime         = proto_perl->Ibasetime;
11917     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
11918
11919     PL_maxsysfd         = proto_perl->Imaxsysfd;
11920     PL_statusvalue      = proto_perl->Istatusvalue;
11921 #ifdef VMS
11922     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
11923 #else
11924     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11925 #endif
11926     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
11927
11928     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
11929     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
11930     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
11931
11932
11933     /* RE engine related */
11934     Zero(&PL_reg_state, 1, struct re_save_state);
11935     PL_reginterp_cnt    = 0;
11936     PL_regmatch_slab    = NULL;
11937
11938     /* Clone the regex array */
11939     /* ORANGE FIXME for plugins, probably in the SV dup code.
11940        newSViv(PTR2IV(CALLREGDUPE(
11941        INT2PTR(REGEXP *, SvIVX(regex)), param))))
11942     */
11943     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
11944     PL_regex_pad = AvARRAY(PL_regex_padav);
11945
11946     /* shortcuts to various I/O objects */
11947     PL_ofsgv            = gv_dup(proto_perl->Iofsgv, param);
11948     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
11949     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
11950     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
11951     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
11952     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
11953     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
11954
11955     /* shortcuts to regexp stuff */
11956     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
11957
11958     /* shortcuts to misc objects */
11959     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
11960
11961     /* shortcuts to debugging objects */
11962     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
11963     PL_DBline           = gv_dup(proto_perl->IDBline, param);
11964     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
11965     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
11966     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
11967     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
11968     PL_dbargs           = av_dup(proto_perl->Idbargs, param);
11969
11970     /* symbol tables */
11971     PL_defstash         = hv_dup_inc(proto_perl->Idefstash, param);
11972     PL_curstash         = hv_dup(proto_perl->Icurstash, param);
11973     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
11974     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
11975     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
11976
11977     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
11978     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
11979     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
11980     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
11981     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
11982     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
11983     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
11984     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
11985
11986     PL_sub_generation   = proto_perl->Isub_generation;
11987     PL_isarev           = hv_dup_inc(proto_perl->Iisarev, param);
11988
11989     /* funky return mechanisms */
11990     PL_forkprocess      = proto_perl->Iforkprocess;
11991
11992     /* subprocess state */
11993     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
11994
11995     /* internal state */
11996     PL_maxo             = proto_perl->Imaxo;
11997     if (proto_perl->Iop_mask)
11998         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11999     else
12000         PL_op_mask      = NULL;
12001     /* PL_asserting        = proto_perl->Iasserting; */
12002
12003     /* current interpreter roots */
12004     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
12005     OP_REFCNT_LOCK;
12006     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
12007     OP_REFCNT_UNLOCK;
12008     PL_main_start       = proto_perl->Imain_start;
12009     PL_eval_root        = proto_perl->Ieval_root;
12010     PL_eval_start       = proto_perl->Ieval_start;
12011
12012     /* runtime control stuff */
12013     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12014
12015     PL_filemode         = proto_perl->Ifilemode;
12016     PL_lastfd           = proto_perl->Ilastfd;
12017     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
12018     PL_Argv             = NULL;
12019     PL_Cmd              = NULL;
12020     PL_gensym           = proto_perl->Igensym;
12021     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
12022     PL_laststatval      = proto_perl->Ilaststatval;
12023     PL_laststype        = proto_perl->Ilaststype;
12024     PL_mess_sv          = NULL;
12025
12026     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
12027
12028     /* interpreter atexit processing */
12029     PL_exitlistlen      = proto_perl->Iexitlistlen;
12030     if (PL_exitlistlen) {
12031         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12032         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12033     }
12034     else
12035         PL_exitlist     = (PerlExitListEntry*)NULL;
12036
12037     PL_my_cxt_size = proto_perl->Imy_cxt_size;
12038     if (PL_my_cxt_size) {
12039         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12040         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12041 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12042         Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12043         Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12044 #endif
12045     }
12046     else {
12047         PL_my_cxt_list  = (void**)NULL;
12048 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12049         PL_my_cxt_keys  = (const char**)NULL;
12050 #endif
12051     }
12052     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
12053     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
12054     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12055
12056     PL_profiledata      = NULL;
12057
12058     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
12059
12060     PAD_CLONE_VARS(proto_perl, param);
12061
12062 #ifdef HAVE_INTERP_INTERN
12063     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12064 #endif
12065
12066     /* more statics moved here */
12067     PL_generation       = proto_perl->Igeneration;
12068     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
12069
12070     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
12071     PL_in_clean_all     = proto_perl->Iin_clean_all;
12072
12073     PL_uid              = proto_perl->Iuid;
12074     PL_euid             = proto_perl->Ieuid;
12075     PL_gid              = proto_perl->Igid;
12076     PL_egid             = proto_perl->Iegid;
12077     PL_nomemok          = proto_perl->Inomemok;
12078     PL_an               = proto_perl->Ian;
12079     PL_evalseq          = proto_perl->Ievalseq;
12080     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
12081     PL_origalen         = proto_perl->Iorigalen;
12082 #ifdef PERL_USES_PL_PIDSTATUS
12083     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
12084 #endif
12085     PL_osname           = SAVEPV(proto_perl->Iosname);
12086     PL_sighandlerp      = proto_perl->Isighandlerp;
12087
12088     PL_runops           = proto_perl->Irunops;
12089
12090     PL_parser           = parser_dup(proto_perl->Iparser, param);
12091
12092     PL_subline          = proto_perl->Isubline;
12093     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
12094
12095 #ifdef FCRYPT
12096     PL_cryptseen        = proto_perl->Icryptseen;
12097 #endif
12098
12099     PL_hints            = proto_perl->Ihints;
12100
12101     PL_amagic_generation        = proto_perl->Iamagic_generation;
12102
12103 #ifdef USE_LOCALE_COLLATE
12104     PL_collation_ix     = proto_perl->Icollation_ix;
12105     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
12106     PL_collation_standard       = proto_perl->Icollation_standard;
12107     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
12108     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
12109 #endif /* USE_LOCALE_COLLATE */
12110
12111 #ifdef USE_LOCALE_NUMERIC
12112     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
12113     PL_numeric_standard = proto_perl->Inumeric_standard;
12114     PL_numeric_local    = proto_perl->Inumeric_local;
12115     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12116 #endif /* !USE_LOCALE_NUMERIC */
12117
12118     /* utf8 character classes */
12119     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12120     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12121     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12122     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12123     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
12124     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12125     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
12126     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
12127     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
12128     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
12129     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
12130     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
12131     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12132     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
12133     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12134     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12135     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12136     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12137     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12138     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12139
12140     /* Did the locale setup indicate UTF-8? */
12141     PL_utf8locale       = proto_perl->Iutf8locale;
12142     /* Unicode features (see perlrun/-C) */
12143     PL_unicode          = proto_perl->Iunicode;
12144
12145     /* Pre-5.8 signals control */
12146     PL_signals          = proto_perl->Isignals;
12147
12148     /* times() ticks per second */
12149     PL_clocktick        = proto_perl->Iclocktick;
12150
12151     /* Recursion stopper for PerlIO_find_layer */
12152     PL_in_load_module   = proto_perl->Iin_load_module;
12153
12154     /* sort() routine */
12155     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
12156
12157     /* Not really needed/useful since the reenrant_retint is "volatile",
12158      * but do it for consistency's sake. */
12159     PL_reentrant_retint = proto_perl->Ireentrant_retint;
12160
12161     /* Hooks to shared SVs and locks. */
12162     PL_sharehook        = proto_perl->Isharehook;
12163     PL_lockhook         = proto_perl->Ilockhook;
12164     PL_unlockhook       = proto_perl->Iunlockhook;
12165     PL_threadhook       = proto_perl->Ithreadhook;
12166     PL_destroyhook      = proto_perl->Idestroyhook;
12167
12168 #ifdef THREADS_HAVE_PIDS
12169     PL_ppid             = proto_perl->Ippid;
12170 #endif
12171
12172     /* swatch cache */
12173     PL_last_swash_hv    = NULL; /* reinits on demand */
12174     PL_last_swash_klen  = 0;
12175     PL_last_swash_key[0]= '\0';
12176     PL_last_swash_tmps  = (U8*)NULL;
12177     PL_last_swash_slen  = 0;
12178
12179     PL_glob_index       = proto_perl->Iglob_index;
12180     PL_srand_called     = proto_perl->Isrand_called;
12181
12182     if (proto_perl->Ipsig_pend) {
12183         Newxz(PL_psig_pend, SIG_SIZE, int);
12184     }
12185     else {
12186         PL_psig_pend    = (int*)NULL;
12187     }
12188
12189     if (proto_perl->Ipsig_name) {
12190         Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
12191         sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
12192                             param);
12193         PL_psig_ptr = PL_psig_name + SIG_SIZE;
12194     }
12195     else {
12196         PL_psig_ptr     = (SV**)NULL;
12197         PL_psig_name    = (SV**)NULL;
12198     }
12199
12200     /* intrpvar.h stuff */
12201
12202     if (flags & CLONEf_COPY_STACKS) {
12203         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12204         PL_tmps_ix              = proto_perl->Itmps_ix;
12205         PL_tmps_max             = proto_perl->Itmps_max;
12206         PL_tmps_floor           = proto_perl->Itmps_floor;
12207         Newx(PL_tmps_stack, PL_tmps_max, SV*);
12208         sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, PL_tmps_ix,
12209                             param);
12210
12211         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12212         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12213         Newxz(PL_markstack, i, I32);
12214         PL_markstack_max        = PL_markstack + (proto_perl->Imarkstack_max
12215                                                   - proto_perl->Imarkstack);
12216         PL_markstack_ptr        = PL_markstack + (proto_perl->Imarkstack_ptr
12217                                                   - proto_perl->Imarkstack);
12218         Copy(proto_perl->Imarkstack, PL_markstack,
12219              PL_markstack_ptr - PL_markstack + 1, I32);
12220
12221         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12222          * NOTE: unlike the others! */
12223         PL_scopestack_ix        = proto_perl->Iscopestack_ix;
12224         PL_scopestack_max       = proto_perl->Iscopestack_max;
12225         Newxz(PL_scopestack, PL_scopestack_max, I32);
12226         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12227
12228         /* NOTE: si_dup() looks at PL_markstack */
12229         PL_curstackinfo         = si_dup(proto_perl->Icurstackinfo, param);
12230
12231         /* PL_curstack          = PL_curstackinfo->si_stack; */
12232         PL_curstack             = av_dup(proto_perl->Icurstack, param);
12233         PL_mainstack            = av_dup(proto_perl->Imainstack, param);
12234
12235         /* next PUSHs() etc. set *(PL_stack_sp+1) */
12236         PL_stack_base           = AvARRAY(PL_curstack);
12237         PL_stack_sp             = PL_stack_base + (proto_perl->Istack_sp
12238                                                    - proto_perl->Istack_base);
12239         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
12240
12241         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12242          * NOTE: unlike the others! */
12243         PL_savestack_ix         = proto_perl->Isavestack_ix;
12244         PL_savestack_max        = proto_perl->Isavestack_max;
12245         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12246         PL_savestack            = ss_dup(proto_perl, param);
12247     }
12248     else {
12249         init_stacks();
12250         ENTER;                  /* perl_destruct() wants to LEAVE; */
12251
12252         /* although we're not duplicating the tmps stack, we should still
12253          * add entries for any SVs on the tmps stack that got cloned by a
12254          * non-refcount means (eg a temp in @_); otherwise they will be
12255          * orphaned
12256          */
12257         for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12258             SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
12259                     proto_perl->Itmps_stack[i]));
12260             if (nsv && !SvREFCNT(nsv)) {
12261                 EXTEND_MORTAL(1);
12262                 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
12263             }
12264         }
12265     }
12266
12267     PL_start_env        = proto_perl->Istart_env;       /* XXXXXX */
12268     PL_top_env          = &PL_start_env;
12269
12270     PL_op               = proto_perl->Iop;
12271
12272     PL_Sv               = NULL;
12273     PL_Xpv              = (XPV*)NULL;
12274     my_perl->Ina        = proto_perl->Ina;
12275
12276     PL_statbuf          = proto_perl->Istatbuf;
12277     PL_statcache        = proto_perl->Istatcache;
12278     PL_statgv           = gv_dup(proto_perl->Istatgv, param);
12279     PL_statname         = sv_dup_inc(proto_perl->Istatname, param);
12280 #ifdef HAS_TIMES
12281     PL_timesbuf         = proto_perl->Itimesbuf;
12282 #endif
12283
12284     PL_tainted          = proto_perl->Itainted;
12285     PL_curpm            = proto_perl->Icurpm;   /* XXX No PMOP ref count */
12286     PL_rs               = sv_dup_inc(proto_perl->Irs, param);
12287     PL_last_in_gv       = gv_dup(proto_perl->Ilast_in_gv, param);
12288     PL_defoutgv         = gv_dup_inc(proto_perl->Idefoutgv, param);
12289     PL_chopset          = proto_perl->Ichopset; /* XXX never deallocated */
12290     PL_toptarget        = sv_dup_inc(proto_perl->Itoptarget, param);
12291     PL_bodytarget       = sv_dup_inc(proto_perl->Ibodytarget, param);
12292     PL_formtarget       = sv_dup(proto_perl->Iformtarget, param);
12293
12294     PL_restartop        = proto_perl->Irestartop;
12295     PL_in_eval          = proto_perl->Iin_eval;
12296     PL_delaymagic       = proto_perl->Idelaymagic;
12297     PL_dirty            = proto_perl->Idirty;
12298     PL_localizing       = proto_perl->Ilocalizing;
12299
12300     PL_errors           = sv_dup_inc(proto_perl->Ierrors, param);
12301     PL_hv_fetch_ent_mh  = NULL;
12302     PL_modcount         = proto_perl->Imodcount;
12303     PL_lastgotoprobe    = NULL;
12304     PL_dumpindent       = proto_perl->Idumpindent;
12305
12306     PL_sortcop          = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12307     PL_sortstash        = hv_dup(proto_perl->Isortstash, param);
12308     PL_firstgv          = gv_dup(proto_perl->Ifirstgv, param);
12309     PL_secondgv         = gv_dup(proto_perl->Isecondgv, param);
12310     PL_efloatbuf        = NULL;         /* reinits on demand */
12311     PL_efloatsize       = 0;                    /* reinits on demand */
12312
12313     /* regex stuff */
12314
12315     PL_screamfirst      = NULL;
12316     PL_screamnext       = NULL;
12317     PL_maxscream        = -1;                   /* reinits on demand */
12318     PL_lastscream       = NULL;
12319
12320
12321     PL_regdummy         = proto_perl->Iregdummy;
12322     PL_colorset         = 0;            /* reinits PL_colors[] */
12323     /*PL_colors[6]      = {0,0,0,0,0,0};*/
12324
12325
12326
12327     /* Pluggable optimizer */
12328     PL_peepp            = proto_perl->Ipeepp;
12329
12330     PL_stashcache       = newHV();
12331
12332     PL_watchaddr        = (char **) ptr_table_fetch(PL_ptr_table,
12333                                             proto_perl->Iwatchaddr);
12334     PL_watchok          = PL_watchaddr ? * PL_watchaddr : NULL;
12335     if (PL_debug && PL_watchaddr) {
12336         PerlIO_printf(Perl_debug_log,
12337           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12338           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12339           PTR2UV(PL_watchok));
12340     }
12341
12342     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
12343
12344     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12345         ptr_table_free(PL_ptr_table);
12346         PL_ptr_table = NULL;
12347     }
12348
12349     /* Call the ->CLONE method, if it exists, for each of the stashes
12350        identified by sv_dup() above.
12351     */
12352     while(av_len(param->stashes) != -1) {
12353         HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12354         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12355         if (cloner && GvCV(cloner)) {
12356             dSP;
12357             ENTER;
12358             SAVETMPS;
12359             PUSHMARK(SP);
12360             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12361             PUTBACK;
12362             call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
12363             FREETMPS;
12364             LEAVE;
12365         }
12366     }
12367
12368     SvREFCNT_dec(param->stashes);
12369
12370     /* orphaned? eg threads->new inside BEGIN or use */
12371     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12372         SvREFCNT_inc_simple_void(PL_compcv);
12373         SAVEFREESV(PL_compcv);
12374     }
12375
12376     return my_perl;
12377 }
12378
12379 #endif /* USE_ITHREADS */
12380
12381 /*
12382 =head1 Unicode Support
12383
12384 =for apidoc sv_recode_to_utf8
12385
12386 The encoding is assumed to be an Encode object, on entry the PV
12387 of the sv is assumed to be octets in that encoding, and the sv
12388 will be converted into Unicode (and UTF-8).
12389
12390 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12391 is not a reference, nothing is done to the sv.  If the encoding is not
12392 an C<Encode::XS> Encoding object, bad things will happen.
12393 (See F<lib/encoding.pm> and L<Encode>).
12394
12395 The PV of the sv is returned.
12396
12397 =cut */
12398
12399 char *
12400 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12401 {
12402     dVAR;
12403
12404     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12405
12406     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12407         SV *uni;
12408         STRLEN len;
12409         const char *s;
12410         dSP;
12411         ENTER;
12412         SAVETMPS;
12413         save_re_context();
12414         PUSHMARK(sp);
12415         EXTEND(SP, 3);
12416         XPUSHs(encoding);
12417         XPUSHs(sv);
12418 /*
12419   NI-S 2002/07/09
12420   Passing sv_yes is wrong - it needs to be or'ed set of constants
12421   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12422   remove converted chars from source.
12423
12424   Both will default the value - let them.
12425
12426         XPUSHs(&PL_sv_yes);
12427 */
12428         PUTBACK;
12429         call_method("decode", G_SCALAR);
12430         SPAGAIN;
12431         uni = POPs;
12432         PUTBACK;
12433         s = SvPV_const(uni, len);
12434         if (s != SvPVX_const(sv)) {
12435             SvGROW(sv, len + 1);
12436             Move(s, SvPVX(sv), len + 1, char);
12437             SvCUR_set(sv, len);
12438         }
12439         FREETMPS;
12440         LEAVE;
12441         SvUTF8_on(sv);
12442         return SvPVX(sv);
12443     }
12444     return SvPOKp(sv) ? SvPVX(sv) : NULL;
12445 }
12446
12447 /*
12448 =for apidoc sv_cat_decode
12449
12450 The encoding is assumed to be an Encode object, the PV of the ssv is
12451 assumed to be octets in that encoding and decoding the input starts
12452 from the position which (PV + *offset) pointed to.  The dsv will be
12453 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
12454 when the string tstr appears in decoding output or the input ends on
12455 the PV of the ssv. The value which the offset points will be modified
12456 to the last input position on the ssv.
12457
12458 Returns TRUE if the terminator was found, else returns FALSE.
12459
12460 =cut */
12461
12462 bool
12463 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12464                    SV *ssv, int *offset, char *tstr, int tlen)
12465 {
12466     dVAR;
12467     bool ret = FALSE;
12468
12469     PERL_ARGS_ASSERT_SV_CAT_DECODE;
12470
12471     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12472         SV *offsv;
12473         dSP;
12474         ENTER;
12475         SAVETMPS;
12476         save_re_context();
12477         PUSHMARK(sp);
12478         EXTEND(SP, 6);
12479         XPUSHs(encoding);
12480         XPUSHs(dsv);
12481         XPUSHs(ssv);
12482         offsv = newSViv(*offset);
12483         mXPUSHs(offsv);
12484         mXPUSHp(tstr, tlen);
12485         PUTBACK;
12486         call_method("cat_decode", G_SCALAR);
12487         SPAGAIN;
12488         ret = SvTRUE(TOPs);
12489         *offset = SvIV(offsv);
12490         PUTBACK;
12491         FREETMPS;
12492         LEAVE;
12493     }
12494     else
12495         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12496     return ret;
12497
12498 }
12499
12500 /* ---------------------------------------------------------------------
12501  *
12502  * support functions for report_uninit()
12503  */
12504
12505 /* the maxiumum size of array or hash where we will scan looking
12506  * for the undefined element that triggered the warning */
12507
12508 #define FUV_MAX_SEARCH_SIZE 1000
12509
12510 /* Look for an entry in the hash whose value has the same SV as val;
12511  * If so, return a mortal copy of the key. */
12512
12513 STATIC SV*
12514 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
12515 {
12516     dVAR;
12517     register HE **array;
12518     I32 i;
12519
12520     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12521
12522     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12523                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12524         return NULL;
12525
12526     array = HvARRAY(hv);
12527
12528     for (i=HvMAX(hv); i>0; i--) {
12529         register HE *entry;
12530         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12531             if (HeVAL(entry) != val)
12532                 continue;
12533             if (    HeVAL(entry) == &PL_sv_undef ||
12534                     HeVAL(entry) == &PL_sv_placeholder)
12535                 continue;
12536             if (!HeKEY(entry))
12537                 return NULL;
12538             if (HeKLEN(entry) == HEf_SVKEY)
12539                 return sv_mortalcopy(HeKEY_sv(entry));
12540             return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12541         }
12542     }
12543     return NULL;
12544 }
12545
12546 /* Look for an entry in the array whose value has the same SV as val;
12547  * If so, return the index, otherwise return -1. */
12548
12549 STATIC I32
12550 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
12551 {
12552     dVAR;
12553
12554     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12555
12556     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12557                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12558         return -1;
12559
12560     if (val != &PL_sv_undef) {
12561         SV ** const svp = AvARRAY(av);
12562         I32 i;
12563
12564         for (i=AvFILLp(av); i>=0; i--)
12565             if (svp[i] == val)
12566                 return i;
12567     }
12568     return -1;
12569 }
12570
12571 /* S_varname(): return the name of a variable, optionally with a subscript.
12572  * If gv is non-zero, use the name of that global, along with gvtype (one
12573  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12574  * targ.  Depending on the value of the subscript_type flag, return:
12575  */
12576
12577 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
12578 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
12579 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
12580 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
12581
12582 STATIC SV*
12583 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
12584         const SV *const keyname, I32 aindex, int subscript_type)
12585 {
12586
12587     SV * const name = sv_newmortal();
12588     if (gv) {
12589         char buffer[2];
12590         buffer[0] = gvtype;
12591         buffer[1] = 0;
12592
12593         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
12594
12595         gv_fullname4(name, gv, buffer, 0);
12596
12597         if ((unsigned int)SvPVX(name)[1] <= 26) {
12598             buffer[0] = '^';
12599             buffer[1] = SvPVX(name)[1] + 'A' - 1;
12600
12601             /* Swap the 1 unprintable control character for the 2 byte pretty
12602                version - ie substr($name, 1, 1) = $buffer; */
12603             sv_insert(name, 1, 1, buffer, 2);
12604         }
12605     }
12606     else {
12607         CV * const cv = find_runcv(NULL);
12608         SV *sv;
12609         AV *av;
12610
12611         if (!cv || !CvPADLIST(cv))
12612             return NULL;
12613         av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
12614         sv = *av_fetch(av, targ, FALSE);
12615         sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12616     }
12617
12618     if (subscript_type == FUV_SUBSCRIPT_HASH) {
12619         SV * const sv = newSV(0);
12620         *SvPVX(name) = '$';
12621         Perl_sv_catpvf(aTHX_ name, "{%s}",
12622             pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12623         SvREFCNT_dec(sv);
12624     }
12625     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12626         *SvPVX(name) = '$';
12627         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12628     }
12629     else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12630         /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12631         Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
12632     }
12633
12634     return name;
12635 }
12636
12637
12638 /*
12639 =for apidoc find_uninit_var
12640
12641 Find the name of the undefined variable (if any) that caused the operator o
12642 to issue a "Use of uninitialized value" warning.
12643 If match is true, only return a name if it's value matches uninit_sv.
12644 So roughly speaking, if a unary operator (such as OP_COS) generates a
12645 warning, then following the direct child of the op may yield an
12646 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12647 other hand, with OP_ADD there are two branches to follow, so we only print
12648 the variable name if we get an exact match.
12649
12650 The name is returned as a mortal SV.
12651
12652 Assumes that PL_op is the op that originally triggered the error, and that
12653 PL_comppad/PL_curpad points to the currently executing pad.
12654
12655 =cut
12656 */
12657
12658 STATIC SV *
12659 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
12660                   bool match)
12661 {
12662     dVAR;
12663     SV *sv;
12664     const GV *gv;
12665     const OP *o, *o2, *kid;
12666
12667     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12668                             uninit_sv == &PL_sv_placeholder)))
12669         return NULL;
12670
12671     switch (obase->op_type) {
12672
12673     case OP_RV2AV:
12674     case OP_RV2HV:
12675     case OP_PADAV:
12676     case OP_PADHV:
12677       {
12678         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12679         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12680         I32 index = 0;
12681         SV *keysv = NULL;
12682         int subscript_type = FUV_SUBSCRIPT_WITHIN;
12683
12684         if (pad) { /* @lex, %lex */
12685             sv = PAD_SVl(obase->op_targ);
12686             gv = NULL;
12687         }
12688         else {
12689             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12690             /* @global, %global */
12691                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12692                 if (!gv)
12693                     break;
12694                 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
12695             }
12696             else /* @{expr}, %{expr} */
12697                 return find_uninit_var(cUNOPx(obase)->op_first,
12698                                                     uninit_sv, match);
12699         }
12700
12701         /* attempt to find a match within the aggregate */
12702         if (hash) {
12703             keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12704             if (keysv)
12705                 subscript_type = FUV_SUBSCRIPT_HASH;
12706         }
12707         else {
12708             index = find_array_subscript((const AV *)sv, uninit_sv);
12709             if (index >= 0)
12710                 subscript_type = FUV_SUBSCRIPT_ARRAY;
12711         }
12712
12713         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12714             break;
12715
12716         return varname(gv, hash ? '%' : '@', obase->op_targ,
12717                                     keysv, index, subscript_type);
12718       }
12719
12720     case OP_PADSV:
12721         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12722             break;
12723         return varname(NULL, '$', obase->op_targ,
12724                                     NULL, 0, FUV_SUBSCRIPT_NONE);
12725
12726     case OP_GVSV:
12727         gv = cGVOPx_gv(obase);
12728         if (!gv || (match && GvSV(gv) != uninit_sv))
12729             break;
12730         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12731
12732     case OP_AELEMFAST:
12733         if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12734             if (match) {
12735                 SV **svp;
12736                 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
12737                 if (!av || SvRMAGICAL(av))
12738                     break;
12739                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12740                 if (!svp || *svp != uninit_sv)
12741                     break;
12742             }
12743             return varname(NULL, '$', obase->op_targ,
12744                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12745         }
12746         else {
12747             gv = cGVOPx_gv(obase);
12748             if (!gv)
12749                 break;
12750             if (match) {
12751                 SV **svp;
12752                 AV *const av = GvAV(gv);
12753                 if (!av || SvRMAGICAL(av))
12754                     break;
12755                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12756                 if (!svp || *svp != uninit_sv)
12757                     break;
12758             }
12759             return varname(gv, '$', 0,
12760                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12761         }
12762         break;
12763
12764     case OP_EXISTS:
12765         o = cUNOPx(obase)->op_first;
12766         if (!o || o->op_type != OP_NULL ||
12767                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12768             break;
12769         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12770
12771     case OP_AELEM:
12772     case OP_HELEM:
12773         if (PL_op == obase)
12774             /* $a[uninit_expr] or $h{uninit_expr} */
12775             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12776
12777         gv = NULL;
12778         o = cBINOPx(obase)->op_first;
12779         kid = cBINOPx(obase)->op_last;
12780
12781         /* get the av or hv, and optionally the gv */
12782         sv = NULL;
12783         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12784             sv = PAD_SV(o->op_targ);
12785         }
12786         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12787                 && cUNOPo->op_first->op_type == OP_GV)
12788         {
12789             gv = cGVOPx_gv(cUNOPo->op_first);
12790             if (!gv)
12791                 break;
12792             sv = o->op_type
12793                 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
12794         }
12795         if (!sv)
12796             break;
12797
12798         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
12799             /* index is constant */
12800             if (match) {
12801                 if (SvMAGICAL(sv))
12802                     break;
12803                 if (obase->op_type == OP_HELEM) {
12804                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
12805                     if (!he || HeVAL(he) != uninit_sv)
12806                         break;
12807                 }
12808                 else {
12809                     SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
12810                     if (!svp || *svp != uninit_sv)
12811                         break;
12812                 }
12813             }
12814             if (obase->op_type == OP_HELEM)
12815                 return varname(gv, '%', o->op_targ,
12816                             cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
12817             else
12818                 return varname(gv, '@', o->op_targ, NULL,
12819                             SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
12820         }
12821         else  {
12822             /* index is an expression;
12823              * attempt to find a match within the aggregate */
12824             if (obase->op_type == OP_HELEM) {
12825                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12826                 if (keysv)
12827                     return varname(gv, '%', o->op_targ,
12828                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
12829             }
12830             else {
12831                 const I32 index
12832                     = find_array_subscript((const AV *)sv, uninit_sv);
12833                 if (index >= 0)
12834                     return varname(gv, '@', o->op_targ,
12835                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
12836             }
12837             if (match)
12838                 break;
12839             return varname(gv,
12840                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
12841                 ? '@' : '%',
12842                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
12843         }
12844         break;
12845
12846     case OP_AASSIGN:
12847         /* only examine RHS */
12848         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
12849
12850     case OP_OPEN:
12851         o = cUNOPx(obase)->op_first;
12852         if (o->op_type == OP_PUSHMARK)
12853             o = o->op_sibling;
12854
12855         if (!o->op_sibling) {
12856             /* one-arg version of open is highly magical */
12857
12858             if (o->op_type == OP_GV) { /* open FOO; */
12859                 gv = cGVOPx_gv(o);
12860                 if (match && GvSV(gv) != uninit_sv)
12861                     break;
12862                 return varname(gv, '$', 0,
12863                             NULL, 0, FUV_SUBSCRIPT_NONE);
12864             }
12865             /* other possibilities not handled are:
12866              * open $x; or open my $x;  should return '${*$x}'
12867              * open expr;               should return '$'.expr ideally
12868              */
12869              break;
12870         }
12871         goto do_op;
12872
12873     /* ops where $_ may be an implicit arg */
12874     case OP_TRANS:
12875     case OP_SUBST:
12876     case OP_MATCH:
12877         if ( !(obase->op_flags & OPf_STACKED)) {
12878             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
12879                                  ? PAD_SVl(obase->op_targ)
12880                                  : DEFSV))
12881             {
12882                 sv = sv_newmortal();
12883                 sv_setpvs(sv, "$_");
12884                 return sv;
12885             }
12886         }
12887         goto do_op;
12888
12889     case OP_PRTF:
12890     case OP_PRINT:
12891     case OP_SAY:
12892         match = 1; /* print etc can return undef on defined args */
12893         /* skip filehandle as it can't produce 'undef' warning  */
12894         o = cUNOPx(obase)->op_first;
12895         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
12896             o = o->op_sibling->op_sibling;
12897         goto do_op2;
12898
12899
12900     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
12901     case OP_RV2SV:
12902     case OP_CUSTOM: /* XS or custom code could trigger random warnings */
12903
12904         /* the following ops are capable of returning PL_sv_undef even for
12905          * defined arg(s) */
12906
12907     case OP_BACKTICK:
12908     case OP_PIPE_OP:
12909     case OP_FILENO:
12910     case OP_BINMODE:
12911     case OP_TIED:
12912     case OP_GETC:
12913     case OP_SYSREAD:
12914     case OP_SEND:
12915     case OP_IOCTL:
12916     case OP_SOCKET:
12917     case OP_SOCKPAIR:
12918     case OP_BIND:
12919     case OP_CONNECT:
12920     case OP_LISTEN:
12921     case OP_ACCEPT:
12922     case OP_SHUTDOWN:
12923     case OP_SSOCKOPT:
12924     case OP_GETPEERNAME:
12925     case OP_FTRREAD:
12926     case OP_FTRWRITE:
12927     case OP_FTREXEC:
12928     case OP_FTROWNED:
12929     case OP_FTEREAD:
12930     case OP_FTEWRITE:
12931     case OP_FTEEXEC:
12932     case OP_FTEOWNED:
12933     case OP_FTIS:
12934     case OP_FTZERO:
12935     case OP_FTSIZE:
12936     case OP_FTFILE:
12937     case OP_FTDIR:
12938     case OP_FTLINK:
12939     case OP_FTPIPE:
12940     case OP_FTSOCK:
12941     case OP_FTBLK:
12942     case OP_FTCHR:
12943     case OP_FTTTY:
12944     case OP_FTSUID:
12945     case OP_FTSGID:
12946     case OP_FTSVTX:
12947     case OP_FTTEXT:
12948     case OP_FTBINARY:
12949     case OP_FTMTIME:
12950     case OP_FTATIME:
12951     case OP_FTCTIME:
12952     case OP_READLINK:
12953     case OP_OPEN_DIR:
12954     case OP_READDIR:
12955     case OP_TELLDIR:
12956     case OP_SEEKDIR:
12957     case OP_REWINDDIR:
12958     case OP_CLOSEDIR:
12959     case OP_GMTIME:
12960     case OP_ALARM:
12961     case OP_SEMGET:
12962     case OP_GETLOGIN:
12963     case OP_UNDEF:
12964     case OP_SUBSTR:
12965     case OP_AEACH:
12966     case OP_EACH:
12967     case OP_SORT:
12968     case OP_CALLER:
12969     case OP_DOFILE:
12970     case OP_PROTOTYPE:
12971     case OP_NCMP:
12972     case OP_SMARTMATCH:
12973     case OP_UNPACK:
12974     case OP_SYSOPEN:
12975     case OP_SYSSEEK:
12976         match = 1;
12977         goto do_op;
12978
12979     case OP_ENTERSUB:
12980     case OP_GOTO:
12981         /* XXX tmp hack: these two may call an XS sub, and currently
12982           XS subs don't have a SUB entry on the context stack, so CV and
12983           pad determination goes wrong, and BAD things happen. So, just
12984           don't try to determine the value under those circumstances.
12985           Need a better fix at dome point. DAPM 11/2007 */
12986         break;
12987
12988     case OP_FLIP:
12989     case OP_FLOP:
12990     {
12991         GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
12992         if (gv && GvSV(gv) == uninit_sv)
12993             return newSVpvs_flags("$.", SVs_TEMP);
12994         goto do_op;
12995     }
12996
12997     case OP_POS:
12998         /* def-ness of rval pos() is independent of the def-ness of its arg */
12999         if ( !(obase->op_flags & OPf_MOD))
13000             break;
13001
13002     case OP_SCHOMP:
13003     case OP_CHOMP:
13004         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13005             return newSVpvs_flags("${$/}", SVs_TEMP);
13006         /*FALLTHROUGH*/
13007
13008     default:
13009     do_op:
13010         if (!(obase->op_flags & OPf_KIDS))
13011             break;
13012         o = cUNOPx(obase)->op_first;
13013
13014     do_op2:
13015         if (!o)
13016             break;
13017
13018         /* if all except one arg are constant, or have no side-effects,
13019          * or are optimized away, then it's unambiguous */
13020         o2 = NULL;
13021         for (kid=o; kid; kid = kid->op_sibling) {
13022             if (kid) {
13023                 const OPCODE type = kid->op_type;
13024                 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13025                   || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
13026                   || (type == OP_PUSHMARK)
13027                 )
13028                 continue;
13029             }
13030             if (o2) { /* more than one found */
13031                 o2 = NULL;
13032                 break;
13033             }
13034             o2 = kid;
13035         }
13036         if (o2)
13037             return find_uninit_var(o2, uninit_sv, match);
13038
13039         /* scan all args */
13040         while (o) {
13041             sv = find_uninit_var(o, uninit_sv, 1);
13042             if (sv)
13043                 return sv;
13044             o = o->op_sibling;
13045         }
13046         break;
13047     }
13048     return NULL;
13049 }
13050
13051
13052 /*
13053 =for apidoc report_uninit
13054
13055 Print appropriate "Use of uninitialized variable" warning
13056
13057 =cut
13058 */
13059
13060 void
13061 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13062 {
13063     dVAR;
13064     if (PL_op) {
13065         SV* varname = NULL;
13066         if (uninit_sv) {
13067             varname = find_uninit_var(PL_op, uninit_sv,0);
13068             if (varname)
13069                 sv_insert(varname, 0, 0, " ", 1);
13070         }
13071         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13072                 varname ? SvPV_nolen_const(varname) : "",
13073                 " in ", OP_DESC(PL_op));
13074     }
13075     else
13076         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13077                     "", "", "");
13078 }
13079
13080 /*
13081  * Local variables:
13082  * c-indentation-style: bsd
13083  * c-basic-offset: 4
13084  * indent-tabs-mode: t
13085  * End:
13086  *
13087  * ex: set ts=8 sts=4 sw=4 noet:
13088  */