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 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
  10  *
  11  *
  12  * This file contains the code that creates, manipulates and destroys
  13  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
  14  * structure of an SV, so their creation and destruction is handled
  15  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
  16  * level functions (eg. substr, split, join) for each of the types are
  17  * in the pp*.c files.
  18  */
  19
  20 #include "EXTERN.h"
  21 #define PERL_IN_SV_C
  22 #include "perl.h"
  23 #include "regcomp.h"
  24
  25 #define FCALL *f
  26
  27 #ifdef __Lynx__
  28 /* Missing proto on LynxOS */
  29   char *gconvert(double, int, int,  char *);
  30 #endif
  31
  32 #ifdef PERL_UTF8_CACHE_ASSERT
  33 /* if adding more checks watch out for the following tests:
  34  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
  35  *   lib/utf8.t lib/Unicode/Collate/t/index.t
  36  * --jhi
  37  */
  38 #   define ASSERT_UTF8_CACHE(cache) \
  39     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
  40                               assert((cache)[2] <= (cache)[3]); \
  41                               assert((cache)[3] <= (cache)[1]);} \
  42                               } STMT_END
  43 #else
  44 #   define ASSERT_UTF8_CACHE(cache) NOOP
  45 #endif
  46
  47 #ifdef PERL_OLD_COPY_ON_WRITE
  48 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
  49 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
  50 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
  51    on-write.  */
  52 #endif
  53
  54 /* ============================================================================
  55
  56 =head1 Allocation and deallocation of SVs.
  57
  58 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
  59 sv, av, hv...) contains type and reference count information, and for
  60 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
  61 contains fields specific to each type.  Some types store all they need
  62 in the head, so don't have a body.
  63
  64 In all but the most memory-paranoid configuations (ex: PURIFY), heads
  65 and bodies are allocated out of arenas, which by default are
  66 approximately 4K chunks of memory parcelled up into N heads or bodies.
  67 Sv-bodies are allocated by their sv-type, guaranteeing size
  68 consistency needed to allocate safely from arrays.
  69
  70 For SV-heads, the first slot in each arena is reserved, and holds a
  71 link to the next arena, some flags, and a note of the number of slots.
  72 Snaked through each arena chain is a linked list of free items; when
  73 this becomes empty, an extra arena is allocated and divided up into N
  74 items which are threaded into the free list.
  75
  76 SV-bodies are similar, but they use arena-sets by default, which
  77 separate the link and info from the arena itself, and reclaim the 1st
  78 slot in the arena.  SV-bodies are further described later.
  79
  80 The following global variables are associated with arenas:
  81
  82     PL_sv_arenaroot     pointer to list of SV arenas
  83     PL_sv_root          pointer to list of free SV structures
  84
  85     PL_body_arenas      head of linked-list of body arenas
  86     PL_body_roots[]     array of pointers to list of free bodies of svtype
  87                         arrays are indexed by the svtype needed
  88
  89 A few special SV heads are not allocated from an arena, but are
  90 instead directly created in the interpreter structure, eg PL_sv_undef.
  91 The size of arenas can be changed from the default by setting
  92 PERL_ARENA_SIZE appropriately at compile time.
  93
  94 The SV arena serves the secondary purpose of allowing still-live SVs
  95 to be located and destroyed during final cleanup.
  96
  97 At the lowest level, the macros new_SV() and del_SV() grab and free
  98 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
  99 to return the SV to the free list with error checking.) new_SV() calls
 100 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
 101 SVs in the free list have their SvTYPE field set to all ones.
 102
 103 At the time of very final cleanup, sv_free_arenas() is called from
 104 perl_destruct() to physically free all the arenas allocated since the
 105 start of the interpreter.
 106
 107 The function visit() scans the SV arenas list, and calls a specified
 108 function for each SV it finds which is still live - ie which has an SvTYPE
 109 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
 110 following functions (specified as [function that calls visit()] / [function
 111 called by visit() for each SV]):
 112
 113     sv_report_used() / do_report_used()
 114                         dump all remaining SVs (debugging aid)
 115
 116     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
 117                         Attempt to free all objects pointed to by RVs,
 118                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
 119                         try to do the same for all objects indirectly
 120                         referenced by typeglobs too.  Called once from
 121                         perl_destruct(), prior to calling sv_clean_all()
 122                         below.
 123
 124     sv_clean_all() / do_clean_all()
 125                         SvREFCNT_dec(sv) each remaining SV, possibly
 126                         triggering an sv_free(). It also sets the
 127                         SVf_BREAK flag on the SV to indicate that the
 128                         refcnt has been artificially lowered, and thus
 129                         stopping sv_free() from giving spurious warnings
 130                         about SVs which unexpectedly have a refcnt
 131                         of zero.  called repeatedly from perl_destruct()
 132                         until there are no SVs left.
 133
 134 =head2 Arena allocator API Summary
 135
 136 Private API to rest of sv.c
 137
 138     new_SV(),  del_SV(),
 139
 140     new_XIV(), del_XIV(),
 141     new_XNV(), del_XNV(),
 142     etc
 143
 144 Public API:
 145
 146     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
 147
 148 =cut
 149
 150 ============================================================================ */
 151
 152 /*
 153  * "A time to plant, and a time to uproot what was planted..."
 154  */
 155
 156 void
 157 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
 158 {
 159     dVAR;
 160     void *new_chunk;
 161     U32 new_chunk_size;
 162
 163     PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
 164
 165     new_chunk = (void *)(chunk);
 166     new_chunk_size = (chunk_size);
 167     if (new_chunk_size > PL_nice_chunk_size) {
 168         Safefree(PL_nice_chunk);
 169         PL_nice_chunk = (char *) new_chunk;
 170         PL_nice_chunk_size = new_chunk_size;
 171     } else {
 172         Safefree(chunk);
 173     }
 174 }
 175
 176 #ifdef PERL_MEM_LOG
 177 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
 178             Perl_mem_log_new_sv(sv, file, line, func)
 179 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
 180             Perl_mem_log_del_sv(sv, file, line, func)
 181 #else
 182 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
 183 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
 184 #endif
 185
 186 #ifdef DEBUG_LEAKING_SCALARS
 187 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
 188 #  define DEBUG_SV_SERIAL(sv)                                               \
 189     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
 190             PTR2UV(sv), (long)(sv)->sv_debug_serial))
 191 #else
 192 #  define FREE_SV_DEBUG_FILE(sv)
 193 #  define DEBUG_SV_SERIAL(sv)   NOOP
 194 #endif
 195
 196 #ifdef PERL_POISON
 197 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
 198 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = (SV *)(val)
 199 /* Whilst I'd love to do this, it seems that things like to check on
 200    unreferenced scalars
 201 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
 202 */
 203 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
 204                                 PoisonNew(&SvREFCNT(sv), 1, U32)
 205 #else
 206 #  define SvARENA_CHAIN(sv)     SvANY(sv)
 207 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
 208 #  define POSION_SV_HEAD(sv)
 209 #endif
 210
 211 /* Mark an SV head as unused, and add to free list.
 212  *
 213  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
 214  * its refcount artificially decremented during global destruction, so
 215  * there may be dangling pointers to it. The last thing we want in that
 216  * case is for it to be reused. */
 217
 218 #define plant_SV(p) \
 219     STMT_START {                                        \
 220         const U32 old_flags = SvFLAGS(p);                       \
 221         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 222         DEBUG_SV_SERIAL(p);                             \
 223         FREE_SV_DEBUG_FILE(p);                          \
 224         POSION_SV_HEAD(p);                              \
 225         SvFLAGS(p) = SVTYPEMASK;                        \
 226         if (!(old_flags & SVf_BREAK)) {         \
 227             SvARENA_CHAIN_SET(p, PL_sv_root);   \
 228             PL_sv_root = (p);                           \
 229         }                                               \
 230         --PL_sv_count;                                  \
 231     } STMT_END
 232
 233 #define uproot_SV(p) \
 234     STMT_START {                                        \
 235         (p) = PL_sv_root;                               \
 236         PL_sv_root = (SV*)SvARENA_CHAIN(p);             \
 237         ++PL_sv_count;                                  \
 238     } STMT_END
 239
 240
 241 /* make some more SVs by adding another arena */
 242
 243 STATIC SV*
 244 S_more_sv(pTHX)
 245 {
 246     dVAR;
 247     SV* sv;
 248
 249     if (PL_nice_chunk) {
 250         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 251         PL_nice_chunk = NULL;
 252         PL_nice_chunk_size = 0;
 253     }
 254     else {
 255         char *chunk;                /* must use New here to match call to */
 256         Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
 257         sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
 258     }
 259     uproot_SV(sv);
 260     return sv;
 261 }
 262
 263 /* new_SV(): return a new, empty SV head */
 264
 265 #ifdef DEBUG_LEAKING_SCALARS
 266 /* provide a real function for a debugger to play with */
 267 STATIC SV*
 268 S_new_SV(pTHX_ const char *file, int line, const char *func)
 269 {
 270     SV* sv;
 271
 272     if (PL_sv_root)
 273         uproot_SV(sv);
 274     else
 275         sv = S_more_sv(aTHX);
 276     SvANY(sv) = 0;
 277     SvREFCNT(sv) = 1;
 278     SvFLAGS(sv) = 0;
 279     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
 280     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
 281                 ? PL_parser->copline
 282                 :  PL_curcop
 283                     ? CopLINE(PL_curcop)
 284                     : 0
 285             );
 286     sv->sv_debug_inpad = 0;
 287     sv->sv_debug_cloned = 0;
 288     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 289
 290     sv->sv_debug_serial = PL_sv_serial++;
 291
 292     MEM_LOG_NEW_SV(sv, file, line, func);
 293     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
 294             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
 295
 296     return sv;
 297 }
 298 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
 299
 300 #else
 301 #  define new_SV(p) \
 302     STMT_START {                                        \
 303         if (PL_sv_root)                                 \
 304             uproot_SV(p);                               \
 305         else                                            \
 306             (p) = S_more_sv(aTHX);                      \
 307         SvANY(p) = 0;                                   \
 308         SvREFCNT(p) = 1;                                \
 309         SvFLAGS(p) = 0;                                 \
 310         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 311     } STMT_END
 312 #endif
 313
 314
 315 /* del_SV(): return an empty SV head to the free list */
 316
 317 #ifdef DEBUGGING
 318
 319 #define del_SV(p) \
 320     STMT_START {                                        \
 321         if (DEBUG_D_TEST)                               \
 322             del_sv(p);                                  \
 323         else                                            \
 324             plant_SV(p);                                \
 325     } STMT_END
 326
 327 STATIC void
 328 S_del_sv(pTHX_ SV *p)
 329 {
 330     dVAR;
 331
 332     PERL_ARGS_ASSERT_DEL_SV;
 333
 334     if (DEBUG_D_TEST) {
 335         SV* sva;
 336         bool ok = 0;
 337         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
 338             const SV * const sv = sva + 1;
 339             const SV * const svend = &sva[SvREFCNT(sva)];
 340             if (p >= sv && p < svend) {
 341                 ok = 1;
 342                 break;
 343             }
 344         }
 345         if (!ok) {
 346             if (ckWARN_d(WARN_INTERNAL))
 347                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 348                             "Attempt to free non-arena SV: 0x%"UVxf
 349                             pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
 350             return;
 351         }
 352     }
 353     plant_SV(p);
 354 }
 355
 356 #else /* ! DEBUGGING */
 357
 358 #define del_SV(p)   plant_SV(p)
 359
 360 #endif /* DEBUGGING */
 361
 362
 363 /*
 364 =head1 SV Manipulation Functions
 365
 366 =for apidoc sv_add_arena
 367
 368 Given a chunk of memory, link it to the head of the list of arenas,
 369 and split it into a list of free SVs.
 370
 371 =cut
 372 */
 373
 374 void
 375 Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
 376 {
 377     dVAR;
 378     SV* const sva = (SV*)ptr;
 379     register SV* sv;
 380     register SV* svend;
 381
 382     PERL_ARGS_ASSERT_SV_ADD_ARENA;
 383
 384     /* The first SV in an arena isn't an SV. */
 385     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 386     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 387     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 388
 389     PL_sv_arenaroot = sva;
 390     PL_sv_root = sva + 1;
 391
 392     svend = &sva[SvREFCNT(sva) - 1];
 393     sv = sva + 1;
 394     while (sv < svend) {
 395         SvARENA_CHAIN_SET(sv, (sv + 1));
 396 #ifdef DEBUGGING
 397         SvREFCNT(sv) = 0;
 398 #endif
 399         /* Must always set typemask because it's always checked in on cleanup
 400            when the arenas are walked looking for objects.  */
 401         SvFLAGS(sv) = SVTYPEMASK;
 402         sv++;
 403     }
 404     SvARENA_CHAIN_SET(sv, 0);
 405 #ifdef DEBUGGING
 406     SvREFCNT(sv) = 0;
 407 #endif
 408     SvFLAGS(sv) = SVTYPEMASK;
 409 }
 410
 411 /* visit(): call the named function for each non-free SV in the arenas
 412  * whose flags field matches the flags/mask args. */
 413
 414 STATIC I32
 415 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
 416 {
 417     dVAR;
 418     SV* sva;
 419     I32 visited = 0;
 420
 421     PERL_ARGS_ASSERT_VISIT;
 422
 423     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 424         register const SV * const svend = &sva[SvREFCNT(sva)];
 425         register SV* sv;
 426         for (sv = sva + 1; sv < svend; ++sv) {
 427             if (SvTYPE(sv) != SVTYPEMASK
 428                     && (sv->sv_flags & mask) == flags
 429                     && SvREFCNT(sv))
 430             {
 431                 (FCALL)(aTHX_ sv);
 432                 ++visited;
 433             }
 434         }
 435     }
 436     return visited;
 437 }
 438
 439 #ifdef DEBUGGING
 440
 441 /* called by sv_report_used() for each live SV */
 442
 443 static void
 444 do_report_used(pTHX_ SV *const sv)
 445 {
 446     if (SvTYPE(sv) != SVTYPEMASK) {
 447         PerlIO_printf(Perl_debug_log, "****\n");
 448         sv_dump(sv);
 449     }
 450 }
 451 #endif
 452
 453 /*
 454 =for apidoc sv_report_used
 455
 456 Dump the contents of all SVs not yet freed. (Debugging aid).
 457
 458 =cut
 459 */
 460
 461 void
 462 Perl_sv_report_used(pTHX)
 463 {
 464 #ifdef DEBUGGING
 465     visit(do_report_used, 0, 0);
 466 #else
 467     PERL_UNUSED_CONTEXT;
 468 #endif
 469 }
 470
 471 /* called by sv_clean_objs() for each live SV */
 472
 473 static void
 474 do_clean_objs(pTHX_ SV *const ref)
 475 {
 476     dVAR;
 477     assert (SvROK(ref));
 478     {
 479         SV * const target = SvRV(ref);
 480         if (SvOBJECT(target)) {
 481             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
 482             if (SvWEAKREF(ref)) {
 483                 sv_del_backref(target, ref);
 484                 SvWEAKREF_off(ref);
 485                 SvRV_set(ref, NULL);
 486             } else {
 487                 SvROK_off(ref);
 488                 SvRV_set(ref, NULL);
 489                 SvREFCNT_dec(target);
 490             }
 491         }
 492     }
 493
 494     /* XXX Might want to check arrays, etc. */
 495 }
 496
 497 /* called by sv_clean_objs() for each live SV */
 498
 499 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 500 static void
 501 do_clean_named_objs(pTHX_ SV *const sv)
 502 {
 503     dVAR;
 504     assert(SvTYPE(sv) == SVt_PVGV);
 505     assert(isGV_with_GP(sv));
 506     if (GvGP(sv)) {
 507         if ((
 508 #ifdef PERL_DONT_CREATE_GVSV
 509              GvSV(sv) &&
 510 #endif
 511              SvOBJECT(GvSV(sv))) ||
 512              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
 513              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
 514              /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
 515              (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
 516              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
 517         {
 518             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
 519             SvFLAGS(sv) |= SVf_BREAK;
 520             SvREFCNT_dec(sv);
 521         }
 522     }
 523 }
 524 #endif
 525
 526 /*
 527 =for apidoc sv_clean_objs
 528
 529 Attempt to destroy all objects not yet freed
 530
 531 =cut
 532 */
 533
 534 void
 535 Perl_sv_clean_objs(pTHX)
 536 {
 537     dVAR;
 538     PL_in_clean_objs = TRUE;
 539     visit(do_clean_objs, SVf_ROK, SVf_ROK);
 540 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 541     /* some barnacles may yet remain, clinging to typeglobs */
 542     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
 543 #endif
 544     PL_in_clean_objs = FALSE;
 545 }
 546
 547 /* called by sv_clean_all() for each live SV */
 548
 549 static void
 550 do_clean_all(pTHX_ SV *const sv)
 551 {
 552     dVAR;
 553     if (sv == (SV*) PL_fdpid || sv == (SV *)PL_strtab) {
 554         /* don't clean pid table and strtab */
 555         return;
 556     }
 557     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
 558     SvFLAGS(sv) |= SVf_BREAK;
 559     SvREFCNT_dec(sv);
 560 }
 561
 562 /*
 563 =for apidoc sv_clean_all
 564
 565 Decrement the refcnt of each remaining SV, possibly triggering a
 566 cleanup. This function may have to be called multiple times to free
 567 SVs which are in complex self-referential hierarchies.
 568
 569 =cut
 570 */
 571
 572 I32
 573 Perl_sv_clean_all(pTHX)
 574 {
 575     dVAR;
 576     I32 cleaned;
 577     PL_in_clean_all = TRUE;
 578     cleaned = visit(do_clean_all, 0,0);
 579     PL_in_clean_all = FALSE;
 580     return cleaned;
 581 }
 582
 583 /*
 584   ARENASETS: a meta-arena implementation which separates arena-info
 585   into struct arena_set, which contains an array of struct
 586   arena_descs, each holding info for a single arena.  By separating
 587   the meta-info from the arena, we recover the 1st slot, formerly
 588   borrowed for list management.  The arena_set is about the size of an
 589   arena, avoiding the needless malloc overhead of a naive linked-list.
 590
 591   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
 592   memory in the last arena-set (1/2 on average).  In trade, we get
 593   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
 594   smaller types).  The recovery of the wasted space allows use of
 595   small arenas for large, rare body types, by changing array* fields
 596   in body_details_by_type[] below.
 597 */
 598 struct arena_desc {
 599     char       *arena;          /* the raw storage, allocated aligned */
 600     size_t      size;           /* its size ~4k typ */
 601     U32         misc;           /* type, and in future other things. */
 602 };
 603
 604 struct arena_set;
 605
 606 /* Get the maximum number of elements in set[] such that struct arena_set
 607    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
 608    therefore likely to be 1 aligned memory page.  */
 609
 610 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
 611                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
 612
 613 struct arena_set {
 614     struct arena_set* next;
 615     unsigned int   set_size;    /* ie ARENAS_PER_SET */
 616     unsigned int   curr;        /* index of next available arena-desc */
 617     struct arena_desc set[ARENAS_PER_SET];
 618 };
 619
 620 /*
 621 =for apidoc sv_free_arenas
 622
 623 Deallocate the memory used by all arenas. Note that all the individual SV
 624 heads and bodies within the arenas must already have been freed.
 625
 626 =cut
 627 */
 628 void
 629 Perl_sv_free_arenas(pTHX)
 630 {
 631     dVAR;
 632     SV* sva;
 633     SV* svanext;
 634     unsigned int i;
 635
 636     /* Free arenas here, but be careful about fake ones.  (We assume
 637        contiguity of the fake ones with the corresponding real ones.) */
 638
 639     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 640         svanext = (SV*) SvANY(sva);
 641         while (svanext && SvFAKE(svanext))
 642             svanext = (SV*) SvANY(svanext);
 643
 644         if (!SvFAKE(sva))
 645             Safefree(sva);
 646     }
 647
 648     {
 649         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 650
 651         while (aroot) {
 652             struct arena_set *current = aroot;
 653             i = aroot->curr;
 654             while (i--) {
 655                 assert(aroot->set[i].arena);
 656                 Safefree(aroot->set[i].arena);
 657             }
 658             aroot = aroot->next;
 659             Safefree(current);
 660         }
 661     }
 662     PL_body_arenas = 0;
 663
 664     i = PERL_ARENA_ROOTS_SIZE;
 665     while (i--)
 666         PL_body_roots[i] = 0;
 667
 668     Safefree(PL_nice_chunk);
 669     PL_nice_chunk = NULL;
 670     PL_nice_chunk_size = 0;
 671     PL_sv_arenaroot = 0;
 672     PL_sv_root = 0;
 673 }
 674
 675 /*
 676   Here are mid-level routines that manage the allocation of bodies out
 677   of the various arenas.  There are 5 kinds of arenas:
 678
 679   1. SV-head arenas, which are discussed and handled above
 680   2. regular body arenas
 681   3. arenas for reduced-size bodies
 682   4. Hash-Entry arenas
 683   5. pte arenas (thread related)
 684
 685   Arena types 2 & 3 are chained by body-type off an array of
 686   arena-root pointers, which is indexed by svtype.  Some of the
 687   larger/less used body types are malloced singly, since a large
 688   unused block of them is wasteful.  Also, several svtypes dont have
 689   bodies; the data fits into the sv-head itself.  The arena-root
 690   pointer thus has a few unused root-pointers (which may be hijacked
 691   later for arena types 4,5)
 692
 693   3 differs from 2 as an optimization; some body types have several
 694   unused fields in the front of the structure (which are kept in-place
 695   for consistency).  These bodies can be allocated in smaller chunks,
 696   because the leading fields arent accessed.  Pointers to such bodies
 697   are decremented to point at the unused 'ghost' memory, knowing that
 698   the pointers are used with offsets to the real memory.
 699
 700   HE, HEK arenas are managed separately, with separate code, but may
 701   be merge-able later..
 702
 703   PTE arenas are not sv-bodies, but they share these mid-level
 704   mechanics, so are considered here.  The new mid-level mechanics rely
 705   on the sv_type of the body being allocated, so we just reserve one
 706   of the unused body-slots for PTEs, then use it in those (2) PTE
 707   contexts below (line ~10k)
 708 */
 709
 710 /* get_arena(size): this creates custom-sized arenas
 711    TBD: export properly for hv.c: S_more_he().
 712 */
 713 void*
 714 Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
 715 {
 716     dVAR;
 717     struct arena_desc* adesc;
 718     struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 719     unsigned int curr;
 720
 721     /* shouldnt need this
 722     if (!arena_size)    arena_size = PERL_ARENA_SIZE;
 723     */
 724
 725     /* may need new arena-set to hold new arena */
 726     if (!aroot || aroot->curr >= aroot->set_size) {
 727         struct arena_set *newroot;
 728         Newxz(newroot, 1, struct arena_set);
 729         newroot->set_size = ARENAS_PER_SET;
 730         newroot->next = aroot;
 731         aroot = newroot;
 732         PL_body_arenas = (void *) newroot;
 733         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
 734     }
 735
 736     /* ok, now have arena-set with at least 1 empty/available arena-desc */
 737     curr = aroot->curr++;
 738     adesc = &(aroot->set[curr]);
 739     assert(!adesc->arena);
 740
 741     Newx(adesc->arena, arena_size, char);
 742     adesc->size = arena_size;
 743     adesc->misc = misc;
 744     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
 745                           curr, (void*)adesc->arena, (UV)arena_size));
 746
 747     return adesc->arena;
 748 }
 749
 750
 751 /* return a thing to the free list */
 752
 753 #define del_body(thing, root)                   \
 754     STMT_START {                                \
 755         void ** const thing_copy = (void **)thing;\
 756         *thing_copy = *root;                    \
 757         *root = (void*)thing_copy;              \
 758     } STMT_END
 759
 760 /*
 761
 762 =head1 SV-Body Allocation
 763
 764 Allocation of SV-bodies is similar to SV-heads, differing as follows;
 765 the allocation mechanism is used for many body types, so is somewhat
 766 more complicated, it uses arena-sets, and has no need for still-live
 767 SV detection.
 768
 769 At the outermost level, (new|del)_X*V macros return bodies of the
 770 appropriate type.  These macros call either (new|del)_body_type or
 771 (new|del)_body_allocated macro pairs, depending on specifics of the
 772 type.  Most body types use the former pair, the latter pair is used to
 773 allocate body types with "ghost fields".
 774
 775 "ghost fields" are fields that are unused in certain types, and
 776 consequently dont need to actually exist.  They are declared because
 777 they're part of a "base type", which allows use of functions as
 778 methods.  The simplest examples are AVs and HVs, 2 aggregate types
 779 which don't use the fields which support SCALAR semantics.
 780
 781 For these types, the arenas are carved up into *_allocated size
 782 chunks, we thus avoid wasted memory for those unaccessed members.
 783 When bodies are allocated, we adjust the pointer back in memory by the
 784 size of the bit not allocated, so it's as if we allocated the full
 785 structure.  (But things will all go boom if you write to the part that
 786 is "not there", because you'll be overwriting the last members of the
 787 preceding structure in memory.)
 788
 789 We calculate the correction using the STRUCT_OFFSET macro. For
 790 example, if xpv_allocated is the same structure as XPV then the two
 791 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
 792 structure is smaller (no initial NV actually allocated) then the net
 793 effect is to subtract the size of the NV from the pointer, to return a
 794 new pointer as if an initial NV were actually allocated.
 795
 796 This is the same trick as was used for NV and IV bodies. Ironically it
 797 doesn't need to be used for NV bodies any more, because NV is now at
 798 the start of the structure. IV bodies don't need it either, because
 799 they are no longer allocated.
 800
 801 In turn, the new_body_* allocators call S_new_body(), which invokes
 802 new_body_inline macro, which takes a lock, and takes a body off the
 803 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
 804 necessary to refresh an empty list.  Then the lock is released, and
 805 the body is returned.
 806
 807 S_more_bodies calls get_arena(), and carves it up into an array of N
 808 bodies, which it strings into a linked list.  It looks up arena-size
 809 and body-size from the body_details table described below, thus
 810 supporting the multiple body-types.
 811
 812 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
 813 the (new|del)_X*V macros are mapped directly to malloc/free.
 814
 815 */
 816
 817 /*
 818
 819 For each sv-type, struct body_details bodies_by_type[] carries
 820 parameters which control these aspects of SV handling:
 821
 822 Arena_size determines whether arenas are used for this body type, and if
 823 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
 824 zero, forcing individual mallocs and frees.
 825
 826 Body_size determines how big a body is, and therefore how many fit into
 827 each arena.  Offset carries the body-pointer adjustment needed for
 828 *_allocated body types, and is used in *_allocated macros.
 829
 830 But its main purpose is to parameterize info needed in
 831 Perl_sv_upgrade().  The info here dramatically simplifies the function
 832 vs the implementation in 5.8.7, making it table-driven.  All fields
 833 are used for this, except for arena_size.
 834
 835 For the sv-types that have no bodies, arenas are not used, so those
 836 PL_body_roots[sv_type] are unused, and can be overloaded.  In
 837 something of a special case, SVt_NULL is borrowed for HE arenas;
 838 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
 839 bodies_by_type[SVt_NULL] slot is not used, as the table is not
 840 available in hv.c.
 841
 842 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
 843 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
 844 just use the same allocation semantics.  At first, PTEs were also
 845 overloaded to a non-body sv-type, but this yielded hard-to-find malloc
 846 bugs, so was simplified by claiming a new slot.  This choice has no
 847 consequence at this time.
 848
 849 */
 850
 851 struct body_details {
 852     U8 body_size;       /* Size to allocate  */
 853     U8 copy;            /* Size of structure to copy (may be shorter)  */
 854     U8 offset;
 855     unsigned int type : 4;          /* We have space for a sanity check.  */
 856     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
 857     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
 858     unsigned int arena : 1;         /* Allocated from an arena */
 859     size_t arena_size;              /* Size of arena to allocate */
 860 };
 861
 862 #define HADNV FALSE
 863 #define NONV TRUE
 864
 865
 866 #ifdef PURIFY
 867 /* With -DPURFIY we allocate everything directly, and don't use arenas.
 868    This seems a rather elegant way to simplify some of the code below.  */
 869 #define HASARENA FALSE
 870 #else
 871 #define HASARENA TRUE
 872 #endif
 873 #define NOARENA FALSE
 874
 875 /* Size the arenas to exactly fit a given number of bodies.  A count
 876    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
 877    simplifying the default.  If count > 0, the arena is sized to fit
 878    only that many bodies, allowing arenas to be used for large, rare
 879    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
 880    limited by PERL_ARENA_SIZE, so we can safely oversize the
 881    declarations.
 882  */
 883 #define FIT_ARENA0(body_size)                           \
 884     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
 885 #define FIT_ARENAn(count,body_size)                     \
 886     ( count * body_size <= PERL_ARENA_SIZE)             \
 887     ? count * body_size                                 \
 888     : FIT_ARENA0 (body_size)
 889 #define FIT_ARENA(count,body_size)                      \
 890     count                                               \
 891     ? FIT_ARENAn (count, body_size)                     \
 892     : FIT_ARENA0 (body_size)
 893
 894 /* A macro to work out the offset needed to subtract from a pointer to (say)
 895
 896 typedef struct {
 897     STRLEN      xpv_cur;
 898     STRLEN      xpv_len;
 899 } xpv_allocated;
 900
 901 to make its members accessible via a pointer to (say)
 902
 903 struct xpv {
 904     NV          xnv_nv;
 905     STRLEN      xpv_cur;
 906     STRLEN      xpv_len;
 907 };
 908
 909 */
 910
 911 #define relative_STRUCT_OFFSET(longer, shorter, member) \
 912     (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
 913
 914 /* Calculate the length to copy. Specifically work out the length less any
 915    final padding the compiler needed to add.  See the comment in sv_upgrade
 916    for why copying the padding proved to be a bug.  */
 917
 918 #define copy_length(type, last_member) \
 919         STRUCT_OFFSET(type, last_member) \
 920         + sizeof (((type*)SvANY((SV*)0))->last_member)
 921
 922 static const struct body_details bodies_by_type[] = {
 923     { sizeof(HE), 0, 0, SVt_NULL,
 924       FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
 925
 926     /* The bind placeholder pretends to be an RV for now.
 927        Also it's marked as "can't upgrade" to stop anyone using it before it's
 928        implemented.  */
 929     { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
 930
 931     /* IVs are in the head, so the allocation size is 0.
 932        However, the slot is overloaded for PTEs.  */
 933     { sizeof(struct ptr_tbl_ent), /* This is used for PTEs.  */
 934       sizeof(IV), /* This is used to copy out the IV body.  */
 935       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
 936       NOARENA /* IVS don't need an arena  */,
 937       /* But PTEs need to know the size of their arena  */
 938       FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
 939     },
 940
 941     /* 8 bytes on most ILP32 with IEEE doubles */
 942     { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
 943       FIT_ARENA(0, sizeof(NV)) },
 944
 945     /* 8 bytes on most ILP32 with IEEE doubles */
 946     { sizeof(xpv_allocated),
 947       copy_length(XPV, xpv_len)
 948       - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
 949       + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
 950       SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
 951
 952     /* 12 */
 953     { sizeof(xpviv_allocated),
 954       copy_length(XPVIV, xiv_u)
 955       - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
 956       + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
 957       SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
 958
 959     /* 20 */
 960     { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
 961       HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
 962
 963     /* 28 */
 964     { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
 965       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 966
 967     /* something big */
 968     { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated),
 969       + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur),
 970       SVt_REGEXP, FALSE, NONV, HASARENA,
 971       FIT_ARENA(0, sizeof(struct regexp_allocated))
 972     },
 973
 974     /* 48 */
 975     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
 976       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
 977
 978     /* 64 */
 979     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
 980       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
 981
 982     { sizeof(xpvav_allocated),
 983       copy_length(XPVAV, xmg_stash)
 984       - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
 985       + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
 986       SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
 987
 988     { sizeof(xpvhv_allocated),
 989       copy_length(XPVHV, xmg_stash)
 990       - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
 991       + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
 992       SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
 993
 994     /* 56 */
 995     { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
 996       + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
 997       SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
 998
 999     { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
1000       + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
1001       SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
1002
1003     /* XPVIO is 84 bytes, fits 48x */
1004     { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
1005       + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
1006       SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
1007 };
1008
1009 #define new_body_type(sv_type)          \
1010     (void *)((char *)S_new_body(aTHX_ sv_type))
1011
1012 #define del_body_type(p, sv_type)       \
1013     del_body(p, &PL_body_roots[sv_type])
1014
1015
1016 #define new_body_allocated(sv_type)             \
1017     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1018              - bodies_by_type[sv_type].offset)
1019
1020 #define del_body_allocated(p, sv_type)          \
1021     del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1022
1023
1024 #define my_safemalloc(s)        (void*)safemalloc(s)
1025 #define my_safecalloc(s)        (void*)safecalloc(s, 1)
1026 #define my_safefree(p)  safefree((char*)p)
1027
1028 #ifdef PURIFY
1029
1030 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
1031 #define del_XNV(p)      my_safefree(p)
1032
1033 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
1034 #define del_XPVNV(p)    my_safefree(p)
1035
1036 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
1037 #define del_XPVAV(p)    my_safefree(p)
1038
1039 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
1040 #define del_XPVHV(p)    my_safefree(p)
1041
1042 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
1043 #define del_XPVMG(p)    my_safefree(p)
1044
1045 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
1046 #define del_XPVGV(p)    my_safefree(p)
1047
1048 #else /* !PURIFY */
1049
1050 #define new_XNV()       new_body_type(SVt_NV)
1051 #define del_XNV(p)      del_body_type(p, SVt_NV)
1052
1053 #define new_XPVNV()     new_body_type(SVt_PVNV)
1054 #define del_XPVNV(p)    del_body_type(p, SVt_PVNV)
1055
1056 #define new_XPVAV()     new_body_allocated(SVt_PVAV)
1057 #define del_XPVAV(p)    del_body_allocated(p, SVt_PVAV)
1058
1059 #define new_XPVHV()     new_body_allocated(SVt_PVHV)
1060 #define del_XPVHV(p)    del_body_allocated(p, SVt_PVHV)
1061
1062 #define new_XPVMG()     new_body_type(SVt_PVMG)
1063 #define del_XPVMG(p)    del_body_type(p, SVt_PVMG)
1064
1065 #define new_XPVGV()     new_body_type(SVt_PVGV)
1066 #define del_XPVGV(p)    del_body_type(p, SVt_PVGV)
1067
1068 #endif /* PURIFY */
1069
1070 /* no arena for you! */
1071
1072 #define new_NOARENA(details) \
1073         my_safemalloc((details)->body_size + (details)->offset)
1074 #define new_NOARENAZ(details) \
1075         my_safecalloc((details)->body_size + (details)->offset)
1076
1077 STATIC void *
1078 S_more_bodies (pTHX_ const svtype sv_type)
1079 {
1080     dVAR;
1081     void ** const root = &PL_body_roots[sv_type];
1082     const struct body_details * const bdp = &bodies_by_type[sv_type];
1083     const size_t body_size = bdp->body_size;
1084     char *start;
1085     const char *end;
1086     const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1087 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1088     static bool done_sanity_check;
1089
1090     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1091      * variables like done_sanity_check. */
1092     if (!done_sanity_check) {
1093         unsigned int i = SVt_LAST;
1094
1095         done_sanity_check = TRUE;
1096
1097         while (i--)
1098             assert (bodies_by_type[i].type == i);
1099     }
1100 #endif
1101
1102     assert(bdp->arena_size);
1103
1104     start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1105
1106     end = start + arena_size - 2 * body_size;
1107
1108     /* computed count doesnt reflect the 1st slot reservation */
1109 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1110     DEBUG_m(PerlIO_printf(Perl_debug_log,
1111                           "arena %p end %p arena-size %d (from %d) type %d "
1112                           "size %d ct %d\n",
1113                           (void*)start, (void*)end, (int)arena_size,
1114                           (int)bdp->arena_size, sv_type, (int)body_size,
1115                           (int)arena_size / (int)body_size));
1116 #else
1117     DEBUG_m(PerlIO_printf(Perl_debug_log,
1118                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1119                           (void*)start, (void*)end,
1120                           (int)bdp->arena_size, sv_type, (int)body_size,
1121                           (int)bdp->arena_size / (int)body_size));
1122 #endif
1123     *root = (void *)start;
1124
1125     while (start <= end) {
1126         char * const next = start + body_size;
1127         *(void**) start = (void *)next;
1128         start = next;
1129     }
1130     *(void **)start = 0;
1131
1132     return *root;
1133 }
1134
1135 /* grab a new thing from the free list, allocating more if necessary.
1136    The inline version is used for speed in hot routines, and the
1137    function using it serves the rest (unless PURIFY).
1138 */
1139 #define new_body_inline(xpv, sv_type) \
1140     STMT_START { \
1141         void ** const r3wt = &PL_body_roots[sv_type]; \
1142         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1143           ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1144         *(r3wt) = *(void**)(xpv); \
1145     } STMT_END
1146
1147 #ifndef PURIFY
1148
1149 STATIC void *
1150 S_new_body(pTHX_ const svtype sv_type)
1151 {
1152     dVAR;
1153     void *xpv;
1154     new_body_inline(xpv, sv_type);
1155     return xpv;
1156 }
1157
1158 #endif
1159
1160 static const struct body_details fake_rv =
1161     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1162
1163 /*
1164 =for apidoc sv_upgrade
1165
1166 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1167 SV, then copies across as much information as possible from the old body.
1168 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1169
1170 =cut
1171 */
1172
1173 void
1174 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1175 {
1176     dVAR;
1177     void*       old_body;
1178     void*       new_body;
1179     const svtype old_type = SvTYPE(sv);
1180     const struct body_details *new_type_details;
1181     const struct body_details *old_type_details
1182         = bodies_by_type + old_type;
1183     SV *referant = NULL;
1184
1185     PERL_ARGS_ASSERT_SV_UPGRADE;
1186
1187     if (new_type != SVt_PV && SvIsCOW(sv)) {
1188         sv_force_normal_flags(sv, 0);
1189     }
1190
1191     if (old_type == new_type)
1192         return;
1193
1194     old_body = SvANY(sv);
1195
1196     /* Copying structures onto other structures that have been neatly zeroed
1197        has a subtle gotcha. Consider XPVMG
1198
1199        +------+------+------+------+------+-------+-------+
1200        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1201        +------+------+------+------+------+-------+-------+
1202        0      4      8     12     16     20      24      28
1203
1204        where NVs are aligned to 8 bytes, so that sizeof that structure is
1205        actually 32 bytes long, with 4 bytes of padding at the end:
1206
1207        +------+------+------+------+------+-------+-------+------+
1208        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1209        +------+------+------+------+------+-------+-------+------+
1210        0      4      8     12     16     20      24      28     32
1211
1212        so what happens if you allocate memory for this structure:
1213
1214        +------+------+------+------+------+-------+-------+------+------+...
1215        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1216        +------+------+------+------+------+-------+-------+------+------+...
1217        0      4      8     12     16     20      24      28     32     36
1218
1219        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1220        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1221        started out as zero once, but it's quite possible that it isn't. So now,
1222        rather than a nicely zeroed GP, you have it pointing somewhere random.
1223        Bugs ensue.
1224
1225        (In fact, GP ends up pointing at a previous GP structure, because the
1226        principle cause of the padding in XPVMG getting garbage is a copy of
1227        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1228        this happens to be moot because XPVGV has been re-ordered, with GP
1229        no longer after STASH)
1230
1231        So we are careful and work out the size of used parts of all the
1232        structures.  */
1233
1234     switch (old_type) {
1235     case SVt_NULL:
1236         break;
1237     case SVt_IV:
1238         if (SvROK(sv)) {
1239             referant = SvRV(sv);
1240             old_type_details = &fake_rv;
1241             if (new_type == SVt_NV)
1242                 new_type = SVt_PVNV;
1243         } else {
1244             if (new_type < SVt_PVIV) {
1245                 new_type = (new_type == SVt_NV)
1246                     ? SVt_PVNV : SVt_PVIV;
1247             }
1248         }
1249         break;
1250     case SVt_NV:
1251         if (new_type < SVt_PVNV) {
1252             new_type = SVt_PVNV;
1253         }
1254         break;
1255     case SVt_PV:
1256         assert(new_type > SVt_PV);
1257         assert(SVt_IV < SVt_PV);
1258         assert(SVt_NV < SVt_PV);
1259         break;
1260     case SVt_PVIV:
1261         break;
1262     case SVt_PVNV:
1263         break;
1264     case SVt_PVMG:
1265         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1266            there's no way that it can be safely upgraded, because perl.c
1267            expects to Safefree(SvANY(PL_mess_sv))  */
1268         assert(sv != PL_mess_sv);
1269         /* This flag bit is used to mean other things in other scalar types.
1270            Given that it only has meaning inside the pad, it shouldn't be set
1271            on anything that can get upgraded.  */
1272         assert(!SvPAD_TYPED(sv));
1273         break;
1274     default:
1275         if (old_type_details->cant_upgrade)
1276             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1277                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1278     }
1279
1280     if (old_type > new_type)
1281         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1282                 (int)old_type, (int)new_type);
1283
1284     new_type_details = bodies_by_type + new_type;
1285
1286     SvFLAGS(sv) &= ~SVTYPEMASK;
1287     SvFLAGS(sv) |= new_type;
1288
1289     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1290        the return statements above will have triggered.  */
1291     assert (new_type != SVt_NULL);
1292     switch (new_type) {
1293     case SVt_IV:
1294         assert(old_type == SVt_NULL);
1295         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1296         SvIV_set(sv, 0);
1297         return;
1298     case SVt_NV:
1299         assert(old_type == SVt_NULL);
1300         SvANY(sv) = new_XNV();
1301         SvNV_set(sv, 0);
1302         return;
1303     case SVt_PVHV:
1304     case SVt_PVAV:
1305         assert(new_type_details->body_size);
1306
1307 #ifndef PURIFY
1308         assert(new_type_details->arena);
1309         assert(new_type_details->arena_size);
1310         /* This points to the start of the allocated area.  */
1311         new_body_inline(new_body, new_type);
1312         Zero(new_body, new_type_details->body_size, char);
1313         new_body = ((char *)new_body) - new_type_details->offset;
1314 #else
1315         /* We always allocated the full length item with PURIFY. To do this
1316            we fake things so that arena is false for all 16 types..  */
1317         new_body = new_NOARENAZ(new_type_details);
1318 #endif
1319         SvANY(sv) = new_body;
1320         if (new_type == SVt_PVAV) {
1321             AvMAX(sv)   = -1;
1322             AvFILLp(sv) = -1;
1323             AvREAL_only(sv);
1324             if (old_type_details->body_size) {
1325                 AvALLOC(sv) = 0;
1326             } else {
1327                 /* It will have been zeroed when the new body was allocated.
1328                    Lets not write to it, in case it confuses a write-back
1329                    cache.  */
1330             }
1331         } else {
1332             assert(!SvOK(sv));
1333             SvOK_off(sv);
1334 #ifndef NODEFAULT_SHAREKEYS
1335             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1336 #endif
1337             HvMAX(sv) = 7; /* (start with 8 buckets) */
1338             if (old_type_details->body_size) {
1339                 HvFILL(sv) = 0;
1340             } else {
1341                 /* It will have been zeroed when the new body was allocated.
1342                    Lets not write to it, in case it confuses a write-back
1343                    cache.  */
1344             }
1345         }
1346
1347         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1348            The target created by newSVrv also is, and it can have magic.
1349            However, it never has SvPVX set.
1350         */
1351         if (old_type == SVt_IV) {
1352             assert(!SvROK(sv));
1353         } else if (old_type >= SVt_PV) {
1354             assert(SvPVX_const(sv) == 0);
1355         }
1356
1357         if (old_type >= SVt_PVMG) {
1358             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1359             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1360         } else {
1361             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1362         }
1363         break;
1364
1365
1366     case SVt_PVIV:
1367         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1368            no route from NV to PVIV, NOK can never be true  */
1369         assert(!SvNOKp(sv));
1370         assert(!SvNOK(sv));
1371     case SVt_PVIO:
1372     case SVt_PVFM:
1373     case SVt_PVGV:
1374     case SVt_PVCV:
1375     case SVt_PVLV:
1376     case SVt_REGEXP:
1377     case SVt_PVMG:
1378     case SVt_PVNV:
1379     case SVt_PV:
1380
1381         assert(new_type_details->body_size);
1382         /* We always allocated the full length item with PURIFY. To do this
1383            we fake things so that arena is false for all 16 types..  */
1384         if(new_type_details->arena) {
1385             /* This points to the start of the allocated area.  */
1386             new_body_inline(new_body, new_type);
1387             Zero(new_body, new_type_details->body_size, char);
1388             new_body = ((char *)new_body) - new_type_details->offset;
1389         } else {
1390             new_body = new_NOARENAZ(new_type_details);
1391         }
1392         SvANY(sv) = new_body;
1393
1394         if (old_type_details->copy) {
1395             /* There is now the potential for an upgrade from something without
1396                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1397             int offset = old_type_details->offset;
1398             int length = old_type_details->copy;
1399
1400             if (new_type_details->offset > old_type_details->offset) {
1401                 const int difference
1402                     = new_type_details->offset - old_type_details->offset;
1403                 offset += difference;
1404                 length -= difference;
1405             }
1406             assert (length >= 0);
1407
1408             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1409                  char);
1410         }
1411
1412 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1413         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1414          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1415          * NV slot, but the new one does, then we need to initialise the
1416          * freshly created NV slot with whatever the correct bit pattern is
1417          * for 0.0  */
1418         if (old_type_details->zero_nv && !new_type_details->zero_nv
1419             && !isGV_with_GP(sv))
1420             SvNV_set(sv, 0);
1421 #endif
1422
1423         if (new_type == SVt_PVIO)
1424             IoPAGE_LEN(sv) = 60;
1425         if (old_type < SVt_PV) {
1426             /* referant will be NULL unless the old type was SVt_IV emulating
1427                SVt_RV */
1428             sv->sv_u.svu_rv = referant;
1429         }
1430         break;
1431     default:
1432         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1433                    (unsigned long)new_type);
1434     }
1435
1436     if (old_type_details->arena) {
1437         /* If there was an old body, then we need to free it.
1438            Note that there is an assumption that all bodies of types that
1439            can be upgraded came from arenas. Only the more complex non-
1440            upgradable types are allowed to be directly malloc()ed.  */
1441 #ifdef PURIFY
1442         my_safefree(old_body);
1443 #else
1444         del_body((void*)((char*)old_body + old_type_details->offset),
1445                  &PL_body_roots[old_type]);
1446 #endif
1447     }
1448 }
1449
1450 /*
1451 =for apidoc sv_backoff
1452
1453 Remove any string offset. You should normally use the C<SvOOK_off> macro
1454 wrapper instead.
1455
1456 =cut
1457 */
1458
1459 int
1460 Perl_sv_backoff(pTHX_ register SV *const sv)
1461 {
1462     STRLEN delta;
1463     const char * const s = SvPVX_const(sv);
1464
1465     PERL_ARGS_ASSERT_SV_BACKOFF;
1466     PERL_UNUSED_CONTEXT;
1467
1468     assert(SvOOK(sv));
1469     assert(SvTYPE(sv) != SVt_PVHV);
1470     assert(SvTYPE(sv) != SVt_PVAV);
1471
1472     SvOOK_offset(sv, delta);
1473
1474     SvLEN_set(sv, SvLEN(sv) + delta);
1475     SvPV_set(sv, SvPVX(sv) - delta);
1476     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1477     SvFLAGS(sv) &= ~SVf_OOK;
1478     return 0;
1479 }
1480
1481 /*
1482 =for apidoc sv_grow
1483
1484 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1485 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1486 Use the C<SvGROW> wrapper instead.
1487
1488 =cut
1489 */
1490
1491 char *
1492 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1493 {
1494     register char *s;
1495
1496     PERL_ARGS_ASSERT_SV_GROW;
1497
1498     if (PL_madskills && newlen >= 0x100000) {
1499         PerlIO_printf(Perl_debug_log,
1500                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1501     }
1502 #ifdef HAS_64K_LIMIT
1503     if (newlen >= 0x10000) {
1504         PerlIO_printf(Perl_debug_log,
1505                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1506         my_exit(1);
1507     }
1508 #endif /* HAS_64K_LIMIT */
1509     if (SvROK(sv))
1510         sv_unref(sv);
1511     if (SvTYPE(sv) < SVt_PV) {
1512         sv_upgrade(sv, SVt_PV);
1513         s = SvPVX_mutable(sv);
1514     }
1515     else if (SvOOK(sv)) {       /* pv is offset? */
1516         sv_backoff(sv);
1517         s = SvPVX_mutable(sv);
1518         if (newlen > SvLEN(sv))
1519             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1520 #ifdef HAS_64K_LIMIT
1521         if (newlen >= 0x10000)
1522             newlen = 0xFFFF;
1523 #endif
1524     }
1525     else
1526         s = SvPVX_mutable(sv);
1527
1528     if (newlen > SvLEN(sv)) {           /* need more room? */
1529 #ifndef Perl_safesysmalloc_size
1530         newlen = PERL_STRLEN_ROUNDUP(newlen);
1531 #endif
1532         if (SvLEN(sv) && s) {
1533             s = (char*)saferealloc(s, newlen);
1534         }
1535         else {
1536             s = (char*)safemalloc(newlen);
1537             if (SvPVX_const(sv) && SvCUR(sv)) {
1538                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1539             }
1540         }
1541         SvPV_set(sv, s);
1542 #ifdef Perl_safesysmalloc_size
1543         /* Do this here, do it once, do it right, and then we will never get
1544            called back into sv_grow() unless there really is some growing
1545            needed.  */
1546         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1547 #else
1548         SvLEN_set(sv, newlen);
1549 #endif
1550     }
1551     return s;
1552 }
1553
1554 /*
1555 =for apidoc sv_setiv
1556
1557 Copies an integer into the given SV, upgrading first if necessary.
1558 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1559
1560 =cut
1561 */
1562
1563 void
1564 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1565 {
1566     dVAR;
1567
1568     PERL_ARGS_ASSERT_SV_SETIV;
1569
1570     SV_CHECK_THINKFIRST_COW_DROP(sv);
1571     switch (SvTYPE(sv)) {
1572     case SVt_NULL:
1573     case SVt_NV:
1574         sv_upgrade(sv, SVt_IV);
1575         break;
1576     case SVt_PV:
1577         sv_upgrade(sv, SVt_PVIV);
1578         break;
1579
1580     case SVt_PVGV:
1581         if (!isGV_with_GP(sv))
1582             break;
1583     case SVt_PVAV:
1584     case SVt_PVHV:
1585     case SVt_PVCV:
1586     case SVt_PVFM:
1587     case SVt_PVIO:
1588         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1589                    OP_DESC(PL_op));
1590     default: NOOP;
1591     }
1592     (void)SvIOK_only(sv);                       /* validate number */
1593     SvIV_set(sv, i);
1594     SvTAINT(sv);
1595 }
1596
1597 /*
1598 =for apidoc sv_setiv_mg
1599
1600 Like C<sv_setiv>, but also handles 'set' magic.
1601
1602 =cut
1603 */
1604
1605 void
1606 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1607 {
1608     PERL_ARGS_ASSERT_SV_SETIV_MG;
1609
1610     sv_setiv(sv,i);
1611     SvSETMAGIC(sv);
1612 }
1613
1614 /*
1615 =for apidoc sv_setuv
1616
1617 Copies an unsigned integer into the given SV, upgrading first if necessary.
1618 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1619
1620 =cut
1621 */
1622
1623 void
1624 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1625 {
1626     PERL_ARGS_ASSERT_SV_SETUV;
1627
1628     /* With these two if statements:
1629        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1630
1631        without
1632        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1633
1634        If you wish to remove them, please benchmark to see what the effect is
1635     */
1636     if (u <= (UV)IV_MAX) {
1637        sv_setiv(sv, (IV)u);
1638        return;
1639     }
1640     sv_setiv(sv, 0);
1641     SvIsUV_on(sv);
1642     SvUV_set(sv, u);
1643 }
1644
1645 /*
1646 =for apidoc sv_setuv_mg
1647
1648 Like C<sv_setuv>, but also handles 'set' magic.
1649
1650 =cut
1651 */
1652
1653 void
1654 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1655 {
1656     PERL_ARGS_ASSERT_SV_SETUV_MG;
1657
1658     sv_setuv(sv,u);
1659     SvSETMAGIC(sv);
1660 }
1661
1662 /*
1663 =for apidoc sv_setnv
1664
1665 Copies a double into the given SV, upgrading first if necessary.
1666 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1667
1668 =cut
1669 */
1670
1671 void
1672 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1673 {
1674     dVAR;
1675
1676     PERL_ARGS_ASSERT_SV_SETNV;
1677
1678     SV_CHECK_THINKFIRST_COW_DROP(sv);
1679     switch (SvTYPE(sv)) {
1680     case SVt_NULL:
1681     case SVt_IV:
1682         sv_upgrade(sv, SVt_NV);
1683         break;
1684     case SVt_PV:
1685     case SVt_PVIV:
1686         sv_upgrade(sv, SVt_PVNV);
1687         break;
1688
1689     case SVt_PVGV:
1690         if (!isGV_with_GP(sv))
1691             break;
1692     case SVt_PVAV:
1693     case SVt_PVHV:
1694     case SVt_PVCV:
1695     case SVt_PVFM:
1696     case SVt_PVIO:
1697         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1698                    OP_NAME(PL_op));
1699     default: NOOP;
1700     }
1701     SvNV_set(sv, num);
1702     (void)SvNOK_only(sv);                       /* validate number */
1703     SvTAINT(sv);
1704 }
1705
1706 /*
1707 =for apidoc sv_setnv_mg
1708
1709 Like C<sv_setnv>, but also handles 'set' magic.
1710
1711 =cut
1712 */
1713
1714 void
1715 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1716 {
1717     PERL_ARGS_ASSERT_SV_SETNV_MG;
1718
1719     sv_setnv(sv,num);
1720     SvSETMAGIC(sv);
1721 }
1722
1723 /* Print an "isn't numeric" warning, using a cleaned-up,
1724  * printable version of the offending string
1725  */
1726
1727 STATIC void
1728 S_not_a_number(pTHX_ SV *const sv)
1729 {
1730      dVAR;
1731      SV *dsv;
1732      char tmpbuf[64];
1733      const char *pv;
1734
1735      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1736
1737      if (DO_UTF8(sv)) {
1738           dsv = newSVpvs_flags("", SVs_TEMP);
1739           pv = sv_uni_display(dsv, sv, 10, 0);
1740      } else {
1741           char *d = tmpbuf;
1742           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1743           /* each *s can expand to 4 chars + "...\0",
1744              i.e. need room for 8 chars */
1745
1746           const char *s = SvPVX_const(sv);
1747           const char * const end = s + SvCUR(sv);
1748           for ( ; s < end && d < limit; s++ ) {
1749                int ch = *s & 0xFF;
1750                if (ch & 128 && !isPRINT_LC(ch)) {
1751                     *d++ = 'M';
1752                     *d++ = '-';
1753                     ch &= 127;
1754                }
1755                if (ch == '\n') {
1756                     *d++ = '\\';
1757                     *d++ = 'n';
1758                }
1759                else if (ch == '\r') {
1760                     *d++ = '\\';
1761                     *d++ = 'r';
1762                }
1763                else if (ch == '\f') {
1764                     *d++ = '\\';
1765                     *d++ = 'f';
1766                }
1767                else if (ch == '\\') {
1768                     *d++ = '\\';
1769                     *d++ = '\\';
1770                }
1771                else if (ch == '\0') {
1772                     *d++ = '\\';
1773                     *d++ = '0';
1774                }
1775                else if (isPRINT_LC(ch))
1776                     *d++ = ch;
1777                else {
1778                     *d++ = '^';
1779                     *d++ = toCTRL(ch);
1780                }
1781           }
1782           if (s < end) {
1783                *d++ = '.';
1784                *d++ = '.';
1785                *d++ = '.';
1786           }
1787           *d = '\0';
1788           pv = tmpbuf;
1789     }
1790
1791     if (PL_op)
1792         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1793                     "Argument \"%s\" isn't numeric in %s", pv,
1794                     OP_DESC(PL_op));
1795     else
1796         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1797                     "Argument \"%s\" isn't numeric", pv);
1798 }
1799
1800 /*
1801 =for apidoc looks_like_number
1802
1803 Test if the content of an SV looks like a number (or is a number).
1804 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1805 non-numeric warning), even if your atof() doesn't grok them.
1806
1807 =cut
1808 */
1809
1810 I32
1811 Perl_looks_like_number(pTHX_ SV *const sv)
1812 {
1813     register const char *sbegin;
1814     STRLEN len;
1815
1816     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1817
1818     if (SvPOK(sv)) {
1819         sbegin = SvPVX_const(sv);
1820         len = SvCUR(sv);
1821     }
1822     else if (SvPOKp(sv))
1823         sbegin = SvPV_const(sv, len);
1824     else
1825         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1826     return grok_number(sbegin, len, NULL);
1827 }
1828
1829 STATIC bool
1830 S_glob_2number(pTHX_ GV * const gv)
1831 {
1832     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1833     SV *const buffer = sv_newmortal();
1834
1835     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1836
1837     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1838        is on.  */
1839     SvFAKE_off(gv);
1840     gv_efullname3(buffer, gv, "*");
1841     SvFLAGS(gv) |= wasfake;
1842
1843     /* We know that all GVs stringify to something that is not-a-number,
1844         so no need to test that.  */
1845     if (ckWARN(WARN_NUMERIC))
1846         not_a_number(buffer);
1847     /* We just want something true to return, so that S_sv_2iuv_common
1848         can tail call us and return true.  */
1849     return TRUE;
1850 }
1851
1852 STATIC char *
1853 S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len)
1854 {
1855     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1856     SV *const buffer = sv_newmortal();
1857
1858     PERL_ARGS_ASSERT_GLOB_2PV;
1859
1860     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1861        is on.  */
1862     SvFAKE_off(gv);
1863     gv_efullname3(buffer, gv, "*");
1864     SvFLAGS(gv) |= wasfake;
1865
1866     assert(SvPOK(buffer));
1867     if (len) {
1868         *len = SvCUR(buffer);
1869     }
1870     return SvPVX(buffer);
1871 }
1872
1873 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1874    until proven guilty, assume that things are not that bad... */
1875
1876 /*
1877    NV_PRESERVES_UV:
1878
1879    As 64 bit platforms often have an NV that doesn't preserve all bits of
1880    an IV (an assumption perl has been based on to date) it becomes necessary
1881    to remove the assumption that the NV always carries enough precision to
1882    recreate the IV whenever needed, and that the NV is the canonical form.
1883    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1884    precision as a side effect of conversion (which would lead to insanity
1885    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1886    1) to distinguish between IV/UV/NV slots that have cached a valid
1887       conversion where precision was lost and IV/UV/NV slots that have a
1888       valid conversion which has lost no precision
1889    2) to ensure that if a numeric conversion to one form is requested that
1890       would lose precision, the precise conversion (or differently
1891       imprecise conversion) is also performed and cached, to prevent
1892       requests for different numeric formats on the same SV causing
1893       lossy conversion chains. (lossless conversion chains are perfectly
1894       acceptable (still))
1895
1896
1897    flags are used:
1898    SvIOKp is true if the IV slot contains a valid value
1899    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1900    SvNOKp is true if the NV slot contains a valid value
1901    SvNOK  is true only if the NV value is accurate
1902
1903    so
1904    while converting from PV to NV, check to see if converting that NV to an
1905    IV(or UV) would lose accuracy over a direct conversion from PV to
1906    IV(or UV). If it would, cache both conversions, return NV, but mark
1907    SV as IOK NOKp (ie not NOK).
1908
1909    While converting from PV to IV, check to see if converting that IV to an
1910    NV would lose accuracy over a direct conversion from PV to NV. If it
1911    would, cache both conversions, flag similarly.
1912
1913    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1914    correctly because if IV & NV were set NV *always* overruled.
1915    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1916    changes - now IV and NV together means that the two are interchangeable:
1917    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1918
1919    The benefit of this is that operations such as pp_add know that if
1920    SvIOK is true for both left and right operands, then integer addition
1921    can be used instead of floating point (for cases where the result won't
1922    overflow). Before, floating point was always used, which could lead to
1923    loss of precision compared with integer addition.
1924
1925    * making IV and NV equal status should make maths accurate on 64 bit
1926      platforms
1927    * may speed up maths somewhat if pp_add and friends start to use
1928      integers when possible instead of fp. (Hopefully the overhead in
1929      looking for SvIOK and checking for overflow will not outweigh the
1930      fp to integer speedup)
1931    * will slow down integer operations (callers of SvIV) on "inaccurate"
1932      values, as the change from SvIOK to SvIOKp will cause a call into
1933      sv_2iv each time rather than a macro access direct to the IV slot
1934    * should speed up number->string conversion on integers as IV is
1935      favoured when IV and NV are equally accurate
1936
1937    ####################################################################
1938    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1939    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1940    On the other hand, SvUOK is true iff UV.
1941    ####################################################################
1942
1943    Your mileage will vary depending your CPU's relative fp to integer
1944    performance ratio.
1945 */
1946
1947 #ifndef NV_PRESERVES_UV
1948 #  define IS_NUMBER_UNDERFLOW_IV 1
1949 #  define IS_NUMBER_UNDERFLOW_UV 2
1950 #  define IS_NUMBER_IV_AND_UV    2
1951 #  define IS_NUMBER_OVERFLOW_IV  4
1952 #  define IS_NUMBER_OVERFLOW_UV  5
1953
1954 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1955
1956 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1957 STATIC int
1958 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1959 #  ifdef DEBUGGING
1960                        , I32 numtype
1961 #  endif
1962                        )
1963 {
1964     dVAR;
1965
1966     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1967
1968     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));
1969     if (SvNVX(sv) < (NV)IV_MIN) {
1970         (void)SvIOKp_on(sv);
1971         (void)SvNOK_on(sv);
1972         SvIV_set(sv, IV_MIN);
1973         return IS_NUMBER_UNDERFLOW_IV;
1974     }
1975     if (SvNVX(sv) > (NV)UV_MAX) {
1976         (void)SvIOKp_on(sv);
1977         (void)SvNOK_on(sv);
1978         SvIsUV_on(sv);
1979         SvUV_set(sv, UV_MAX);
1980         return IS_NUMBER_OVERFLOW_UV;
1981     }
1982     (void)SvIOKp_on(sv);
1983     (void)SvNOK_on(sv);
1984     /* Can't use strtol etc to convert this string.  (See truth table in
1985        sv_2iv  */
1986     if (SvNVX(sv) <= (UV)IV_MAX) {
1987         SvIV_set(sv, I_V(SvNVX(sv)));
1988         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1989             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1990         } else {
1991             /* Integer is imprecise. NOK, IOKp */
1992         }
1993         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1994     }
1995     SvIsUV_on(sv);
1996     SvUV_set(sv, U_V(SvNVX(sv)));
1997     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1998         if (SvUVX(sv) == UV_MAX) {
1999             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2000                possibly be preserved by NV. Hence, it must be overflow.
2001                NOK, IOKp */
2002             return IS_NUMBER_OVERFLOW_UV;
2003         }
2004         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2005     } else {
2006         /* Integer is imprecise. NOK, IOKp */
2007     }
2008     return IS_NUMBER_OVERFLOW_IV;
2009 }
2010 #endif /* !NV_PRESERVES_UV*/
2011
2012 STATIC bool
2013 S_sv_2iuv_common(pTHX_ SV *const sv)
2014 {
2015     dVAR;
2016
2017     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2018
2019     if (SvNOKp(sv)) {
2020         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2021          * without also getting a cached IV/UV from it at the same time
2022          * (ie PV->NV conversion should detect loss of accuracy and cache
2023          * IV or UV at same time to avoid this. */
2024         /* IV-over-UV optimisation - choose to cache IV if possible */
2025
2026         if (SvTYPE(sv) == SVt_NV)
2027             sv_upgrade(sv, SVt_PVNV);
2028
2029         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2030         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2031            certainly cast into the IV range at IV_MAX, whereas the correct
2032            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2033            cases go to UV */
2034 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2035         if (Perl_isnan(SvNVX(sv))) {
2036             SvUV_set(sv, 0);
2037             SvIsUV_on(sv);
2038             return FALSE;
2039         }
2040 #endif
2041         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2042             SvIV_set(sv, I_V(SvNVX(sv)));
2043             if (SvNVX(sv) == (NV) SvIVX(sv)
2044 #ifndef NV_PRESERVES_UV
2045                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2046                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2047                 /* Don't flag it as "accurately an integer" if the number
2048                    came from a (by definition imprecise) NV operation, and
2049                    we're outside the range of NV integer precision */
2050 #endif
2051                 ) {
2052                 if (SvNOK(sv))
2053                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2054                 else {
2055                     /* scalar has trailing garbage, eg "42a" */
2056                 }
2057                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2058                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2059                                       PTR2UV(sv),
2060                                       SvNVX(sv),
2061                                       SvIVX(sv)));
2062
2063             } else {
2064                 /* IV not precise.  No need to convert from PV, as NV
2065                    conversion would already have cached IV if it detected
2066                    that PV->IV would be better than PV->NV->IV
2067                    flags already correct - don't set public IOK.  */
2068                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2069                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2070                                       PTR2UV(sv),
2071                                       SvNVX(sv),
2072                                       SvIVX(sv)));
2073             }
2074             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2075                but the cast (NV)IV_MIN rounds to a the value less (more
2076                negative) than IV_MIN which happens to be equal to SvNVX ??
2077                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2078                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2079                (NV)UVX == NVX are both true, but the values differ. :-(
2080                Hopefully for 2s complement IV_MIN is something like
2081                0x8000000000000000 which will be exact. NWC */
2082         }
2083         else {
2084             SvUV_set(sv, U_V(SvNVX(sv)));
2085             if (
2086                 (SvNVX(sv) == (NV) SvUVX(sv))
2087 #ifndef  NV_PRESERVES_UV
2088                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2089                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2090                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2091                 /* Don't flag it as "accurately an integer" if the number
2092                    came from a (by definition imprecise) NV operation, and
2093                    we're outside the range of NV integer precision */
2094 #endif
2095                 && SvNOK(sv)
2096                 )
2097                 SvIOK_on(sv);
2098             SvIsUV_on(sv);
2099             DEBUG_c(PerlIO_printf(Perl_debug_log,
2100                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2101                                   PTR2UV(sv),
2102                                   SvUVX(sv),
2103                                   SvUVX(sv)));
2104         }
2105     }
2106     else if (SvPOKp(sv) && SvLEN(sv)) {
2107         UV value;
2108         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2109         /* We want to avoid a possible problem when we cache an IV/ a UV which
2110            may be later translated to an NV, and the resulting NV is not
2111            the same as the direct translation of the initial string
2112            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2113            be careful to ensure that the value with the .456 is around if the
2114            NV value is requested in the future).
2115
2116            This means that if we cache such an IV/a UV, we need to cache the
2117            NV as well.  Moreover, we trade speed for space, and do not
2118            cache the NV if we are sure it's not needed.
2119          */
2120
2121         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2122         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2123              == IS_NUMBER_IN_UV) {
2124             /* It's definitely an integer, only upgrade to PVIV */
2125             if (SvTYPE(sv) < SVt_PVIV)
2126                 sv_upgrade(sv, SVt_PVIV);
2127             (void)SvIOK_on(sv);
2128         } else if (SvTYPE(sv) < SVt_PVNV)
2129             sv_upgrade(sv, SVt_PVNV);
2130
2131         /* If NVs preserve UVs then we only use the UV value if we know that
2132            we aren't going to call atof() below. If NVs don't preserve UVs
2133            then the value returned may have more precision than atof() will
2134            return, even though value isn't perfectly accurate.  */
2135         if ((numtype & (IS_NUMBER_IN_UV
2136 #ifdef NV_PRESERVES_UV
2137                         | IS_NUMBER_NOT_INT
2138 #endif
2139             )) == IS_NUMBER_IN_UV) {
2140             /* This won't turn off the public IOK flag if it was set above  */
2141             (void)SvIOKp_on(sv);
2142
2143             if (!(numtype & IS_NUMBER_NEG)) {
2144                 /* positive */;
2145                 if (value <= (UV)IV_MAX) {
2146                     SvIV_set(sv, (IV)value);
2147                 } else {
2148                     /* it didn't overflow, and it was positive. */
2149                     SvUV_set(sv, value);
2150                     SvIsUV_on(sv);
2151                 }
2152             } else {
2153                 /* 2s complement assumption  */
2154                 if (value <= (UV)IV_MIN) {
2155                     SvIV_set(sv, -(IV)value);
2156                 } else {
2157                     /* Too negative for an IV.  This is a double upgrade, but
2158                        I'm assuming it will be rare.  */
2159                     if (SvTYPE(sv) < SVt_PVNV)
2160                         sv_upgrade(sv, SVt_PVNV);
2161                     SvNOK_on(sv);
2162                     SvIOK_off(sv);
2163                     SvIOKp_on(sv);
2164                     SvNV_set(sv, -(NV)value);
2165                     SvIV_set(sv, IV_MIN);
2166                 }
2167             }
2168         }
2169         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2170            will be in the previous block to set the IV slot, and the next
2171            block to set the NV slot.  So no else here.  */
2172
2173         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2174             != IS_NUMBER_IN_UV) {
2175             /* It wasn't an (integer that doesn't overflow the UV). */
2176             SvNV_set(sv, Atof(SvPVX_const(sv)));
2177
2178             if (! numtype && ckWARN(WARN_NUMERIC))
2179                 not_a_number(sv);
2180
2181 #if defined(USE_LONG_DOUBLE)
2182             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2183                                   PTR2UV(sv), SvNVX(sv)));
2184 #else
2185             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2186                                   PTR2UV(sv), SvNVX(sv)));
2187 #endif
2188
2189 #ifdef NV_PRESERVES_UV
2190             (void)SvIOKp_on(sv);
2191             (void)SvNOK_on(sv);
2192             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2193                 SvIV_set(sv, I_V(SvNVX(sv)));
2194                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2195                     SvIOK_on(sv);
2196                 } else {
2197                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2198                 }
2199                 /* UV will not work better than IV */
2200             } else {
2201                 if (SvNVX(sv) > (NV)UV_MAX) {
2202                     SvIsUV_on(sv);
2203                     /* Integer is inaccurate. NOK, IOKp, is UV */
2204                     SvUV_set(sv, UV_MAX);
2205                 } else {
2206                     SvUV_set(sv, U_V(SvNVX(sv)));
2207                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2208                        NV preservse UV so can do correct comparison.  */
2209                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2210                         SvIOK_on(sv);
2211                     } else {
2212                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2213                     }
2214                 }
2215                 SvIsUV_on(sv);
2216             }
2217 #else /* NV_PRESERVES_UV */
2218             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2219                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2220                 /* The IV/UV slot will have been set from value returned by
2221                    grok_number above.  The NV slot has just been set using
2222                    Atof.  */
2223                 SvNOK_on(sv);
2224                 assert (SvIOKp(sv));
2225             } else {
2226                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2227                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2228                     /* Small enough to preserve all bits. */
2229                     (void)SvIOKp_on(sv);
2230                     SvNOK_on(sv);
2231                     SvIV_set(sv, I_V(SvNVX(sv)));
2232                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2233                         SvIOK_on(sv);
2234                     /* Assumption: first non-preserved integer is < IV_MAX,
2235                        this NV is in the preserved range, therefore: */
2236                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2237                           < (UV)IV_MAX)) {
2238                         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);
2239                     }
2240                 } else {
2241                     /* IN_UV NOT_INT
2242                          0      0       already failed to read UV.
2243                          0      1       already failed to read UV.
2244                          1      0       you won't get here in this case. IV/UV
2245                                         slot set, public IOK, Atof() unneeded.
2246                          1      1       already read UV.
2247                        so there's no point in sv_2iuv_non_preserve() attempting
2248                        to use atol, strtol, strtoul etc.  */
2249 #  ifdef DEBUGGING
2250                     sv_2iuv_non_preserve (sv, numtype);
2251 #  else
2252                     sv_2iuv_non_preserve (sv);
2253 #  endif
2254                 }
2255             }
2256 #endif /* NV_PRESERVES_UV */
2257         /* It might be more code efficient to go through the entire logic above
2258            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2259            gets complex and potentially buggy, so more programmer efficient
2260            to do it this way, by turning off the public flags:  */
2261         if (!numtype)
2262             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2263         }
2264     }
2265     else  {
2266         if (isGV_with_GP(sv))
2267             return glob_2number((GV *)sv);
2268
2269         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2270             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2271                 report_uninit(sv);
2272         }
2273         if (SvTYPE(sv) < SVt_IV)
2274             /* Typically the caller expects that sv_any is not NULL now.  */
2275             sv_upgrade(sv, SVt_IV);
2276         /* Return 0 from the caller.  */
2277         return TRUE;
2278     }
2279     return FALSE;
2280 }
2281
2282 /*
2283 =for apidoc sv_2iv_flags
2284
2285 Return the integer value of an SV, doing any necessary string
2286 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2287 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2288
2289 =cut
2290 */
2291
2292 IV
2293 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2294 {
2295     dVAR;
2296     if (!sv)
2297         return 0;
2298     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2299         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2300            cache IVs just in case. In practice it seems that they never
2301            actually anywhere accessible by user Perl code, let alone get used
2302            in anything other than a string context.  */
2303         if (flags & SV_GMAGIC)
2304             mg_get(sv);
2305         if (SvIOKp(sv))
2306             return SvIVX(sv);
2307         if (SvNOKp(sv)) {
2308             return I_V(SvNVX(sv));
2309         }
2310         if (SvPOKp(sv) && SvLEN(sv)) {
2311             UV value;
2312             const int numtype
2313                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2314
2315             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2316                 == IS_NUMBER_IN_UV) {
2317                 /* It's definitely an integer */
2318                 if (numtype & IS_NUMBER_NEG) {
2319                     if (value < (UV)IV_MIN)
2320                         return -(IV)value;
2321                 } else {
2322                     if (value < (UV)IV_MAX)
2323                         return (IV)value;
2324                 }
2325             }
2326             if (!numtype) {
2327                 if (ckWARN(WARN_NUMERIC))
2328                     not_a_number(sv);
2329             }
2330             return I_V(Atof(SvPVX_const(sv)));
2331         }
2332         if (SvROK(sv)) {
2333             goto return_rok;
2334         }
2335         assert(SvTYPE(sv) >= SVt_PVMG);
2336         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2337     } else if (SvTHINKFIRST(sv)) {
2338         if (SvROK(sv)) {
2339         return_rok:
2340             if (SvAMAGIC(sv)) {
2341                 SV * const tmpstr=AMG_CALLun(sv,numer);
2342                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2343                     return SvIV(tmpstr);
2344                 }
2345             }
2346             return PTR2IV(SvRV(sv));
2347         }
2348         if (SvIsCOW(sv)) {
2349             sv_force_normal_flags(sv, 0);
2350         }
2351         if (SvREADONLY(sv) && !SvOK(sv)) {
2352             if (ckWARN(WARN_UNINITIALIZED))
2353                 report_uninit(sv);
2354             return 0;
2355         }
2356     }
2357     if (!SvIOKp(sv)) {
2358         if (S_sv_2iuv_common(aTHX_ sv))
2359             return 0;
2360     }
2361     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2362         PTR2UV(sv),SvIVX(sv)));
2363     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2364 }
2365
2366 /*
2367 =for apidoc sv_2uv_flags
2368
2369 Return the unsigned integer value of an SV, doing any necessary string
2370 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2371 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2372
2373 =cut
2374 */
2375
2376 UV
2377 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2378 {
2379     dVAR;
2380     if (!sv)
2381         return 0;
2382     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2383         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2384            cache IVs just in case.  */
2385         if (flags & SV_GMAGIC)
2386             mg_get(sv);
2387         if (SvIOKp(sv))
2388             return SvUVX(sv);
2389         if (SvNOKp(sv))
2390             return U_V(SvNVX(sv));
2391         if (SvPOKp(sv) && SvLEN(sv)) {
2392             UV value;
2393             const int numtype
2394                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2395
2396             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2397                 == IS_NUMBER_IN_UV) {
2398                 /* It's definitely an integer */
2399                 if (!(numtype & IS_NUMBER_NEG))
2400                     return value;
2401             }
2402             if (!numtype) {
2403                 if (ckWARN(WARN_NUMERIC))
2404                     not_a_number(sv);
2405             }
2406             return U_V(Atof(SvPVX_const(sv)));
2407         }
2408         if (SvROK(sv)) {
2409             goto return_rok;
2410         }
2411         assert(SvTYPE(sv) >= SVt_PVMG);
2412         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2413     } else if (SvTHINKFIRST(sv)) {
2414         if (SvROK(sv)) {
2415         return_rok:
2416             if (SvAMAGIC(sv)) {
2417                 SV *const tmpstr = AMG_CALLun(sv,numer);
2418                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2419                     return SvUV(tmpstr);
2420                 }
2421             }
2422             return PTR2UV(SvRV(sv));
2423         }
2424         if (SvIsCOW(sv)) {
2425             sv_force_normal_flags(sv, 0);
2426         }
2427         if (SvREADONLY(sv) && !SvOK(sv)) {
2428             if (ckWARN(WARN_UNINITIALIZED))
2429                 report_uninit(sv);
2430             return 0;
2431         }
2432     }
2433     if (!SvIOKp(sv)) {
2434         if (S_sv_2iuv_common(aTHX_ sv))
2435             return 0;
2436     }
2437
2438     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2439                           PTR2UV(sv),SvUVX(sv)));
2440     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2441 }
2442
2443 /*
2444 =for apidoc sv_2nv
2445
2446 Return the num value of an SV, doing any necessary string or integer
2447 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2448 macros.
2449
2450 =cut
2451 */
2452
2453 NV
2454 Perl_sv_2nv(pTHX_ register SV *const sv)
2455 {
2456     dVAR;
2457     if (!sv)
2458         return 0.0;
2459     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2460         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2461            cache IVs just in case.  */
2462         mg_get(sv);
2463         if (SvNOKp(sv))
2464             return SvNVX(sv);
2465         if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2466             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2467                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2468                 not_a_number(sv);
2469             return Atof(SvPVX_const(sv));
2470         }
2471         if (SvIOKp(sv)) {
2472             if (SvIsUV(sv))
2473                 return (NV)SvUVX(sv);
2474             else
2475                 return (NV)SvIVX(sv);
2476         }
2477         if (SvROK(sv)) {
2478             goto return_rok;
2479         }
2480         assert(SvTYPE(sv) >= SVt_PVMG);
2481         /* This falls through to the report_uninit near the end of the
2482            function. */
2483     } else if (SvTHINKFIRST(sv)) {
2484         if (SvROK(sv)) {
2485         return_rok:
2486             if (SvAMAGIC(sv)) {
2487                 SV *const tmpstr = AMG_CALLun(sv,numer);
2488                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2489                     return SvNV(tmpstr);
2490                 }
2491             }
2492             return PTR2NV(SvRV(sv));
2493         }
2494         if (SvIsCOW(sv)) {
2495             sv_force_normal_flags(sv, 0);
2496         }
2497         if (SvREADONLY(sv) && !SvOK(sv)) {
2498             if (ckWARN(WARN_UNINITIALIZED))
2499                 report_uninit(sv);
2500             return 0.0;
2501         }
2502     }
2503     if (SvTYPE(sv) < SVt_NV) {
2504         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2505         sv_upgrade(sv, SVt_NV);
2506 #ifdef USE_LONG_DOUBLE
2507         DEBUG_c({
2508             STORE_NUMERIC_LOCAL_SET_STANDARD();
2509             PerlIO_printf(Perl_debug_log,
2510                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2511                           PTR2UV(sv), SvNVX(sv));
2512             RESTORE_NUMERIC_LOCAL();
2513         });
2514 #else
2515         DEBUG_c({
2516             STORE_NUMERIC_LOCAL_SET_STANDARD();
2517             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2518                           PTR2UV(sv), SvNVX(sv));
2519             RESTORE_NUMERIC_LOCAL();
2520         });
2521 #endif
2522     }
2523     else if (SvTYPE(sv) < SVt_PVNV)
2524         sv_upgrade(sv, SVt_PVNV);
2525     if (SvNOKp(sv)) {
2526         return SvNVX(sv);
2527     }
2528     if (SvIOKp(sv)) {
2529         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2530 #ifdef NV_PRESERVES_UV
2531         if (SvIOK(sv))
2532             SvNOK_on(sv);
2533         else
2534             SvNOKp_on(sv);
2535 #else
2536         /* Only set the public NV OK flag if this NV preserves the IV  */
2537         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2538         if (SvIOK(sv) &&
2539             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2540                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2541             SvNOK_on(sv);
2542         else
2543             SvNOKp_on(sv);
2544 #endif
2545     }
2546     else if (SvPOKp(sv) && SvLEN(sv)) {
2547         UV value;
2548         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2549         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2550             not_a_number(sv);
2551 #ifdef NV_PRESERVES_UV
2552         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2553             == IS_NUMBER_IN_UV) {
2554             /* It's definitely an integer */
2555             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2556         } else
2557             SvNV_set(sv, Atof(SvPVX_const(sv)));
2558         if (numtype)
2559             SvNOK_on(sv);
2560         else
2561             SvNOKp_on(sv);
2562 #else
2563         SvNV_set(sv, Atof(SvPVX_const(sv)));
2564         /* Only set the public NV OK flag if this NV preserves the value in
2565            the PV at least as well as an IV/UV would.
2566            Not sure how to do this 100% reliably. */
2567         /* if that shift count is out of range then Configure's test is
2568            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2569            UV_BITS */
2570         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2571             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2572             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2573         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2574             /* Can't use strtol etc to convert this string, so don't try.
2575                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2576             SvNOK_on(sv);
2577         } else {
2578             /* value has been set.  It may not be precise.  */
2579             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2580                 /* 2s complement assumption for (UV)IV_MIN  */
2581                 SvNOK_on(sv); /* Integer is too negative.  */
2582             } else {
2583                 SvNOKp_on(sv);
2584                 SvIOKp_on(sv);
2585
2586                 if (numtype & IS_NUMBER_NEG) {
2587                     SvIV_set(sv, -(IV)value);
2588                 } else if (value <= (UV)IV_MAX) {
2589                     SvIV_set(sv, (IV)value);
2590                 } else {
2591                     SvUV_set(sv, value);
2592                     SvIsUV_on(sv);
2593                 }
2594
2595                 if (numtype & IS_NUMBER_NOT_INT) {
2596                     /* I believe that even if the original PV had decimals,
2597                        they are lost beyond the limit of the FP precision.
2598                        However, neither is canonical, so both only get p
2599                        flags.  NWC, 2000/11/25 */
2600                     /* Both already have p flags, so do nothing */
2601                 } else {
2602                     const NV nv = SvNVX(sv);
2603                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2604                         if (SvIVX(sv) == I_V(nv)) {
2605                             SvNOK_on(sv);
2606                         } else {
2607                             /* It had no "." so it must be integer.  */
2608                         }
2609                         SvIOK_on(sv);
2610                     } else {
2611                         /* between IV_MAX and NV(UV_MAX).
2612                            Could be slightly > UV_MAX */
2613
2614                         if (numtype & IS_NUMBER_NOT_INT) {
2615                             /* UV and NV both imprecise.  */
2616                         } else {
2617                             const UV nv_as_uv = U_V(nv);
2618
2619                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2620                                 SvNOK_on(sv);
2621                             }
2622                             SvIOK_on(sv);
2623                         }
2624                     }
2625                 }
2626             }
2627         }
2628         /* It might be more code efficient to go through the entire logic above
2629            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2630            gets complex and potentially buggy, so more programmer efficient
2631            to do it this way, by turning off the public flags:  */
2632         if (!numtype)
2633             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2634 #endif /* NV_PRESERVES_UV */
2635     }
2636     else  {
2637         if (isGV_with_GP(sv)) {
2638             glob_2number((GV *)sv);
2639             return 0.0;
2640         }
2641
2642         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2643             report_uninit(sv);
2644         assert (SvTYPE(sv) >= SVt_NV);
2645         /* Typically the caller expects that sv_any is not NULL now.  */
2646         /* XXX Ilya implies that this is a bug in callers that assume this
2647            and ideally should be fixed.  */
2648         return 0.0;
2649     }
2650 #if defined(USE_LONG_DOUBLE)
2651     DEBUG_c({
2652         STORE_NUMERIC_LOCAL_SET_STANDARD();
2653         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2654                       PTR2UV(sv), SvNVX(sv));
2655         RESTORE_NUMERIC_LOCAL();
2656     });
2657 #else
2658     DEBUG_c({
2659         STORE_NUMERIC_LOCAL_SET_STANDARD();
2660         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2661                       PTR2UV(sv), SvNVX(sv));
2662         RESTORE_NUMERIC_LOCAL();
2663     });
2664 #endif
2665     return SvNVX(sv);
2666 }
2667
2668 /*
2669 =for apidoc sv_2num
2670
2671 Return an SV with the numeric value of the source SV, doing any necessary
2672 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2673 access this function.
2674
2675 =cut
2676 */
2677
2678 SV *
2679 Perl_sv_2num(pTHX_ register SV *const sv)
2680 {
2681     PERL_ARGS_ASSERT_SV_2NUM;
2682
2683     if (!SvROK(sv))
2684         return sv;
2685     if (SvAMAGIC(sv)) {
2686         SV * const tmpsv = AMG_CALLun(sv,numer);
2687         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2688             return sv_2num(tmpsv);
2689     }
2690     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2691 }
2692
2693 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2694  * UV as a string towards the end of buf, and return pointers to start and
2695  * end of it.
2696  *
2697  * We assume that buf is at least TYPE_CHARS(UV) long.
2698  */
2699
2700 static char *
2701 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2702 {
2703     char *ptr = buf + TYPE_CHARS(UV);
2704     char * const ebuf = ptr;
2705     int sign;
2706
2707     PERL_ARGS_ASSERT_UIV_2BUF;
2708
2709     if (is_uv)
2710         sign = 0;
2711     else if (iv >= 0) {
2712         uv = iv;
2713         sign = 0;
2714     } else {
2715         uv = -iv;
2716         sign = 1;
2717     }
2718     do {
2719         *--ptr = '0' + (char)(uv % 10);
2720     } while (uv /= 10);
2721     if (sign)
2722         *--ptr = '-';
2723     *peob = ebuf;
2724     return ptr;
2725 }
2726
2727 /*
2728 =for apidoc sv_2pv_flags
2729
2730 Returns a pointer to the string value of an SV, and sets *lp to its length.
2731 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2732 if necessary.
2733 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2734 usually end up here too.
2735
2736 =cut
2737 */
2738
2739 char *
2740 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2741 {
2742     dVAR;
2743     register char *s;
2744
2745     if (!sv) {
2746         if (lp)
2747             *lp = 0;
2748         return (char *)"";
2749     }
2750     if (SvGMAGICAL(sv)) {
2751         if (flags & SV_GMAGIC)
2752             mg_get(sv);
2753         if (SvPOKp(sv)) {
2754             if (lp)
2755                 *lp = SvCUR(sv);
2756             if (flags & SV_MUTABLE_RETURN)
2757                 return SvPVX_mutable(sv);
2758             if (flags & SV_CONST_RETURN)
2759                 return (char *)SvPVX_const(sv);
2760             return SvPVX(sv);
2761         }
2762         if (SvIOKp(sv) || SvNOKp(sv)) {
2763             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2764             STRLEN len;
2765
2766             if (SvIOKp(sv)) {
2767                 len = SvIsUV(sv)
2768                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2769                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2770             } else {
2771                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2772                 len = strlen(tbuf);
2773             }
2774             assert(!SvROK(sv));
2775             {
2776                 dVAR;
2777
2778 #ifdef FIXNEGATIVEZERO
2779                 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2780                     tbuf[0] = '0';
2781                     tbuf[1] = 0;
2782                     len = 1;
2783                 }
2784 #endif
2785                 SvUPGRADE(sv, SVt_PV);
2786                 if (lp)
2787                     *lp = len;
2788                 s = SvGROW_mutable(sv, len + 1);
2789                 SvCUR_set(sv, len);
2790                 SvPOKp_on(sv);
2791                 return (char*)memcpy(s, tbuf, len + 1);
2792             }
2793         }
2794         if (SvROK(sv)) {
2795             goto return_rok;
2796         }
2797         assert(SvTYPE(sv) >= SVt_PVMG);
2798         /* This falls through to the report_uninit near the end of the
2799            function. */
2800     } else if (SvTHINKFIRST(sv)) {
2801         if (SvROK(sv)) {
2802         return_rok:
2803             if (SvAMAGIC(sv)) {
2804                 SV *const tmpstr = AMG_CALLun(sv,string);
2805                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2806                     /* Unwrap this:  */
2807                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2808                      */
2809
2810                     char *pv;
2811                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2812                         if (flags & SV_CONST_RETURN) {
2813                             pv = (char *) SvPVX_const(tmpstr);
2814                         } else {
2815                             pv = (flags & SV_MUTABLE_RETURN)
2816                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2817                         }
2818                         if (lp)
2819                             *lp = SvCUR(tmpstr);
2820                     } else {
2821                         pv = sv_2pv_flags(tmpstr, lp, flags);
2822                     }
2823                     if (SvUTF8(tmpstr))
2824                         SvUTF8_on(sv);
2825                     else
2826                         SvUTF8_off(sv);
2827                     return pv;
2828                 }
2829             }
2830             {
2831                 STRLEN len;
2832                 char *retval;
2833                 char *buffer;
2834                 const SV *const referent = (SV*)SvRV(sv);
2835
2836                 if (!referent) {
2837                     len = 7;
2838                     retval = buffer = savepvn("NULLREF", len);
2839                 } else if (SvTYPE(referent) == SVt_REGEXP) {
2840                     const REGEXP * const re = (REGEXP *)referent;
2841                     I32 seen_evals = 0;
2842
2843                     assert(re);
2844
2845                     /* If the regex is UTF-8 we want the containing scalar to
2846                        have an UTF-8 flag too */
2847                     if (RX_UTF8(re))
2848                         SvUTF8_on(sv);
2849                     else
2850                         SvUTF8_off(sv);
2851
2852                     if ((seen_evals = RX_SEEN_EVALS(re)))
2853                         PL_reginterp_cnt += seen_evals;
2854
2855                     if (lp)
2856                         *lp = RX_WRAPLEN(re);
2857
2858                     return RX_WRAPPED(re);
2859                 } else {
2860                     const char *const typestr = sv_reftype(referent, 0);
2861                     const STRLEN typelen = strlen(typestr);
2862                     UV addr = PTR2UV(referent);
2863                     const char *stashname = NULL;
2864                     STRLEN stashnamelen = 0; /* hush, gcc */
2865                     const char *buffer_end;
2866
2867                     if (SvOBJECT(referent)) {
2868                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2869
2870                         if (name) {
2871                             stashname = HEK_KEY(name);
2872                             stashnamelen = HEK_LEN(name);
2873
2874                             if (HEK_UTF8(name)) {
2875                                 SvUTF8_on(sv);
2876                             } else {
2877                                 SvUTF8_off(sv);
2878                             }
2879                         } else {
2880                             stashname = "__ANON__";
2881                             stashnamelen = 8;
2882                         }
2883                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2884                             + 2 * sizeof(UV) + 2 /* )\0 */;
2885                     } else {
2886                         len = typelen + 3 /* (0x */
2887                             + 2 * sizeof(UV) + 2 /* )\0 */;
2888                     }
2889
2890                     Newx(buffer, len, char);
2891                     buffer_end = retval = buffer + len;
2892
2893                     /* Working backwards  */
2894                     *--retval = '\0';
2895                     *--retval = ')';
2896                     do {
2897                         *--retval = PL_hexdigit[addr & 15];
2898                     } while (addr >>= 4);
2899                     *--retval = 'x';
2900                     *--retval = '0';
2901                     *--retval = '(';
2902
2903                     retval -= typelen;
2904                     memcpy(retval, typestr, typelen);
2905
2906                     if (stashname) {
2907                         *--retval = '=';
2908                         retval -= stashnamelen;
2909                         memcpy(retval, stashname, stashnamelen);
2910                     }
2911                     /* retval may not neccesarily have reached the start of the
2912                        buffer here.  */
2913                     assert (retval >= buffer);
2914
2915                     len = buffer_end - retval - 1; /* -1 for that \0  */
2916                 }
2917                 if (lp)
2918                     *lp = len;
2919                 SAVEFREEPV(buffer);
2920                 return retval;
2921             }
2922         }
2923         if (SvREADONLY(sv) && !SvOK(sv)) {
2924             if (lp)
2925                 *lp = 0;
2926             if (flags & SV_UNDEF_RETURNS_NULL)
2927                 return NULL;
2928             if (ckWARN(WARN_UNINITIALIZED))
2929                 report_uninit(sv);
2930             return (char *)"";
2931         }
2932     }
2933     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2934         /* I'm assuming that if both IV and NV are equally valid then
2935            converting the IV is going to be more efficient */
2936         const U32 isUIOK = SvIsUV(sv);
2937         char buf[TYPE_CHARS(UV)];
2938         char *ebuf, *ptr;
2939         STRLEN len;
2940
2941         if (SvTYPE(sv) < SVt_PVIV)
2942             sv_upgrade(sv, SVt_PVIV);
2943         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2944         len = ebuf - ptr;
2945         /* inlined from sv_setpvn */
2946         s = SvGROW_mutable(sv, len + 1);
2947         Move(ptr, s, len, char);
2948         s += len;
2949         *s = '\0';
2950     }
2951     else if (SvNOKp(sv)) {
2952         const int olderrno = errno;
2953         if (SvTYPE(sv) < SVt_PVNV)
2954             sv_upgrade(sv, SVt_PVNV);
2955         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2956         s = SvGROW_mutable(sv, NV_DIG + 20);
2957         /* some Xenix systems wipe out errno here */
2958 #ifdef apollo
2959         if (SvNVX(sv) == 0.0)
2960             my_strlcpy(s, "0", SvLEN(sv));
2961         else
2962 #endif /*apollo*/
2963         {
2964             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2965         }
2966         errno = olderrno;
2967 #ifdef FIXNEGATIVEZERO
2968         if (*s == '-' && s[1] == '0' && !s[2]) {
2969             s[0] = '0';
2970             s[1] = 0;
2971         }
2972 #endif
2973         while (*s) s++;
2974 #ifdef hcx
2975         if (s[-1] == '.')
2976             *--s = '\0';
2977 #endif
2978     }
2979     else {
2980         if (isGV_with_GP(sv))
2981             return glob_2pv((GV *)sv, lp);
2982
2983         if (lp)
2984             *lp = 0;
2985         if (flags & SV_UNDEF_RETURNS_NULL)
2986             return NULL;
2987         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2988             report_uninit(sv);
2989         if (SvTYPE(sv) < SVt_PV)
2990             /* Typically the caller expects that sv_any is not NULL now.  */
2991             sv_upgrade(sv, SVt_PV);
2992         return (char *)"";
2993     }
2994     {
2995         const STRLEN len = s - SvPVX_const(sv);
2996         if (lp)
2997             *lp = len;
2998         SvCUR_set(sv, len);
2999     }
3000     SvPOK_on(sv);
3001     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3002                           PTR2UV(sv),SvPVX_const(sv)));
3003     if (flags & SV_CONST_RETURN)
3004         return (char *)SvPVX_const(sv);
3005     if (flags & SV_MUTABLE_RETURN)
3006         return SvPVX_mutable(sv);
3007     return SvPVX(sv);
3008 }
3009
3010 /*
3011 =for apidoc sv_copypv
3012
3013 Copies a stringified representation of the source SV into the
3014 destination SV.  Automatically performs any necessary mg_get and
3015 coercion of numeric values into strings.  Guaranteed to preserve
3016 UTF8 flag even from overloaded objects.  Similar in nature to
3017 sv_2pv[_flags] but operates directly on an SV instead of just the
3018 string.  Mostly uses sv_2pv_flags to do its work, except when that
3019 would lose the UTF-8'ness of the PV.
3020
3021 =cut
3022 */
3023
3024 void
3025 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3026 {
3027     STRLEN len;
3028     const char * const s = SvPV_const(ssv,len);
3029
3030     PERL_ARGS_ASSERT_SV_COPYPV;
3031
3032     sv_setpvn(dsv,s,len);
3033     if (SvUTF8(ssv))
3034         SvUTF8_on(dsv);
3035     else
3036         SvUTF8_off(dsv);
3037 }
3038
3039 /*
3040 =for apidoc sv_2pvbyte
3041
3042 Return a pointer to the byte-encoded representation of the SV, and set *lp
3043 to its length.  May cause the SV to be downgraded from UTF-8 as a
3044 side-effect.
3045
3046 Usually accessed via the C<SvPVbyte> macro.
3047
3048 =cut
3049 */
3050
3051 char *
3052 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3053 {
3054     PERL_ARGS_ASSERT_SV_2PVBYTE;
3055
3056     sv_utf8_downgrade(sv,0);
3057     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3058 }
3059
3060 /*
3061 =for apidoc sv_2pvutf8
3062
3063 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3064 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3065
3066 Usually accessed via the C<SvPVutf8> macro.
3067
3068 =cut
3069 */
3070
3071 char *
3072 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3073 {
3074     PERL_ARGS_ASSERT_SV_2PVUTF8;
3075
3076     sv_utf8_upgrade(sv);
3077     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3078 }
3079
3080
3081 /*
3082 =for apidoc sv_2bool
3083
3084 This function is only called on magical items, and is only used by
3085 sv_true() or its macro equivalent.
3086
3087 =cut
3088 */
3089
3090 bool
3091 Perl_sv_2bool(pTHX_ register SV *const sv)
3092 {
3093     dVAR;
3094
3095     PERL_ARGS_ASSERT_SV_2BOOL;
3096
3097     SvGETMAGIC(sv);
3098
3099     if (!SvOK(sv))
3100         return 0;
3101     if (SvROK(sv)) {
3102         if (SvAMAGIC(sv)) {
3103             SV * const tmpsv = AMG_CALLun(sv,bool_);
3104             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3105                 return (bool)SvTRUE(tmpsv);
3106         }
3107         return SvRV(sv) != 0;
3108     }
3109     if (SvPOKp(sv)) {
3110         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3111         if (Xpvtmp &&
3112                 (*sv->sv_u.svu_pv > '0' ||
3113                 Xpvtmp->xpv_cur > 1 ||
3114                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3115             return 1;
3116         else
3117             return 0;
3118     }
3119     else {
3120         if (SvIOKp(sv))
3121             return SvIVX(sv) != 0;
3122         else {
3123             if (SvNOKp(sv))
3124                 return SvNVX(sv) != 0.0;
3125             else {
3126                 if (isGV_with_GP(sv))
3127                     return TRUE;
3128                 else
3129                     return FALSE;
3130             }
3131         }
3132     }
3133 }
3134
3135 /*
3136 =for apidoc sv_utf8_upgrade
3137
3138 Converts the PV of an SV to its UTF-8-encoded form.
3139 Forces the SV to string form if it is not already.
3140 Always sets the SvUTF8 flag to avoid future validity checks even
3141 if all the bytes have hibit clear.
3142
3143 This is not as a general purpose byte encoding to Unicode interface:
3144 use the Encode extension for that.
3145
3146 =for apidoc sv_utf8_upgrade_flags
3147
3148 Converts the PV of an SV to its UTF-8-encoded form.
3149 Forces the SV to string form if it is not already.
3150 Always sets the SvUTF8 flag to avoid future validity checks even
3151 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3152 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3153 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3154
3155 This is not as a general purpose byte encoding to Unicode interface:
3156 use the Encode extension for that.
3157
3158 =cut
3159 */
3160
3161 STRLEN
3162 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags)
3163 {
3164     dVAR;
3165
3166     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS;
3167
3168     if (sv == &PL_sv_undef)
3169         return 0;
3170     if (!SvPOK(sv)) {
3171         STRLEN len = 0;
3172         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3173             (void) sv_2pv_flags(sv,&len, flags);
3174             if (SvUTF8(sv))
3175                 return len;
3176         } else {
3177             (void) SvPV_force(sv,len);
3178         }
3179     }
3180
3181     if (SvUTF8(sv)) {
3182         return SvCUR(sv);
3183     }
3184
3185     if (SvIsCOW(sv)) {
3186         sv_force_normal_flags(sv, 0);
3187     }
3188
3189     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3190         sv_recode_to_utf8(sv, PL_encoding);
3191     else { /* Assume Latin-1/EBCDIC */
3192         /* This function could be much more efficient if we
3193          * had a FLAG in SVs to signal if there are any hibit
3194          * chars in the PV.  Given that there isn't such a flag
3195          * make the loop as fast as possible. */
3196         const U8 * const s = (U8 *) SvPVX_const(sv);
3197         const U8 * const e = (U8 *) SvEND(sv);
3198         const U8 *t = s;
3199
3200         while (t < e) {
3201             const U8 ch = *t++;
3202             /* Check for hi bit */
3203             if (!NATIVE_IS_INVARIANT(ch)) {
3204                 STRLEN len = SvCUR(sv);
3205                 /* *Currently* bytes_to_utf8() adds a '\0' after every string
3206                    it converts. This isn't documented. It's not clear if it's
3207                    a bad thing to be doing, and should be changed to do exactly
3208                    what the documentation says. If so, this code will have to
3209                    be changed.
3210                    As is, we mustn't rely on our incoming SV being well formed
3211                    and having a trailing '\0', as certain code in pp_formline
3212                    can send us partially built SVs. */
3213                 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3214
3215                 SvPV_free(sv); /* No longer using what was there before. */
3216                 SvPV_set(sv, (char*)recoded);
3217                 SvCUR_set(sv, len);
3218                 SvLEN_set(sv, len + 1); /* No longer know the real size. */
3219                 break;
3220             }
3221         }
3222         /* Mark as UTF-8 even if no hibit - saves scanning loop */
3223         SvUTF8_on(sv);
3224     }
3225     return SvCUR(sv);
3226 }
3227
3228 /*
3229 =for apidoc sv_utf8_downgrade
3230
3231 Attempts to convert the PV of an SV from characters to bytes.
3232 If the PV contains a character beyond byte, this conversion will fail;
3233 in this case, either returns false or, if C<fail_ok> is not
3234 true, croaks.
3235
3236 This is not as a general purpose Unicode to byte encoding interface:
3237 use the Encode extension for that.
3238
3239 =cut
3240 */
3241
3242 bool
3243 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3244 {
3245     dVAR;
3246
3247     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3248
3249     if (SvPOKp(sv) && SvUTF8(sv)) {
3250         if (SvCUR(sv)) {
3251             U8 *s;
3252             STRLEN len;
3253
3254             if (SvIsCOW(sv)) {
3255                 sv_force_normal_flags(sv, 0);
3256             }
3257             s = (U8 *) SvPV(sv, len);
3258             if (!utf8_to_bytes(s, &len)) {
3259                 if (fail_ok)
3260                     return FALSE;
3261                 else {
3262                     if (PL_op)
3263                         Perl_croak(aTHX_ "Wide character in %s",
3264                                    OP_DESC(PL_op));
3265                     else
3266                         Perl_croak(aTHX_ "Wide character");
3267                 }
3268             }
3269             SvCUR_set(sv, len);
3270         }
3271     }
3272     SvUTF8_off(sv);
3273     return TRUE;
3274 }
3275
3276 /*
3277 =for apidoc sv_utf8_encode
3278
3279 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3280 flag off so that it looks like octets again.
3281
3282 =cut
3283 */
3284
3285 void
3286 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3287 {
3288     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3289
3290     if (SvIsCOW(sv)) {
3291         sv_force_normal_flags(sv, 0);
3292     }
3293     if (SvREADONLY(sv)) {
3294         Perl_croak(aTHX_ PL_no_modify);
3295     }
3296     (void) sv_utf8_upgrade(sv);
3297     SvUTF8_off(sv);
3298 }
3299
3300 /*
3301 =for apidoc sv_utf8_decode
3302
3303 If the PV of the SV is an octet sequence in UTF-8
3304 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3305 so that it looks like a character. If the PV contains only single-byte
3306 characters, the C<SvUTF8> flag stays being off.
3307 Scans PV for validity and returns false if the PV is invalid UTF-8.
3308
3309 =cut
3310 */
3311
3312 bool
3313 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3314 {
3315     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3316
3317     if (SvPOKp(sv)) {
3318         const U8 *c;
3319         const U8 *e;
3320
3321         /* The octets may have got themselves encoded - get them back as
3322          * bytes
3323          */
3324         if (!sv_utf8_downgrade(sv, TRUE))
3325             return FALSE;
3326
3327         /* it is actually just a matter of turning the utf8 flag on, but
3328          * we want to make sure everything inside is valid utf8 first.
3329          */
3330         c = (const U8 *) SvPVX_const(sv);
3331         if (!is_utf8_string(c, SvCUR(sv)+1))
3332             return FALSE;
3333         e = (const U8 *) SvEND(sv);
3334         while (c < e) {
3335             const U8 ch = *c++;
3336             if (!UTF8_IS_INVARIANT(ch)) {
3337                 SvUTF8_on(sv);
3338                 break;
3339             }
3340         }
3341     }
3342     return TRUE;
3343 }
3344
3345 /*
3346 =for apidoc sv_setsv
3347
3348 Copies the contents of the source SV C<ssv> into the destination SV
3349 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3350 function if the source SV needs to be reused. Does not handle 'set' magic.
3351 Loosely speaking, it performs a copy-by-value, obliterating any previous
3352 content of the destination.
3353
3354 You probably want to use one of the assortment of wrappers, such as
3355 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3356 C<SvSetMagicSV_nosteal>.
3357
3358 =for apidoc sv_setsv_flags
3359
3360 Copies the contents of the source SV C<ssv> into the destination SV
3361 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3362 function if the source SV needs to be reused. Does not handle 'set' magic.
3363 Loosely speaking, it performs a copy-by-value, obliterating any previous
3364 content of the destination.
3365 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3366 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3367 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3368 and C<sv_setsv_nomg> are implemented in terms of this function.
3369
3370 You probably want to use one of the assortment of wrappers, such as
3371 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3372 C<SvSetMagicSV_nosteal>.
3373
3374 This is the primary function for copying scalars, and most other
3375 copy-ish functions and macros use this underneath.
3376
3377 =cut
3378 */
3379
3380 static void
3381 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3382 {
3383     I32 mro_changes = 0; /* 1 = method, 2 = isa */
3384
3385     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3386
3387     if (dtype != SVt_PVGV) {
3388         const char * const name = GvNAME(sstr);
3389         const STRLEN len = GvNAMELEN(sstr);
3390         {
3391             if (dtype >= SVt_PV) {
3392                 SvPV_free(dstr);
3393                 SvPV_set(dstr, 0);
3394                 SvLEN_set(dstr, 0);
3395                 SvCUR_set(dstr, 0);
3396             }
3397             SvUPGRADE(dstr, SVt_PVGV);
3398             (void)SvOK_off(dstr);
3399             /* FIXME - why are we doing this, then turning it off and on again
3400                below?  */
3401             isGV_with_GP_on(dstr);
3402         }
3403         GvSTASH(dstr) = GvSTASH(sstr);
3404         if (GvSTASH(dstr))
3405             Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3406         gv_name_set((GV *)dstr, name, len, GV_ADD);
3407         SvFAKE_on(dstr);        /* can coerce to non-glob */
3408     }
3409
3410 #ifdef GV_UNIQUE_CHECK
3411     if (GvUNIQUE((GV*)dstr)) {
3412         Perl_croak(aTHX_ PL_no_modify);
3413     }
3414 #endif
3415
3416     if(GvGP((GV*)sstr)) {
3417         /* If source has method cache entry, clear it */
3418         if(GvCVGEN(sstr)) {
3419             SvREFCNT_dec(GvCV(sstr));
3420             GvCV(sstr) = NULL;
3421             GvCVGEN(sstr) = 0;
3422         }
3423         /* If source has a real method, then a method is
3424            going to change */
3425         else if(GvCV((GV*)sstr)) {
3426             mro_changes = 1;
3427         }
3428     }
3429
3430     /* If dest already had a real method, that's a change as well */
3431     if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
3432         mro_changes = 1;
3433     }
3434
3435     if(strEQ(GvNAME((GV*)dstr),"ISA"))
3436         mro_changes = 2;
3437
3438     gp_free((GV*)dstr);
3439     isGV_with_GP_off(dstr);
3440     (void)SvOK_off(dstr);
3441     isGV_with_GP_on(dstr);
3442     GvINTRO_off(dstr);          /* one-shot flag */
3443     GvGP(dstr) = gp_ref(GvGP(sstr));
3444     if (SvTAINTED(sstr))
3445         SvTAINT(dstr);
3446     if (GvIMPORTED(dstr) != GVf_IMPORTED
3447         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3448         {
3449             GvIMPORTED_on(dstr);
3450         }
3451     GvMULTI_on(dstr);
3452     if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3453     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3454     return;
3455 }
3456
3457 static void
3458 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3459 {
3460     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3461     SV *dref = NULL;
3462     const int intro = GvINTRO(dstr);
3463     SV **location;
3464     U8 import_flag = 0;
3465     const U32 stype = SvTYPE(sref);
3466
3467     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3468
3469 #ifdef GV_UNIQUE_CHECK
3470     if (GvUNIQUE((GV*)dstr)) {
3471         Perl_croak(aTHX_ PL_no_modify);
3472     }
3473 #endif
3474
3475     if (intro) {
3476         GvINTRO_off(dstr);      /* one-shot flag */
3477         GvLINE(dstr) = CopLINE(PL_curcop);
3478         GvEGV(dstr) = (GV*)dstr;
3479     }
3480     GvMULTI_on(dstr);
3481     switch (stype) {
3482     case SVt_PVCV:
3483         location = (SV **) &GvCV(dstr);
3484         import_flag = GVf_IMPORTED_CV;
3485         goto common;
3486     case SVt_PVHV:
3487         location = (SV **) &GvHV(dstr);
3488         import_flag = GVf_IMPORTED_HV;
3489         goto common;
3490     case SVt_PVAV:
3491         location = (SV **) &GvAV(dstr);
3492         import_flag = GVf_IMPORTED_AV;
3493         goto common;
3494     case SVt_PVIO:
3495         location = (SV **) &GvIOp(dstr);
3496         goto common;
3497     case SVt_PVFM:
3498         location = (SV **) &GvFORM(dstr);
3499     default:
3500         location = &GvSV(dstr);
3501         import_flag = GVf_IMPORTED_SV;
3502     common:
3503         if (intro) {
3504             if (stype == SVt_PVCV) {
3505                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3506                 if (GvCVGEN(dstr)) {
3507                     SvREFCNT_dec(GvCV(dstr));
3508                     GvCV(dstr) = NULL;
3509                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3510                 }
3511             }
3512             SAVEGENERICSV(*location);
3513         }
3514         else
3515             dref = *location;
3516         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3517             CV* const cv = MUTABLE_CV(*location);
3518             if (cv) {
3519                 if (!GvCVGEN((GV*)dstr) &&
3520                     (CvROOT(cv) || CvXSUB(cv)))
3521                     {
3522                         /* Redefining a sub - warning is mandatory if
3523                            it was a const and its value changed. */
3524                         if (CvCONST(cv) && CvCONST((const CV *)sref)
3525                             && cv_const_sv(cv)
3526                             == cv_const_sv((const CV *)sref)) {
3527                             NOOP;
3528                             /* They are 2 constant subroutines generated from
3529                                the same constant. This probably means that
3530                                they are really the "same" proxy subroutine
3531                                instantiated in 2 places. Most likely this is
3532                                when a constant is exported twice.  Don't warn.
3533                             */
3534                         }
3535                         else if (ckWARN(WARN_REDEFINE)
3536                                  || (CvCONST(cv)
3537                                      && (!CvCONST((const CV *)sref)
3538                                          || sv_cmp(cv_const_sv(cv),
3539                                                    cv_const_sv((const CV *)
3540                                                                sref))))) {
3541                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3542                                         (const char *)
3543                                         (CvCONST(cv)
3544                                          ? "Constant subroutine %s::%s redefined"
3545                                          : "Subroutine %s::%s redefined"),
3546                                         HvNAME_get(GvSTASH((GV*)dstr)),
3547                                         GvENAME((GV*)dstr));
3548                         }
3549                     }
3550                 if (!intro)
3551                     cv_ckproto_len(cv, (GV*)dstr,
3552                                    SvPOK(sref) ? SvPVX_const(sref) : NULL,
3553                                    SvPOK(sref) ? SvCUR(sref) : 0);
3554             }
3555             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3556             GvASSUMECV_on(dstr);
3557             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3558         }
3559         *location = sref;
3560         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3561             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3562             GvFLAGS(dstr) |= import_flag;
3563         }
3564         break;
3565     }
3566     SvREFCNT_dec(dref);
3567     if (SvTAINTED(sstr))
3568         SvTAINT(dstr);
3569     return;
3570 }
3571
3572 void
3573 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3574 {
3575     dVAR;
3576     register U32 sflags;
3577     register int dtype;
3578     register svtype stype;
3579
3580     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3581
3582     if (sstr == dstr)
3583         return;
3584
3585     if (SvIS_FREED(dstr)) {
3586         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3587                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3588     }
3589     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3590     if (!sstr)
3591         sstr = &PL_sv_undef;
3592     if (SvIS_FREED(sstr)) {
3593         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3594                    (void*)sstr, (void*)dstr);
3595     }
3596     stype = SvTYPE(sstr);
3597     dtype = SvTYPE(dstr);
3598
3599     (void)SvAMAGIC_off(dstr);
3600     if ( SvVOK(dstr) )
3601     {
3602         /* need to nuke the magic */
3603         mg_free(dstr);
3604     }
3605
3606     /* There's a lot of redundancy below but we're going for speed here */
3607
3608     switch (stype) {
3609     case SVt_NULL:
3610       undef_sstr:
3611         if (dtype != SVt_PVGV) {
3612             (void)SvOK_off(dstr);
3613             return;
3614         }
3615         break;
3616     case SVt_IV:
3617         if (SvIOK(sstr)) {
3618             switch (dtype) {
3619             case SVt_NULL:
3620                 sv_upgrade(dstr, SVt_IV);
3621                 break;
3622             case SVt_NV:
3623             case SVt_PV:
3624                 sv_upgrade(dstr, SVt_PVIV);
3625                 break;
3626             case SVt_PVGV:
3627                 goto end_of_first_switch;
3628             }
3629             (void)SvIOK_only(dstr);
3630             SvIV_set(dstr,  SvIVX(sstr));
3631             if (SvIsUV(sstr))
3632                 SvIsUV_on(dstr);
3633             /* SvTAINTED can only be true if the SV has taint magic, which in
3634                turn means that the SV type is PVMG (or greater). This is the
3635                case statement for SVt_IV, so this cannot be true (whatever gcov
3636                may say).  */
3637             assert(!SvTAINTED(sstr));
3638             return;
3639         }
3640         if (!SvROK(sstr))
3641             goto undef_sstr;
3642         if (dtype < SVt_PV && dtype != SVt_IV)
3643             sv_upgrade(dstr, SVt_IV);
3644         break;
3645
3646     case SVt_NV:
3647         if (SvNOK(sstr)) {
3648             switch (dtype) {
3649             case SVt_NULL:
3650             case SVt_IV:
3651                 sv_upgrade(dstr, SVt_NV);
3652                 break;
3653             case SVt_PV:
3654             case SVt_PVIV:
3655                 sv_upgrade(dstr, SVt_PVNV);
3656                 break;
3657             case SVt_PVGV:
3658                 goto end_of_first_switch;
3659             }
3660             SvNV_set(dstr, SvNVX(sstr));
3661             (void)SvNOK_only(dstr);
3662             /* SvTAINTED can only be true if the SV has taint magic, which in
3663                turn means that the SV type is PVMG (or greater). This is the
3664                case statement for SVt_NV, so this cannot be true (whatever gcov
3665                may say).  */
3666             assert(!SvTAINTED(sstr));
3667             return;
3668         }
3669         goto undef_sstr;
3670
3671     case SVt_PVFM:
3672 #ifdef PERL_OLD_COPY_ON_WRITE
3673         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3674             if (dtype < SVt_PVIV)
3675                 sv_upgrade(dstr, SVt_PVIV);
3676             break;
3677         }
3678         /* Fall through */
3679 #endif
3680     case SVt_REGEXP:
3681     case SVt_PV:
3682         if (dtype < SVt_PV)
3683             sv_upgrade(dstr, SVt_PV);
3684         break;
3685     case SVt_PVIV:
3686         if (dtype < SVt_PVIV)
3687             sv_upgrade(dstr, SVt_PVIV);
3688         break;
3689     case SVt_PVNV:
3690         if (dtype < SVt_PVNV)
3691             sv_upgrade(dstr, SVt_PVNV);
3692         break;
3693     default:
3694         {
3695         const char * const type = sv_reftype(sstr,0);
3696         if (PL_op)
3697             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3698         else
3699             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3700         }
3701         break;
3702
3703         /* case SVt_BIND: */
3704     case SVt_PVLV:
3705     case SVt_PVGV:
3706         if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3707             glob_assign_glob(dstr, sstr, dtype);
3708             return;
3709         }
3710         /* SvVALID means that this PVGV is playing at being an FBM.  */
3711         /*FALLTHROUGH*/
3712
3713     case SVt_PVMG:
3714         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3715             mg_get(sstr);
3716             if (SvTYPE(sstr) != stype) {
3717                 stype = SvTYPE(sstr);
3718                 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3719                     glob_assign_glob(dstr, sstr, dtype);
3720                     return;
3721                 }
3722             }
3723         }
3724         if (stype == SVt_PVLV)
3725             SvUPGRADE(dstr, SVt_PVNV);
3726         else
3727             SvUPGRADE(dstr, (svtype)stype);
3728     }
3729  end_of_first_switch:
3730
3731     /* dstr may have been upgraded.  */
3732     dtype = SvTYPE(dstr);
3733     sflags = SvFLAGS(sstr);
3734
3735     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3736         /* Assigning to a subroutine sets the prototype.  */
3737         if (SvOK(sstr)) {
3738             STRLEN len;
3739             const char *const ptr = SvPV_const(sstr, len);
3740
3741             SvGROW(dstr, len + 1);
3742             Copy(ptr, SvPVX(dstr), len + 1, char);
3743             SvCUR_set(dstr, len);
3744             SvPOK_only(dstr);
3745             SvFLAGS(dstr) |= sflags & SVf_UTF8;
3746         } else {
3747             SvOK_off(dstr);
3748         }
3749     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3750         const char * const type = sv_reftype(dstr,0);
3751         if (PL_op)
3752             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3753         else
3754             Perl_croak(aTHX_ "Cannot copy to %s", type);
3755     } else if (sflags & SVf_ROK) {
3756         if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3757             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3758             sstr = SvRV(sstr);
3759             if (sstr == dstr) {
3760                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3761                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3762                 {
3763                     GvIMPORTED_on(dstr);
3764                 }
3765                 GvMULTI_on(dstr);
3766                 return;
3767             }
3768             glob_assign_glob(dstr, sstr, dtype);
3769             return;
3770         }
3771
3772         if (dtype >= SVt_PV) {
3773             if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3774                 glob_assign_ref(dstr, sstr);
3775                 return;
3776             }
3777             if (SvPVX_const(dstr)) {
3778                 SvPV_free(dstr);
3779                 SvLEN_set(dstr, 0);
3780                 SvCUR_set(dstr, 0);
3781             }
3782         }
3783         (void)SvOK_off(dstr);
3784         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3785         SvFLAGS(dstr) |= sflags & SVf_ROK;
3786         assert(!(sflags & SVp_NOK));
3787         assert(!(sflags & SVp_IOK));
3788         assert(!(sflags & SVf_NOK));
3789         assert(!(sflags & SVf_IOK));
3790     }
3791     else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3792         if (!(sflags & SVf_OK)) {
3793             if (ckWARN(WARN_MISC))
3794                 Perl_warner(aTHX_ packWARN(WARN_MISC),
3795                             "Undefined value assigned to typeglob");
3796         }
3797         else {
3798             GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3799             if (dstr != (SV*)gv) {
3800                 if (GvGP(dstr))
3801                     gp_free((GV*)dstr);
3802                 GvGP(dstr) = gp_ref(GvGP(gv));
3803             }
3804         }
3805     }
3806     else if (sflags & SVp_POK) {
3807         bool isSwipe = 0;
3808
3809         /*
3810          * Check to see if we can just swipe the string.  If so, it's a
3811          * possible small lose on short strings, but a big win on long ones.
3812          * It might even be a win on short strings if SvPVX_const(dstr)
3813          * has to be allocated and SvPVX_const(sstr) has to be freed.
3814          * Likewise if we can set up COW rather than doing an actual copy, we
3815          * drop to the else clause, as the swipe code and the COW setup code
3816          * have much in common.
3817          */
3818
3819         /* Whichever path we take through the next code, we want this true,
3820            and doing it now facilitates the COW check.  */
3821         (void)SvPOK_only(dstr);
3822
3823         if (
3824             /* If we're already COW then this clause is not true, and if COW
3825                is allowed then we drop down to the else and make dest COW
3826                with us.  If caller hasn't said that we're allowed to COW
3827                shared hash keys then we don't do the COW setup, even if the
3828                source scalar is a shared hash key scalar.  */
3829             (((flags & SV_COW_SHARED_HASH_KEYS)
3830                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
3831                : 1 /* If making a COW copy is forbidden then the behaviour we
3832                        desire is as if the source SV isn't actually already
3833                        COW, even if it is.  So we act as if the source flags
3834                        are not COW, rather than actually testing them.  */
3835               )
3836 #ifndef PERL_OLD_COPY_ON_WRITE
3837              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
3838                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
3839                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
3840                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
3841                 but in turn, it's somewhat dead code, never expected to go
3842                 live, but more kept as a placeholder on how to do it better
3843                 in a newer implementation.  */
3844              /* If we are COW and dstr is a suitable target then we drop down
3845                 into the else and make dest a COW of us.  */
3846              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3847 #endif
3848              )
3849             &&
3850             !(isSwipe =
3851                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
3852                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
3853                  (!(flags & SV_NOSTEAL)) &&
3854                                         /* and we're allowed to steal temps */
3855                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
3856                  SvLEN(sstr)    &&        /* and really is a string */
3857                                 /* and won't be needed again, potentially */
3858               !(PL_op && PL_op->op_type == OP_AASSIGN))
3859 #ifdef PERL_OLD_COPY_ON_WRITE
3860             && ((flags & SV_COW_SHARED_HASH_KEYS)
3861                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3862                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3863                      && SvTYPE(sstr) >= SVt_PVIV))
3864                 : 1)
3865 #endif
3866             ) {
3867             /* Failed the swipe test, and it's not a shared hash key either.
3868                Have to copy the string.  */
3869             STRLEN len = SvCUR(sstr);
3870             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3871             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3872             SvCUR_set(dstr, len);
3873             *SvEND(dstr) = '\0';
3874         } else {
3875             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3876                be true in here.  */
3877             /* Either it's a shared hash key, or it's suitable for
3878                copy-on-write or we can swipe the string.  */
3879             if (DEBUG_C_TEST) {
3880                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3881                 sv_dump(sstr);
3882                 sv_dump(dstr);
3883             }
3884 #ifdef PERL_OLD_COPY_ON_WRITE
3885             if (!isSwipe) {
3886                 /* I believe I should acquire a global SV mutex if
3887                    it's a COW sv (not a shared hash key) to stop
3888                    it going un copy-on-write.
3889                    If the source SV has gone un copy on write between up there
3890                    and down here, then (assert() that) it is of the correct
3891                    form to make it copy on write again */
3892                 if ((sflags & (SVf_FAKE | SVf_READONLY))
3893                     != (SVf_FAKE | SVf_READONLY)) {
3894                     SvREADONLY_on(sstr);
3895                     SvFAKE_on(sstr);
3896                     /* Make the source SV into a loop of 1.
3897                        (about to become 2) */
3898                     SV_COW_NEXT_SV_SET(sstr, sstr);
3899                 }
3900             }
3901 #endif
3902             /* Initial code is common.  */
3903             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
3904                 SvPV_free(dstr);
3905             }
3906
3907             if (!isSwipe) {
3908                 /* making another shared SV.  */
3909                 STRLEN cur = SvCUR(sstr);
3910                 STRLEN len = SvLEN(sstr);
3911 #ifdef PERL_OLD_COPY_ON_WRITE
3912                 if (len) {
3913                     assert (SvTYPE(dstr) >= SVt_PVIV);
3914                     /* SvIsCOW_normal */
3915                     /* splice us in between source and next-after-source.  */
3916                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3917                     SV_COW_NEXT_SV_SET(sstr, dstr);
3918                     SvPV_set(dstr, SvPVX_mutable(sstr));
3919                 } else
3920 #endif
3921                 {
3922                     /* SvIsCOW_shared_hash */
3923                     DEBUG_C(PerlIO_printf(Perl_debug_log,
3924                                           "Copy on write: Sharing hash\n"));
3925
3926                     assert (SvTYPE(dstr) >= SVt_PV);
3927                     SvPV_set(dstr,
3928                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3929                 }
3930                 SvLEN_set(dstr, len);
3931                 SvCUR_set(dstr, cur);
3932                 SvREADONLY_on(dstr);
3933                 SvFAKE_on(dstr);
3934                 /* Relesase a global SV mutex.  */
3935             }
3936             else
3937                 {       /* Passes the swipe test.  */
3938                 SvPV_set(dstr, SvPVX_mutable(sstr));
3939                 SvLEN_set(dstr, SvLEN(sstr));
3940                 SvCUR_set(dstr, SvCUR(sstr));
3941
3942                 SvTEMP_off(dstr);
3943                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
3944                 SvPV_set(sstr, NULL);
3945                 SvLEN_set(sstr, 0);
3946                 SvCUR_set(sstr, 0);
3947                 SvTEMP_off(sstr);
3948             }
3949         }
3950         if (sflags & SVp_NOK) {
3951             SvNV_set(dstr, SvNVX(sstr));
3952         }
3953         if (sflags & SVp_IOK) {
3954             SvIV_set(dstr, SvIVX(sstr));
3955             /* Must do this otherwise some other overloaded use of 0x80000000
3956                gets confused. I guess SVpbm_VALID */
3957             if (sflags & SVf_IVisUV)
3958                 SvIsUV_on(dstr);
3959         }
3960         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
3961         {
3962             const MAGIC * const smg = SvVSTRING_mg(sstr);
3963             if (smg) {
3964                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3965                          smg->mg_ptr, smg->mg_len);
3966                 SvRMAGICAL_on(dstr);
3967             }
3968         }
3969     }
3970     else if (sflags & (SVp_IOK|SVp_NOK)) {
3971         (void)SvOK_off(dstr);
3972         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
3973         if (sflags & SVp_IOK) {
3974             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3975             SvIV_set(dstr, SvIVX(sstr));
3976         }
3977         if (sflags & SVp_NOK) {
3978             SvNV_set(dstr, SvNVX(sstr));
3979         }
3980     }
3981     else {
3982         if (isGV_with_GP(sstr)) {
3983             /* This stringification rule for globs is spread in 3 places.
3984                This feels bad. FIXME.  */
3985             const U32 wasfake = sflags & SVf_FAKE;
3986
3987             /* FAKE globs can get coerced, so need to turn this off
3988                temporarily if it is on.  */
3989             SvFAKE_off(sstr);
3990             gv_efullname3(dstr, (GV *)sstr, "*");
3991             SvFLAGS(sstr) |= wasfake;
3992         }
3993         else
3994             (void)SvOK_off(dstr);
3995     }
3996     if (SvTAINTED(sstr))
3997         SvTAINT(dstr);
3998 }
3999
4000 /*
4001 =for apidoc sv_setsv_mg
4002
4003 Like C<sv_setsv>, but also handles 'set' magic.
4004
4005 =cut
4006 */
4007
4008 void
4009 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4010 {
4011     PERL_ARGS_ASSERT_SV_SETSV_MG;
4012
4013     sv_setsv(dstr,sstr);
4014     SvSETMAGIC(dstr);
4015 }
4016
4017 #ifdef PERL_OLD_COPY_ON_WRITE
4018 SV *
4019 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4020 {
4021     STRLEN cur = SvCUR(sstr);
4022     STRLEN len = SvLEN(sstr);
4023     register char *new_pv;
4024
4025     PERL_ARGS_ASSERT_SV_SETSV_COW;
4026
4027     if (DEBUG_C_TEST) {
4028         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4029                       (void*)sstr, (void*)dstr);
4030         sv_dump(sstr);
4031         if (dstr)
4032                     sv_dump(dstr);
4033     }
4034
4035     if (dstr) {
4036         if (SvTHINKFIRST(dstr))
4037             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4038         else if (SvPVX_const(dstr))
4039             Safefree(SvPVX_const(dstr));
4040     }
4041     else
4042         new_SV(dstr);
4043     SvUPGRADE(dstr, SVt_PVIV);
4044
4045     assert (SvPOK(sstr));
4046     assert (SvPOKp(sstr));
4047     assert (!SvIOK(sstr));
4048     assert (!SvIOKp(sstr));
4049     assert (!SvNOK(sstr));
4050     assert (!SvNOKp(sstr));
4051
4052     if (SvIsCOW(sstr)) {
4053
4054         if (SvLEN(sstr) == 0) {
4055             /* source is a COW shared hash key.  */
4056             DEBUG_C(PerlIO_printf(Perl_debug_log,
4057                                   "Fast copy on write: Sharing hash\n"));
4058             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4059             goto common_exit;
4060         }
4061         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4062     } else {
4063         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4064         SvUPGRADE(sstr, SVt_PVIV);
4065         SvREADONLY_on(sstr);
4066         SvFAKE_on(sstr);
4067         DEBUG_C(PerlIO_printf(Perl_debug_log,
4068                               "Fast copy on write: Converting sstr to COW\n"));
4069         SV_COW_NEXT_SV_SET(dstr, sstr);
4070     }
4071     SV_COW_NEXT_SV_SET(sstr, dstr);
4072     new_pv = SvPVX_mutable(sstr);
4073
4074   common_exit:
4075     SvPV_set(dstr, new_pv);
4076     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4077     if (SvUTF8(sstr))
4078         SvUTF8_on(dstr);
4079     SvLEN_set(dstr, len);
4080     SvCUR_set(dstr, cur);
4081     if (DEBUG_C_TEST) {
4082         sv_dump(dstr);
4083     }
4084     return dstr;
4085 }
4086 #endif
4087
4088 /*
4089 =for apidoc sv_setpvn
4090
4091 Copies a string into an SV.  The C<len> parameter indicates the number of
4092 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4093 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4094
4095 =cut
4096 */
4097
4098 void
4099 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4100 {
4101     dVAR;
4102     register char *dptr;
4103
4104     PERL_ARGS_ASSERT_SV_SETPVN;
4105
4106     SV_CHECK_THINKFIRST_COW_DROP(sv);
4107     if (!ptr) {
4108         (void)SvOK_off(sv);
4109         return;
4110     }
4111     else {
4112         /* len is STRLEN which is unsigned, need to copy to signed */
4113         const IV iv = len;
4114         if (iv < 0)
4115             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4116     }
4117     SvUPGRADE(sv, SVt_PV);
4118
4119     dptr = SvGROW(sv, len + 1);
4120     Move(ptr,dptr,len,char);
4121     dptr[len] = '\0';
4122     SvCUR_set(sv, len);
4123     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4124     SvTAINT(sv);
4125 }
4126
4127 /*
4128 =for apidoc sv_setpvn_mg
4129
4130 Like C<sv_setpvn>, but also handles 'set' magic.
4131
4132 =cut
4133 */
4134
4135 void
4136 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4137 {
4138     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4139
4140     sv_setpvn(sv,ptr,len);
4141     SvSETMAGIC(sv);
4142 }
4143
4144 /*
4145 =for apidoc sv_setpv
4146
4147 Copies a string into an SV.  The string must be null-terminated.  Does not
4148 handle 'set' magic.  See C<sv_setpv_mg>.
4149
4150 =cut
4151 */
4152
4153 void
4154 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4155 {
4156     dVAR;
4157     register STRLEN len;
4158
4159     PERL_ARGS_ASSERT_SV_SETPV;
4160
4161     SV_CHECK_THINKFIRST_COW_DROP(sv);
4162     if (!ptr) {
4163         (void)SvOK_off(sv);
4164         return;
4165     }
4166     len = strlen(ptr);
4167     SvUPGRADE(sv, SVt_PV);
4168
4169     SvGROW(sv, len + 1);
4170     Move(ptr,SvPVX(sv),len+1,char);
4171     SvCUR_set(sv, len);
4172     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4173     SvTAINT(sv);
4174 }
4175
4176 /*
4177 =for apidoc sv_setpv_mg
4178
4179 Like C<sv_setpv>, but also handles 'set' magic.
4180
4181 =cut
4182 */
4183
4184 void
4185 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4186 {
4187     PERL_ARGS_ASSERT_SV_SETPV_MG;
4188
4189     sv_setpv(sv,ptr);
4190     SvSETMAGIC(sv);
4191 }
4192
4193 /*
4194 =for apidoc sv_usepvn_flags
4195
4196 Tells an SV to use C<ptr> to find its string value.  Normally the
4197 string is stored inside the SV but sv_usepvn allows the SV to use an
4198 outside string.  The C<ptr> should point to memory that was allocated
4199 by C<malloc>.  The string length, C<len>, must be supplied.  By default
4200 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4201 so that pointer should not be freed or used by the programmer after
4202 giving it to sv_usepvn, and neither should any pointers from "behind"
4203 that pointer (e.g. ptr + 1) be used.
4204
4205 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4206 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4207 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4208 C<len>, and already meets the requirements for storing in C<SvPVX>)
4209
4210 =cut
4211 */
4212
4213 void
4214 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4215 {
4216     dVAR;
4217     STRLEN allocate;
4218
4219     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4220
4221     SV_CHECK_THINKFIRST_COW_DROP(sv);
4222     SvUPGRADE(sv, SVt_PV);
4223     if (!ptr) {
4224         (void)SvOK_off(sv);
4225         if (flags & SV_SMAGIC)
4226             SvSETMAGIC(sv);
4227         return;
4228     }
4229     if (SvPVX_const(sv))
4230         SvPV_free(sv);
4231
4232 #ifdef DEBUGGING
4233     if (flags & SV_HAS_TRAILING_NUL)
4234         assert(ptr[len] == '\0');
4235 #endif
4236
4237     allocate = (flags & SV_HAS_TRAILING_NUL)
4238         ? len + 1 :
4239 #ifdef Perl_safesysmalloc_size
4240         len + 1;
4241 #else
4242         PERL_STRLEN_ROUNDUP(len + 1);
4243 #endif
4244     if (flags & SV_HAS_TRAILING_NUL) {
4245         /* It's long enough - do nothing.
4246            Specfically Perl_newCONSTSUB is relying on this.  */
4247     } else {
4248 #ifdef DEBUGGING
4249         /* Force a move to shake out bugs in callers.  */
4250         char *new_ptr = (char*)safemalloc(allocate);
4251         Copy(ptr, new_ptr, len, char);
4252         PoisonFree(ptr,len,char);
4253         Safefree(ptr);
4254         ptr = new_ptr;
4255 #else
4256         ptr = (char*) saferealloc (ptr, allocate);
4257 #endif
4258     }
4259 #ifdef Perl_safesysmalloc_size
4260     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4261 #else
4262     SvLEN_set(sv, allocate);
4263 #endif
4264     SvCUR_set(sv, len);
4265     SvPV_set(sv, ptr);
4266     if (!(flags & SV_HAS_TRAILING_NUL)) {
4267         ptr[len] = '\0';
4268     }
4269     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4270     SvTAINT(sv);
4271     if (flags & SV_SMAGIC)
4272         SvSETMAGIC(sv);
4273 }
4274
4275 #ifdef PERL_OLD_COPY_ON_WRITE
4276 /* Need to do this *after* making the SV normal, as we need the buffer
4277    pointer to remain valid until after we've copied it.  If we let go too early,
4278    another thread could invalidate it by unsharing last of the same hash key
4279    (which it can do by means other than releasing copy-on-write Svs)
4280    or by changing the other copy-on-write SVs in the loop.  */
4281 STATIC void
4282 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4283 {
4284     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4285
4286     { /* this SV was SvIsCOW_normal(sv) */
4287          /* we need to find the SV pointing to us.  */
4288         SV *current = SV_COW_NEXT_SV(after);
4289
4290         if (current == sv) {
4291             /* The SV we point to points back to us (there were only two of us
4292                in the loop.)
4293                Hence other SV is no longer copy on write either.  */
4294             SvFAKE_off(after);
4295             SvREADONLY_off(after);
4296         } else {
4297             /* We need to follow the pointers around the loop.  */
4298             SV *next;
4299             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4300                 assert (next);
4301                 current = next;
4302                  /* don't loop forever if the structure is bust, and we have
4303                     a pointer into a closed loop.  */
4304                 assert (current != after);
4305                 assert (SvPVX_const(current) == pvx);
4306             }
4307             /* Make the SV before us point to the SV after us.  */
4308             SV_COW_NEXT_SV_SET(current, after);
4309         }
4310     }
4311 }
4312 #endif
4313 /*
4314 =for apidoc sv_force_normal_flags
4315
4316 Undo various types of fakery on an SV: if the PV is a shared string, make
4317 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4318 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4319 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4320 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4321 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4322 set to some other value.) In addition, the C<flags> parameter gets passed to
4323 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4324 with flags set to 0.
4325
4326 =cut
4327 */
4328
4329 void
4330 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4331 {
4332     dVAR;
4333
4334     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4335
4336 #ifdef PERL_OLD_COPY_ON_WRITE
4337     if (SvREADONLY(sv)) {
4338         /* At this point I believe I should acquire a global SV mutex.  */
4339         if (SvFAKE(sv)) {
4340             const char * const pvx = SvPVX_const(sv);
4341             const STRLEN len = SvLEN(sv);
4342             const STRLEN cur = SvCUR(sv);
4343             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4344                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4345                we'll fail an assertion.  */
4346             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4347
4348             if (DEBUG_C_TEST) {
4349                 PerlIO_printf(Perl_debug_log,
4350                               "Copy on write: Force normal %ld\n",
4351                               (long) flags);
4352                 sv_dump(sv);
4353             }
4354             SvFAKE_off(sv);
4355             SvREADONLY_off(sv);
4356             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4357             SvPV_set(sv, NULL);
4358             SvLEN_set(sv, 0);
4359             if (flags & SV_COW_DROP_PV) {
4360                 /* OK, so we don't need to copy our buffer.  */
4361                 SvPOK_off(sv);
4362             } else {
4363                 SvGROW(sv, cur + 1);
4364                 Move(pvx,SvPVX(sv),cur,char);
4365                 SvCUR_set(sv, cur);
4366                 *SvEND(sv) = '\0';
4367             }
4368             if (len) {
4369                 sv_release_COW(sv, pvx, next);
4370             } else {
4371                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4372             }
4373             if (DEBUG_C_TEST) {
4374                 sv_dump(sv);
4375             }
4376         }
4377         else if (IN_PERL_RUNTIME)
4378             Perl_croak(aTHX_ PL_no_modify);
4379         /* At this point I believe that I can drop the global SV mutex.  */
4380     }
4381 #else
4382     if (SvREADONLY(sv)) {
4383         if (SvFAKE(sv)) {
4384             const char * const pvx = SvPVX_const(sv);
4385             const STRLEN len = SvCUR(sv);
4386             SvFAKE_off(sv);
4387             SvREADONLY_off(sv);
4388             SvPV_set(sv, NULL);
4389             SvLEN_set(sv, 0);
4390             SvGROW(sv, len + 1);
4391             Move(pvx,SvPVX(sv),len,char);
4392             *SvEND(sv) = '\0';
4393             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4394         }
4395         else if (IN_PERL_RUNTIME)
4396             Perl_croak(aTHX_ PL_no_modify);
4397     }
4398 #endif
4399     if (SvROK(sv))
4400         sv_unref_flags(sv, flags);
4401     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4402         sv_unglob(sv);
4403 }
4404
4405 /*
4406 =for apidoc sv_chop
4407
4408 Efficient removal of characters from the beginning of the string buffer.
4409 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4410 the string buffer.  The C<ptr> becomes the first character of the adjusted
4411 string. Uses the "OOK hack".
4412 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4413 refer to the same chunk of data.
4414
4415 =cut
4416 */
4417
4418 void
4419 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4420 {
4421     STRLEN delta;
4422     STRLEN old_delta;
4423     U8 *p;
4424 #ifdef DEBUGGING
4425     const U8 *real_start;
4426 #endif
4427     STRLEN max_delta;
4428
4429     PERL_ARGS_ASSERT_SV_CHOP;
4430
4431     if (!ptr || !SvPOKp(sv))
4432         return;
4433     delta = ptr - SvPVX_const(sv);
4434     if (!delta) {
4435         /* Nothing to do.  */
4436         return;
4437     }
4438     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4439        nothing uses the value of ptr any more.  */
4440     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4441     if (ptr <= SvPVX_const(sv))
4442         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4443                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4444     SV_CHECK_THINKFIRST(sv);
4445     if (delta > max_delta)
4446         Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4447                    SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4448                    SvPVX_const(sv) + max_delta);
4449
4450     if (!SvOOK(sv)) {
4451         if (!SvLEN(sv)) { /* make copy of shared string */
4452             const char *pvx = SvPVX_const(sv);
4453             const STRLEN len = SvCUR(sv);
4454             SvGROW(sv, len + 1);
4455             Move(pvx,SvPVX(sv),len,char);
4456             *SvEND(sv) = '\0';
4457         }
4458         SvFLAGS(sv) |= SVf_OOK;
4459         old_delta = 0;
4460     } else {
4461         SvOOK_offset(sv, old_delta);
4462     }
4463     SvLEN_set(sv, SvLEN(sv) - delta);
4464     SvCUR_set(sv, SvCUR(sv) - delta);
4465     SvPV_set(sv, SvPVX(sv) + delta);
4466
4467     p = (U8 *)SvPVX_const(sv);
4468
4469     delta += old_delta;
4470
4471 #ifdef DEBUGGING
4472     real_start = p - delta;
4473 #endif
4474
4475     assert(delta);
4476     if (delta < 0x100) {
4477         *--p = (U8) delta;
4478     } else {
4479         *--p = 0;
4480         p -= sizeof(STRLEN);
4481         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4482     }
4483
4484 #ifdef DEBUGGING
4485     /* Fill the preceding buffer with sentinals to verify that no-one is
4486        using it.  */
4487     while (p > real_start) {
4488         --p;
4489         *p = (U8)PTR2UV(p);
4490     }
4491 #endif
4492 }
4493
4494 /*
4495 =for apidoc sv_catpvn
4496
4497 Concatenates the string onto the end of the string which is in the SV.  The
4498 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4499 status set, then the bytes appended should be valid UTF-8.
4500 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4501
4502 =for apidoc sv_catpvn_flags
4503
4504 Concatenates the string onto the end of the string which is in the SV.  The
4505 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4506 status set, then the bytes appended should be valid UTF-8.
4507 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4508 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4509 in terms of this function.
4510
4511 =cut
4512 */
4513
4514 void
4515 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4516 {
4517     dVAR;
4518     STRLEN dlen;
4519     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4520
4521     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4522
4523     SvGROW(dsv, dlen + slen + 1);
4524     if (sstr == dstr)
4525         sstr = SvPVX_const(dsv);
4526     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4527     SvCUR_set(dsv, SvCUR(dsv) + slen);
4528     *SvEND(dsv) = '\0';
4529     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4530     SvTAINT(dsv);
4531     if (flags & SV_SMAGIC)
4532         SvSETMAGIC(dsv);
4533 }
4534
4535 /*
4536 =for apidoc sv_catsv
4537
4538 Concatenates the string from SV C<ssv> onto the end of the string in
4539 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4540 not 'set' magic.  See C<sv_catsv_mg>.
4541
4542 =for apidoc sv_catsv_flags
4543
4544 Concatenates the string from SV C<ssv> onto the end of the string in
4545 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4546 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4547 and C<sv_catsv_nomg> are implemented in terms of this function.
4548
4549 =cut */
4550
4551 void
4552 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4553 {
4554     dVAR;
4555
4556     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4557
4558    if (ssv) {
4559         STRLEN slen;
4560         const char *spv = SvPV_const(ssv, slen);
4561         if (spv) {
4562             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4563                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4564                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4565                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4566                 dsv->sv_flags doesn't have that bit set.
4567                 Andy Dougherty  12 Oct 2001
4568             */
4569             const I32 sutf8 = DO_UTF8(ssv);
4570             I32 dutf8;
4571
4572             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4573                 mg_get(dsv);
4574             dutf8 = DO_UTF8(dsv);
4575
4576             if (dutf8 != sutf8) {
4577                 if (dutf8) {
4578                     /* Not modifying source SV, so taking a temporary copy. */
4579                     SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4580
4581                     sv_utf8_upgrade(csv);
4582                     spv = SvPV_const(csv, slen);
4583                 }
4584                 else
4585                     sv_utf8_upgrade_nomg(dsv);
4586             }
4587             sv_catpvn_nomg(dsv, spv, slen);
4588         }
4589     }
4590     if (flags & SV_SMAGIC)
4591         SvSETMAGIC(dsv);
4592 }
4593
4594 /*
4595 =for apidoc sv_catpv
4596
4597 Concatenates the string onto the end of the string which is in the SV.
4598 If the SV has the UTF-8 status set, then the bytes appended should be
4599 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4600
4601 =cut */
4602
4603 void
4604 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4605 {
4606     dVAR;
4607     register STRLEN len;
4608     STRLEN tlen;
4609     char *junk;
4610
4611     PERL_ARGS_ASSERT_SV_CATPV;
4612
4613     if (!ptr)
4614         return;
4615     junk = SvPV_force(sv, tlen);
4616     len = strlen(ptr);
4617     SvGROW(sv, tlen + len + 1);
4618     if (ptr == junk)
4619         ptr = SvPVX_const(sv);
4620     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4621     SvCUR_set(sv, SvCUR(sv) + len);
4622     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4623     SvTAINT(sv);
4624 }
4625
4626 /*
4627 =for apidoc sv_catpv_mg
4628
4629 Like C<sv_catpv>, but also handles 'set' magic.
4630
4631 =cut
4632 */
4633
4634 void
4635 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4636 {
4637     PERL_ARGS_ASSERT_SV_CATPV_MG;
4638
4639     sv_catpv(sv,ptr);
4640     SvSETMAGIC(sv);
4641 }
4642
4643 /*
4644 =for apidoc newSV
4645
4646 Creates a new SV.  A non-zero C<len> parameter indicates the number of
4647 bytes of preallocated string space the SV should have.  An extra byte for a
4648 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
4649 space is allocated.)  The reference count for the new SV is set to 1.
4650
4651 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4652 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4653 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4654 L<perlhack/PERL_MEM_LOG>).  The older API is still there for use in XS
4655 modules supporting older perls.
4656
4657 =cut
4658 */
4659
4660 SV *
4661 Perl_newSV(pTHX_ const STRLEN len)
4662 {
4663     dVAR;
4664     register SV *sv;
4665
4666     new_SV(sv);
4667     if (len) {
4668         sv_upgrade(sv, SVt_PV);
4669         SvGROW(sv, len + 1);
4670     }
4671     return sv;
4672 }
4673 /*
4674 =for apidoc sv_magicext
4675
4676 Adds magic to an SV, upgrading it if necessary. Applies the
4677 supplied vtable and returns a pointer to the magic added.
4678
4679 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4680 In particular, you can add magic to SvREADONLY SVs, and add more than
4681 one instance of the same 'how'.
4682
4683 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4684 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4685 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4686 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4687
4688 (This is now used as a subroutine by C<sv_magic>.)
4689
4690 =cut
4691 */
4692 MAGIC *
4693 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4694                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4695 {
4696     dVAR;
4697     MAGIC* mg;
4698
4699     PERL_ARGS_ASSERT_SV_MAGICEXT;
4700
4701     SvUPGRADE(sv, SVt_PVMG);
4702     Newxz(mg, 1, MAGIC);
4703     mg->mg_moremagic = SvMAGIC(sv);
4704     SvMAGIC_set(sv, mg);
4705
4706     /* Sometimes a magic contains a reference loop, where the sv and
4707        object refer to each other.  To prevent a reference loop that
4708        would prevent such objects being freed, we look for such loops
4709        and if we find one we avoid incrementing the object refcount.
4710
4711        Note we cannot do this to avoid self-tie loops as intervening RV must
4712        have its REFCNT incremented to keep it in existence.
4713
4714     */
4715     if (!obj || obj == sv ||
4716         how == PERL_MAGIC_arylen ||
4717         how == PERL_MAGIC_symtab ||
4718         (SvTYPE(obj) == SVt_PVGV &&
4719             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4720              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4721              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4722     {
4723         mg->mg_obj = obj;
4724     }
4725     else {
4726         mg->mg_obj = SvREFCNT_inc_simple(obj);
4727         mg->mg_flags |= MGf_REFCOUNTED;
4728     }
4729
4730     /* Normal self-ties simply pass a null object, and instead of
4731        using mg_obj directly, use the SvTIED_obj macro to produce a
4732        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4733        with an RV obj pointing to the glob containing the PVIO.  In
4734        this case, to avoid a reference loop, we need to weaken the
4735        reference.
4736     */
4737
4738     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4739         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4740     {
4741       sv_rvweaken(obj);
4742     }
4743
4744     mg->mg_type = how;
4745     mg->mg_len = namlen;
4746     if (name) {
4747         if (namlen > 0)
4748             mg->mg_ptr = savepvn(name, namlen);
4749         else if (namlen == HEf_SVKEY)
4750             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
4751         else
4752             mg->mg_ptr = (char *) name;
4753     }
4754     mg->mg_virtual = (MGVTBL *) vtable;
4755
4756     mg_magical(sv);
4757     if (SvGMAGICAL(sv))
4758         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4759     return mg;
4760 }
4761
4762 /*
4763 =for apidoc sv_magic
4764
4765 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4766 then adds a new magic item of type C<how> to the head of the magic list.
4767
4768 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4769 handling of the C<name> and C<namlen> arguments.
4770
4771 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4772 to add more than one instance of the same 'how'.
4773
4774 =cut
4775 */
4776
4777 void
4778 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
4779              const char *const name, const I32 namlen)
4780 {
4781     dVAR;
4782     const MGVTBL *vtable;
4783     MAGIC* mg;
4784
4785     PERL_ARGS_ASSERT_SV_MAGIC;
4786
4787 #ifdef PERL_OLD_COPY_ON_WRITE
4788     if (SvIsCOW(sv))
4789         sv_force_normal_flags(sv, 0);
4790 #endif
4791     if (SvREADONLY(sv)) {
4792         if (
4793             /* its okay to attach magic to shared strings; the subsequent
4794              * upgrade to PVMG will unshare the string */
4795             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4796
4797             && IN_PERL_RUNTIME
4798             && how != PERL_MAGIC_regex_global
4799             && how != PERL_MAGIC_bm
4800             && how != PERL_MAGIC_fm
4801             && how != PERL_MAGIC_sv
4802             && how != PERL_MAGIC_backref
4803            )
4804         {
4805             Perl_croak(aTHX_ PL_no_modify);
4806         }
4807     }
4808     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4809         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4810             /* sv_magic() refuses to add a magic of the same 'how' as an
4811                existing one
4812              */
4813             if (how == PERL_MAGIC_taint) {
4814                 mg->mg_len |= 1;
4815                 /* Any scalar which already had taint magic on which someone
4816                    (erroneously?) did SvIOK_on() or similar will now be
4817                    incorrectly sporting public "OK" flags.  */
4818                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4819             }
4820             return;
4821         }
4822     }
4823
4824     switch (how) {
4825     case PERL_MAGIC_sv:
4826         vtable = &PL_vtbl_sv;
4827         break;
4828     case PERL_MAGIC_overload:
4829         vtable = &PL_vtbl_amagic;
4830         break;
4831     case PERL_MAGIC_overload_elem:
4832         vtable = &PL_vtbl_amagicelem;
4833         break;
4834     case PERL_MAGIC_overload_table:
4835         vtable = &PL_vtbl_ovrld;
4836         break;
4837     case PERL_MAGIC_bm:
4838         vtable = &PL_vtbl_bm;
4839         break;
4840     case PERL_MAGIC_regdata:
4841         vtable = &PL_vtbl_regdata;
4842         break;
4843     case PERL_MAGIC_regdatum:
4844         vtable = &PL_vtbl_regdatum;
4845         break;
4846     case PERL_MAGIC_env:
4847         vtable = &PL_vtbl_env;
4848         break;
4849     case PERL_MAGIC_fm:
4850         vtable = &PL_vtbl_fm;
4851         break;
4852     case PERL_MAGIC_envelem:
4853         vtable = &PL_vtbl_envelem;
4854         break;
4855     case PERL_MAGIC_regex_global:
4856         vtable = &PL_vtbl_mglob;
4857         break;
4858     case PERL_MAGIC_isa:
4859         vtable = &PL_vtbl_isa;
4860         break;
4861     case PERL_MAGIC_isaelem:
4862         vtable = &PL_vtbl_isaelem;
4863         break;
4864     case PERL_MAGIC_nkeys:
4865         vtable = &PL_vtbl_nkeys;
4866         break;
4867     case PERL_MAGIC_dbfile:
4868         vtable = NULL;
4869         break;
4870     case PERL_MAGIC_dbline:
4871         vtable = &PL_vtbl_dbline;
4872         break;
4873 #ifdef USE_LOCALE_COLLATE
4874     case PERL_MAGIC_collxfrm:
4875         vtable = &PL_vtbl_collxfrm;
4876         break;
4877 #endif /* USE_LOCALE_COLLATE */
4878     case PERL_MAGIC_tied:
4879         vtable = &PL_vtbl_pack;
4880         break;
4881     case PERL_MAGIC_tiedelem:
4882     case PERL_MAGIC_tiedscalar:
4883         vtable = &PL_vtbl_packelem;
4884         break;
4885     case PERL_MAGIC_qr:
4886         vtable = &PL_vtbl_regexp;
4887         break;
4888     case PERL_MAGIC_hints:
4889         /* As this vtable is all NULL, we can reuse it.  */
4890     case PERL_MAGIC_sig:
4891         vtable = &PL_vtbl_sig;
4892         break;
4893     case PERL_MAGIC_sigelem:
4894         vtable = &PL_vtbl_sigelem;
4895         break;
4896     case PERL_MAGIC_taint:
4897         vtable = &PL_vtbl_taint;
4898         break;
4899     case PERL_MAGIC_uvar:
4900         vtable = &PL_vtbl_uvar;
4901         break;
4902     case PERL_MAGIC_vec:
4903         vtable = &PL_vtbl_vec;
4904         break;
4905     case PERL_MAGIC_arylen_p:
4906     case PERL_MAGIC_rhash:
4907     case PERL_MAGIC_symtab:
4908     case PERL_MAGIC_vstring:
4909         vtable = NULL;
4910         break;
4911     case PERL_MAGIC_utf8:
4912         vtable = &PL_vtbl_utf8;
4913         break;
4914     case PERL_MAGIC_substr:
4915         vtable = &PL_vtbl_substr;
4916         break;
4917     case PERL_MAGIC_defelem:
4918         vtable = &PL_vtbl_defelem;
4919         break;
4920     case PERL_MAGIC_arylen:
4921         vtable = &PL_vtbl_arylen;
4922         break;
4923     case PERL_MAGIC_pos:
4924         vtable = &PL_vtbl_pos;
4925         break;
4926     case PERL_MAGIC_backref:
4927         vtable = &PL_vtbl_backref;
4928         break;
4929     case PERL_MAGIC_hintselem:
4930         vtable = &PL_vtbl_hintselem;
4931         break;
4932     case PERL_MAGIC_ext:
4933         /* Reserved for use by extensions not perl internals.           */
4934         /* Useful for attaching extension internal data to perl vars.   */
4935         /* Note that multiple extensions may clash if magical scalars   */
4936         /* etc holding private data from one are passed to another.     */
4937         vtable = NULL;
4938         break;
4939     default:
4940         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4941     }
4942
4943     /* Rest of work is done else where */
4944     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4945
4946     switch (how) {
4947     case PERL_MAGIC_taint:
4948         mg->mg_len = 1;
4949         break;
4950     case PERL_MAGIC_ext:
4951     case PERL_MAGIC_dbfile:
4952         SvRMAGICAL_on(sv);
4953         break;
4954     }
4955 }
4956
4957 /*
4958 =for apidoc sv_unmagic
4959
4960 Removes all magic of type C<type> from an SV.
4961
4962 =cut
4963 */
4964
4965 int
4966 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
4967 {
4968     MAGIC* mg;
4969     MAGIC** mgp;
4970
4971     PERL_ARGS_ASSERT_SV_UNMAGIC;
4972
4973     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4974         return 0;
4975     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
4976     for (mg = *mgp; mg; mg = *mgp) {
4977         if (mg->mg_type == type) {
4978             const MGVTBL* const vtbl = mg->mg_virtual;
4979             *mgp = mg->mg_moremagic;
4980             if (vtbl && vtbl->svt_free)
4981                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4982             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4983                 if (mg->mg_len > 0)
4984                     Safefree(mg->mg_ptr);
4985                 else if (mg->mg_len == HEf_SVKEY)
4986                     SvREFCNT_dec((SV*)mg->mg_ptr);
4987                 else if (mg->mg_type == PERL_MAGIC_utf8)
4988                     Safefree(mg->mg_ptr);
4989             }
4990             if (mg->mg_flags & MGf_REFCOUNTED)
4991                 SvREFCNT_dec(mg->mg_obj);
4992             Safefree(mg);
4993         }
4994         else
4995             mgp = &mg->mg_moremagic;
4996     }
4997     if (!SvMAGIC(sv)) {
4998         SvMAGICAL_off(sv);
4999         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5000         SvMAGIC_set(sv, NULL);
5001     }
5002
5003     return 0;
5004 }
5005
5006 /*
5007 =for apidoc sv_rvweaken
5008
5009 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5010 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5011 push a back-reference to this RV onto the array of backreferences
5012 associated with that magic. If the RV is magical, set magic will be
5013 called after the RV is cleared.
5014
5015 =cut
5016 */
5017
5018 SV *
5019 Perl_sv_rvweaken(pTHX_ SV *const sv)
5020 {
5021     SV *tsv;
5022
5023     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5024
5025     if (!SvOK(sv))  /* let undefs pass */
5026         return sv;
5027     if (!SvROK(sv))
5028         Perl_croak(aTHX_ "Can't weaken a nonreference");
5029     else if (SvWEAKREF(sv)) {
5030         if (ckWARN(WARN_MISC))
5031             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5032         return sv;
5033     }
5034     tsv = SvRV(sv);
5035     Perl_sv_add_backref(aTHX_ tsv, sv);
5036     SvWEAKREF_on(sv);
5037     SvREFCNT_dec(tsv);
5038     return sv;
5039 }
5040
5041 /* Give tsv backref magic if it hasn't already got it, then push a
5042  * back-reference to sv onto the array associated with the backref magic.
5043  */
5044
5045 /* A discussion about the backreferences array and its refcount:
5046  *
5047  * The AV holding the backreferences is pointed to either as the mg_obj of
5048  * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5049  * structure, from the xhv_backreferences field. (A HV without hv_aux will
5050  * have the standard magic instead.) The array is created with a refcount
5051  * of 2. This means that if during global destruction the array gets
5052  * picked on first to have its refcount decremented by the random zapper,
5053  * it won't actually be freed, meaning it's still theere for when its
5054  * parent gets freed.
5055  * When the parent SV is freed, in the case of magic, the magic is freed,
5056  * Perl_magic_killbackrefs is called which decrements one refcount, then
5057  * mg_obj is freed which kills the second count.
5058  * In the vase of a HV being freed, one ref is removed by
5059  * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5060  * calls.
5061  */
5062
5063 void
5064 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5065 {
5066     dVAR;
5067     AV *av;
5068
5069     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5070
5071     if (SvTYPE(tsv) == SVt_PVHV) {
5072         AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5073
5074         av = *avp;
5075         if (!av) {
5076             /* There is no AV in the offical place - try a fixup.  */
5077             MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5078
5079             if (mg) {
5080                 /* Aha. They've got it stowed in magic.  Bring it back.  */
5081                 av = MUTABLE_AV(mg->mg_obj);
5082                 /* Stop mg_free decreasing the refernce count.  */
5083                 mg->mg_obj = NULL;
5084                 /* Stop mg_free even calling the destructor, given that
5085                    there's no AV to free up.  */
5086                 mg->mg_virtual = 0;
5087                 sv_unmagic(tsv, PERL_MAGIC_backref);
5088             } else {
5089                 av = newAV();
5090                 AvREAL_off(av);
5091                 SvREFCNT_inc_simple_void(av); /* see discussion above */
5092             }
5093             *avp = av;
5094         }
5095     } else {
5096         const MAGIC *const mg
5097             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5098         if (mg)
5099             av = MUTABLE_AV(mg->mg_obj);
5100         else {
5101             av = newAV();
5102             AvREAL_off(av);
5103             sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5104             /* av now has a refcnt of 2; see discussion above */
5105         }
5106     }
5107     if (AvFILLp(av) >= AvMAX(av)) {
5108         av_extend(av, AvFILLp(av)+1);
5109     }
5110     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5111 }
5112
5113 /* delete a back-reference to ourselves from the backref magic associated
5114  * with the SV we point to.
5115  */
5116
5117 STATIC void
5118 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5119 {
5120     dVAR;
5121     AV *av = NULL;
5122     SV **svp;
5123     I32 i;
5124
5125     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5126
5127     if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5128         av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5129         /* We mustn't attempt to "fix up" the hash here by moving the
5130            backreference array back to the hv_aux structure, as that is stored
5131            in the main HvARRAY(), and hfreentries assumes that no-one
5132            reallocates HvARRAY() while it is running.  */
5133     }
5134     if (!av) {
5135         const MAGIC *const mg
5136             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5137         if (mg)
5138             av = MUTABLE_AV(mg->mg_obj);
5139     }
5140
5141     if (!av)
5142         Perl_croak(aTHX_ "panic: del_backref");
5143
5144     assert(!SvIS_FREED(av));
5145
5146     svp = AvARRAY(av);
5147     /* We shouldn't be in here more than once, but for paranoia reasons lets
5148        not assume this.  */
5149     for (i = AvFILLp(av); i >= 0; i--) {
5150         if (svp[i] == sv) {
5151             const SSize_t fill = AvFILLp(av);
5152             if (i != fill) {
5153                 /* We weren't the last entry.
5154                    An unordered list has this property that you can take the
5155                    last element off the end to fill the hole, and it's still
5156                    an unordered list :-)
5157                 */
5158                 svp[i] = svp[fill];
5159             }
5160             svp[fill] = NULL;
5161             AvFILLp(av) = fill - 1;
5162         }
5163     }
5164 }
5165
5166 int
5167 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5168 {
5169     SV **svp = AvARRAY(av);
5170
5171     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5172     PERL_UNUSED_ARG(sv);
5173
5174     assert(!svp || !SvIS_FREED(av));
5175     if (svp) {
5176         SV *const *const last = svp + AvFILLp(av);
5177
5178         while (svp <= last) {
5179             if (*svp) {
5180                 SV *const referrer = *svp;
5181                 if (SvWEAKREF(referrer)) {
5182                     /* XXX Should we check that it hasn't changed? */
5183                     SvRV_set(referrer, 0);
5184                     SvOK_off(referrer);
5185                     SvWEAKREF_off(referrer);
5186                     SvSETMAGIC(referrer);
5187                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5188                            SvTYPE(referrer) == SVt_PVLV) {
5189                     /* You lookin' at me?  */
5190                     assert(GvSTASH(referrer));
5191                     assert(GvSTASH(referrer) == (const HV *)sv);
5192                     GvSTASH(referrer) = 0;
5193                 } else {
5194                     Perl_croak(aTHX_
5195                                "panic: magic_killbackrefs (flags=%"UVxf")",
5196                                (UV)SvFLAGS(referrer));
5197                 }
5198
5199                 *svp = NULL;
5200             }
5201             svp++;
5202         }
5203     }
5204     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5205     return 0;
5206 }
5207
5208 /*
5209 =for apidoc sv_insert
5210
5211 Inserts a string at the specified offset/length within the SV. Similar to
5212 the Perl substr() function. Handles get magic.
5213
5214 =for apidoc sv_insert_flags
5215
5216 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5217
5218 =cut
5219 */
5220
5221 void
5222 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5223 {
5224     dVAR;
5225     register char *big;
5226     register char *mid;
5227     register char *midend;
5228     register char *bigend;
5229     register I32 i;
5230     STRLEN curlen;
5231
5232     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5233
5234     if (!bigstr)
5235         Perl_croak(aTHX_ "Can't modify non-existent substring");
5236     SvPV_force_flags(bigstr, curlen, flags);
5237     (void)SvPOK_only_UTF8(bigstr);
5238     if (offset + len > curlen) {
5239         SvGROW(bigstr, offset+len+1);
5240         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5241         SvCUR_set(bigstr, offset+len);
5242     }
5243
5244     SvTAINT(bigstr);
5245     i = littlelen - len;
5246     if (i > 0) {                        /* string might grow */
5247         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5248         mid = big + offset + len;
5249         midend = bigend = big + SvCUR(bigstr);
5250         bigend += i;
5251         *bigend = '\0';
5252         while (midend > mid)            /* shove everything down */
5253             *--bigend = *--midend;
5254         Move(little,big+offset,littlelen,char);
5255         SvCUR_set(bigstr, SvCUR(bigstr) + i);
5256         SvSETMAGIC(bigstr);
5257         return;
5258     }
5259     else if (i == 0) {
5260         Move(little,SvPVX(bigstr)+offset,len,char);
5261         SvSETMAGIC(bigstr);
5262         return;
5263     }
5264
5265     big = SvPVX(bigstr);
5266     mid = big + offset;
5267     midend = mid + len;
5268     bigend = big + SvCUR(bigstr);
5269
5270     if (midend > bigend)
5271         Perl_croak(aTHX_ "panic: sv_insert");
5272
5273     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5274         if (littlelen) {
5275             Move(little, mid, littlelen,char);
5276             mid += littlelen;
5277         }
5278         i = bigend - midend;
5279         if (i > 0) {
5280             Move(midend, mid, i,char);
5281             mid += i;
5282         }
5283         *mid = '\0';
5284         SvCUR_set(bigstr, mid - big);
5285     }
5286     else if ((i = mid - big)) { /* faster from front */
5287         midend -= littlelen;
5288         mid = midend;
5289         Move(big, midend - i, i, char);
5290         sv_chop(bigstr,midend-i);
5291         if (littlelen)
5292             Move(little, mid, littlelen,char);
5293     }
5294     else if (littlelen) {
5295         midend -= littlelen;
5296         sv_chop(bigstr,midend);
5297         Move(little,midend,littlelen,char);
5298     }
5299     else {
5300         sv_chop(bigstr,midend);
5301     }
5302     SvSETMAGIC(bigstr);
5303 }
5304
5305 /*
5306 =for apidoc sv_replace
5307
5308 Make the first argument a copy of the second, then delete the original.
5309 The target SV physically takes over ownership of the body of the source SV
5310 and inherits its flags; however, the target keeps any magic it owns,
5311 and any magic in the source is discarded.
5312 Note that this is a rather specialist SV copying operation; most of the
5313 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5314
5315 =cut
5316 */
5317
5318 void
5319 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5320 {
5321     dVAR;
5322     const U32 refcnt = SvREFCNT(sv);
5323
5324     PERL_ARGS_ASSERT_SV_REPLACE;
5325
5326     SV_CHECK_THINKFIRST_COW_DROP(sv);
5327     if (SvREFCNT(nsv) != 1) {
5328         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5329                    UVuf " != 1)", (UV) SvREFCNT(nsv));
5330     }
5331     if (SvMAGICAL(sv)) {
5332         if (SvMAGICAL(nsv))
5333             mg_free(nsv);
5334         else
5335             sv_upgrade(nsv, SVt_PVMG);
5336         SvMAGIC_set(nsv, SvMAGIC(sv));
5337         SvFLAGS(nsv) |= SvMAGICAL(sv);
5338         SvMAGICAL_off(sv);
5339         SvMAGIC_set(sv, NULL);
5340     }
5341     SvREFCNT(sv) = 0;
5342     sv_clear(sv);
5343     assert(!SvREFCNT(sv));
5344 #ifdef DEBUG_LEAKING_SCALARS
5345     sv->sv_flags  = nsv->sv_flags;
5346     sv->sv_any    = nsv->sv_any;
5347     sv->sv_refcnt = nsv->sv_refcnt;
5348     sv->sv_u      = nsv->sv_u;
5349 #else
5350     StructCopy(nsv,sv,SV);
5351 #endif
5352     if(SvTYPE(sv) == SVt_IV) {
5353         SvANY(sv)
5354             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5355     }
5356
5357
5358 #ifdef PERL_OLD_COPY_ON_WRITE
5359     if (SvIsCOW_normal(nsv)) {
5360         /* We need to follow the pointers around the loop to make the
5361            previous SV point to sv, rather than nsv.  */
5362         SV *next;
5363         SV *current = nsv;
5364         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5365             assert(next);
5366             current = next;
5367             assert(SvPVX_const(current) == SvPVX_const(nsv));
5368         }
5369         /* Make the SV before us point to the SV after us.  */
5370         if (DEBUG_C_TEST) {
5371             PerlIO_printf(Perl_debug_log, "previous is\n");
5372             sv_dump(current);
5373             PerlIO_printf(Perl_debug_log,
5374                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5375                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5376         }
5377         SV_COW_NEXT_SV_SET(current, sv);
5378     }
5379 #endif
5380     SvREFCNT(sv) = refcnt;
5381     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5382     SvREFCNT(nsv) = 0;
5383     del_SV(nsv);
5384 }
5385
5386 /*
5387 =for apidoc sv_clear
5388
5389 Clear an SV: call any destructors, free up any memory used by the body,
5390 and free the body itself. The SV's head is I<not> freed, although
5391 its type is set to all 1's so that it won't inadvertently be assumed
5392 to be live during global destruction etc.
5393 This function should only be called when REFCNT is zero. Most of the time
5394 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5395 instead.
5396
5397 =cut
5398 */
5399
5400 void
5401 Perl_sv_clear(pTHX_ register SV *const sv)
5402 {
5403     dVAR;
5404     const U32 type = SvTYPE(sv);
5405     const struct body_details *const sv_type_details
5406         = bodies_by_type + type;
5407     HV *stash;
5408
5409     PERL_ARGS_ASSERT_SV_CLEAR;
5410     assert(SvREFCNT(sv) == 0);
5411     assert(SvTYPE(sv) != SVTYPEMASK);
5412
5413     if (type <= SVt_IV) {
5414         /* See the comment in sv.h about the collusion between this early
5415            return and the overloading of the NULL and IV slots in the size
5416            table.  */
5417         if (SvROK(sv)) {
5418             SV * const target = SvRV(sv);
5419             if (SvWEAKREF(sv))
5420                 sv_del_backref(target, sv);
5421             else
5422                 SvREFCNT_dec(target);
5423         }
5424         SvFLAGS(sv) &= SVf_BREAK;
5425         SvFLAGS(sv) |= SVTYPEMASK;
5426         return;
5427     }
5428
5429     if (SvOBJECT(sv)) {
5430         if (PL_defstash &&      /* Still have a symbol table? */
5431             SvDESTROYABLE(sv))
5432         {
5433             dSP;
5434             HV* stash;
5435             do {
5436                 CV* destructor;
5437                 stash = SvSTASH(sv);
5438                 destructor = StashHANDLER(stash,DESTROY);
5439                 if (destructor) {
5440                     SV* const tmpref = newRV(sv);
5441                     SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
5442                     ENTER;
5443                     PUSHSTACKi(PERLSI_DESTROY);
5444                     EXTEND(SP, 2);
5445                     PUSHMARK(SP);
5446                     PUSHs(tmpref);
5447                     PUTBACK;
5448                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5449
5450
5451                     POPSTACK;
5452                     SPAGAIN;
5453                     LEAVE;
5454                     if(SvREFCNT(tmpref) < 2) {
5455                         /* tmpref is not kept alive! */
5456                         SvREFCNT(sv)--;
5457                         SvRV_set(tmpref, NULL);
5458                         SvROK_off(tmpref);
5459                     }
5460                     SvREFCNT_dec(tmpref);
5461                 }
5462             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5463
5464
5465             if (SvREFCNT(sv)) {
5466                 if (PL_in_clean_objs)
5467                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5468                           HvNAME_get(stash));
5469                 /* DESTROY gave object new lease on life */
5470                 return;
5471             }
5472         }
5473
5474         if (SvOBJECT(sv)) {
5475             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
5476             SvOBJECT_off(sv);   /* Curse the object. */
5477             if (type != SVt_PVIO)
5478                 --PL_sv_objcount;       /* XXX Might want something more general */
5479         }
5480     }
5481     if (type >= SVt_PVMG) {
5482         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5483             SvREFCNT_dec(SvOURSTASH(sv));
5484         } else if (SvMAGIC(sv))
5485             mg_free(sv);
5486         if (type == SVt_PVMG && SvPAD_TYPED(sv))
5487             SvREFCNT_dec(SvSTASH(sv));
5488     }
5489     switch (type) {
5490         /* case SVt_BIND: */
5491     case SVt_PVIO:
5492         if (IoIFP(sv) &&
5493             IoIFP(sv) != PerlIO_stdin() &&
5494             IoIFP(sv) != PerlIO_stdout() &&
5495             IoIFP(sv) != PerlIO_stderr())
5496         {
5497             io_close((IO*)sv, FALSE);
5498         }
5499         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5500             PerlDir_close(IoDIRP(sv));
5501         IoDIRP(sv) = (DIR*)NULL;
5502         Safefree(IoTOP_NAME(sv));
5503         Safefree(IoFMT_NAME(sv));
5504         Safefree(IoBOTTOM_NAME(sv));
5505         goto freescalar;
5506     case SVt_REGEXP:
5507         /* FIXME for plugins */
5508         pregfree2((REGEXP*) sv);
5509         goto freescalar;
5510     case SVt_PVCV:
5511     case SVt_PVFM:
5512         cv_undef(MUTABLE_CV(sv));
5513         goto freescalar;
5514     case SVt_PVHV:
5515         if (PL_last_swash_hv == (const HV *)sv) {
5516             PL_last_swash_hv = NULL;
5517         }
5518         Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5519         hv_undef(MUTABLE_HV(sv));
5520         break;
5521     case SVt_PVAV:
5522         if (PL_comppad == MUTABLE_AV(sv)) {
5523             PL_comppad = NULL;
5524             PL_curpad = NULL;
5525         }
5526         av_undef(MUTABLE_AV(sv));
5527         break;
5528     case SVt_PVLV:
5529         if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5530             SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5531             HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5532             PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5533         }
5534         else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
5535             SvREFCNT_dec(LvTARG(sv));
5536     case SVt_PVGV:
5537         if (isGV_with_GP(sv)) {
5538             if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
5539                 mro_method_changed_in(stash);
5540             gp_free((GV*)sv);
5541             if (GvNAME_HEK(sv))
5542                 unshare_hek(GvNAME_HEK(sv));
5543             /* If we're in a stash, we don't own a reference to it. However it does
5544                have a back reference to us, which needs to be cleared.  */
5545             if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5546                     sv_del_backref((SV*)stash, sv);
5547         }
5548         /* FIXME. There are probably more unreferenced pointers to SVs in the
5549            interpreter struct that we should check and tidy in a similar
5550            fashion to this:  */
5551         if ((GV*)sv == PL_last_in_gv)
5552             PL_last_in_gv = NULL;
5553     case SVt_PVMG:
5554     case SVt_PVNV:
5555     case SVt_PVIV:
5556     case SVt_PV:
5557       freescalar:
5558         /* Don't bother with SvOOK_off(sv); as we're only going to free it.  */
5559         if (SvOOK(sv)) {
5560             STRLEN offset;
5561             SvOOK_offset(sv, offset);
5562             SvPV_set(sv, SvPVX_mutable(sv) - offset);
5563             /* Don't even bother with turning off the OOK flag.  */
5564         }
5565         if (SvROK(sv)) {
5566             SV * const target = SvRV(sv);
5567             if (SvWEAKREF(sv))
5568                 sv_del_backref(target, sv);
5569             else
5570                 SvREFCNT_dec(target);
5571         }
5572 #ifdef PERL_OLD_COPY_ON_WRITE
5573         else if (SvPVX_const(sv)) {
5574             if (SvIsCOW(sv)) {
5575                 /* I believe I need to grab the global SV mutex here and
5576                    then recheck the COW status.  */
5577                 if (DEBUG_C_TEST) {
5578                     PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5579                     sv_dump(sv);
5580                 }
5581                 if (SvLEN(sv)) {
5582                     sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5583                 } else {
5584                     unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5585                 }
5586
5587                 /* And drop it here.  */
5588                 SvFAKE_off(sv);
5589             } else if (SvLEN(sv)) {
5590                 Safefree(SvPVX_const(sv));
5591             }
5592         }
5593 #else
5594         else if (SvPVX_const(sv) && SvLEN(sv))
5595             Safefree(SvPVX_mutable(sv));
5596         else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5597             unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5598             SvFAKE_off(sv);
5599         }
5600 #endif
5601         break;
5602     case SVt_NV:
5603         break;
5604     }
5605
5606     SvFLAGS(sv) &= SVf_BREAK;
5607     SvFLAGS(sv) |= SVTYPEMASK;
5608
5609     if (sv_type_details->arena) {
5610         del_body(((char *)SvANY(sv) + sv_type_details->offset),
5611                  &PL_body_roots[type]);
5612     }
5613     else if (sv_type_details->body_size) {
5614         my_safefree(SvANY(sv));
5615     }
5616 }
5617
5618 /*
5619 =for apidoc sv_newref
5620
5621 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5622 instead.
5623
5624 =cut
5625 */
5626
5627 SV *
5628 Perl_sv_newref(pTHX_ SV *const sv)
5629 {
5630     PERL_UNUSED_CONTEXT;
5631     if (sv)
5632         (SvREFCNT(sv))++;
5633     return sv;
5634 }
5635
5636 /*
5637 =for apidoc sv_free
5638
5639 Decrement an SV's reference count, and if it drops to zero, call
5640 C<sv_clear> to invoke destructors and free up any memory used by
5641 the body; finally, deallocate the SV's head itself.
5642 Normally called via a wrapper macro C<SvREFCNT_dec>.
5643
5644 =cut
5645 */
5646
5647 void
5648 Perl_sv_free(pTHX_ SV *const sv)
5649 {
5650     dVAR;
5651     if (!sv)
5652         return;
5653     if (SvREFCNT(sv) == 0) {
5654         if (SvFLAGS(sv) & SVf_BREAK)
5655             /* this SV's refcnt has been artificially decremented to
5656              * trigger cleanup */
5657             return;
5658         if (PL_in_clean_all) /* All is fair */
5659             return;
5660         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5661             /* make sure SvREFCNT(sv)==0 happens very seldom */
5662             SvREFCNT(sv) = (~(U32)0)/2;
5663             return;
5664         }
5665         if (ckWARN_d(WARN_INTERNAL)) {
5666 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5667             Perl_dump_sv_child(aTHX_ sv);
5668 #else
5669   #ifdef DEBUG_LEAKING_SCALARS
5670             sv_dump(sv);
5671   #endif
5672 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5673             if (PL_warnhook == PERL_WARNHOOK_FATAL
5674                 || ckDEAD(packWARN(WARN_INTERNAL))) {
5675                 /* Don't let Perl_warner cause us to escape our fate:  */
5676                 abort();
5677             }
5678 #endif
5679             /* This may not return:  */
5680             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5681                         "Attempt to free unreferenced scalar: SV 0x%"UVxf
5682                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5683 #endif
5684         }
5685 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5686         abort();
5687 #endif
5688         return;
5689     }
5690     if (--(SvREFCNT(sv)) > 0)
5691         return;
5692     Perl_sv_free2(aTHX_ sv);
5693 }
5694
5695 void
5696 Perl_sv_free2(pTHX_ SV *const sv)
5697 {
5698     dVAR;
5699
5700     PERL_ARGS_ASSERT_SV_FREE2;
5701
5702 #ifdef DEBUGGING
5703     if (SvTEMP(sv)) {
5704         if (ckWARN_d(WARN_DEBUGGING))
5705             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5706                         "Attempt to free temp prematurely: SV 0x%"UVxf
5707                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5708         return;
5709     }
5710 #endif
5711     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5712         /* make sure SvREFCNT(sv)==0 happens very seldom */
5713         SvREFCNT(sv) = (~(U32)0)/2;
5714         return;
5715     }
5716     sv_clear(sv);
5717     if (! SvREFCNT(sv))
5718         del_SV(sv);
5719 }
5720
5721 /*
5722 =for apidoc sv_len
5723
5724 Returns the length of the string in the SV. Handles magic and type
5725 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5726
5727 =cut
5728 */
5729
5730 STRLEN
5731 Perl_sv_len(pTHX_ register SV *const sv)
5732 {
5733     STRLEN len;
5734
5735     if (!sv)
5736         return 0;
5737
5738     if (SvGMAGICAL(sv))
5739         len = mg_length(sv);
5740     else
5741         (void)SvPV_const(sv, len);
5742     return len;
5743 }
5744
5745 /*
5746 =for apidoc sv_len_utf8
5747
5748 Returns the number of characters in the string in an SV, counting wide
5749 UTF-8 bytes as a single character. Handles magic and type coercion.
5750
5751 =cut
5752 */
5753
5754 /*
5755  * The length is cached in PERL_UTF8_magic, in the mg_len field.  Also the
5756  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
5757  * (Note that the mg_len is not the length of the mg_ptr field.
5758  * This allows the cache to store the character length of the string without
5759  * needing to malloc() extra storage to attach to the mg_ptr.)
5760  *
5761  */
5762
5763 STRLEN
5764 Perl_sv_len_utf8(pTHX_ register SV *const sv)
5765 {
5766     if (!sv)
5767         return 0;
5768
5769     if (SvGMAGICAL(sv))
5770         return mg_length(sv);
5771     else
5772     {
5773         STRLEN len;
5774         const U8 *s = (U8*)SvPV_const(sv, len);
5775
5776         if (PL_utf8cache) {
5777             STRLEN ulen;
5778             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
5779
5780             if (mg && mg->mg_len != -1) {
5781                 ulen = mg->mg_len;
5782                 if (PL_utf8cache < 0) {
5783                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
5784                     if (real != ulen) {
5785                         /* Need to turn the assertions off otherwise we may
5786                            recurse infinitely while printing error messages.
5787                         */
5788                         SAVEI8(PL_utf8cache);
5789                         PL_utf8cache = 0;
5790                         Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
5791                                    " real %"UVuf" for %"SVf,
5792                                    (UV) ulen, (UV) real, SVfARG(sv));
5793                     }
5794                 }
5795             }
5796             else {
5797                 ulen = Perl_utf8_length(aTHX_ s, s + len);
5798                 if (!SvREADONLY(sv)) {
5799                     if (!mg) {
5800                         mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
5801                                          &PL_vtbl_utf8, 0, 0);
5802                     }
5803                     assert(mg);
5804                     mg->mg_len = ulen;
5805                 }
5806             }
5807             return ulen;
5808         }
5809         return Perl_utf8_length(aTHX_ s, s + len);
5810     }
5811 }
5812
5813 /* Walk forwards to find the byte corresponding to the passed in UTF-8
5814    offset.  */
5815 static STRLEN
5816 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
5817                       STRLEN uoffset)
5818 {
5819     const U8 *s = start;
5820
5821     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
5822
5823     while (s < send && uoffset--)
5824         s += UTF8SKIP(s);
5825     if (s > send) {
5826         /* This is the existing behaviour. Possibly it should be a croak, as
5827            it's actually a bounds error  */
5828         s = send;
5829     }
5830     return s - start;
5831 }
5832
5833 /* Given the length of the string in both bytes and UTF-8 characters, decide
5834    whether to walk forwards or backwards to find the byte corresponding to
5835    the passed in UTF-8 offset.  */
5836 static STRLEN
5837 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
5838                       const STRLEN uoffset, const STRLEN uend)
5839 {
5840     STRLEN backw = uend - uoffset;
5841
5842     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
5843
5844     if (uoffset < 2 * backw) {
5845         /* The assumption is that going forwards is twice the speed of going
5846            forward (that's where the 2 * backw comes from).
5847            (The real figure of course depends on the UTF-8 data.)  */
5848         return sv_pos_u2b_forwards(start, send, uoffset);
5849     }
5850
5851     while (backw--) {
5852         send--;
5853         while (UTF8_IS_CONTINUATION(*send))
5854             send--;
5855     }
5856     return send - start;
5857 }
5858
5859 /* For the string representation of the given scalar, find the byte
5860    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
5861    give another position in the string, *before* the sought offset, which
5862    (which is always true, as 0, 0 is a valid pair of positions), which should
5863    help reduce the amount of linear searching.
5864    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
5865    will be used to reduce the amount of linear searching. The cache will be
5866    created if necessary, and the found value offered to it for update.  */
5867 static STRLEN
5868 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
5869                     const U8 *const send, const STRLEN uoffset,
5870                     STRLEN uoffset0, STRLEN boffset0)
5871 {
5872     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
5873     bool found = FALSE;
5874
5875     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
5876
5877     assert (uoffset >= uoffset0);
5878
5879     if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
5880         && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
5881         if ((*mgp)->mg_ptr) {
5882             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
5883             if (cache[0] == uoffset) {
5884                 /* An exact match. */
5885                 return cache[1];
5886             }
5887             if (cache[2] == uoffset) {
5888                 /* An exact match. */
5889                 return cache[3];
5890             }
5891
5892             if (cache[0] < uoffset) {
5893                 /* The cache already knows part of the way.   */
5894                 if (cache[0] > uoffset0) {
5895                     /* The cache knows more than the passed in pair  */
5896                     uoffset0 = cache[0];
5897                     boffset0 = cache[1];
5898                 }
5899                 if ((*mgp)->mg_len != -1) {
5900                     /* And we know the end too.  */
5901                     boffset = boffset0
5902                         + sv_pos_u2b_midway(start + boffset0, send,
5903                                               uoffset - uoffset0,
5904                                               (*mgp)->mg_len - uoffset0);
5905                 } else {
5906                     boffset = boffset0
5907                         + sv_pos_u2b_forwards(start + boffset0,
5908                                                 send, uoffset - uoffset0);
5909                 }
5910             }
5911             else if (cache[2] < uoffset) {
5912                 /* We're between the two cache entries.  */
5913                 if (cache[2] > uoffset0) {
5914                     /* and the cache knows more than the passed in pair  */
5915                     uoffset0 = cache[2];
5916                     boffset0 = cache[3];
5917                 }
5918
5919                 boffset = boffset0
5920                     + sv_pos_u2b_midway(start + boffset0,
5921                                           start + cache[1],
5922                                           uoffset - uoffset0,
5923                                           cache[0] - uoffset0);
5924             } else {
5925                 boffset = boffset0
5926                     + sv_pos_u2b_midway(start + boffset0,
5927                                           start + cache[3],
5928                                           uoffset - uoffset0,
5929                                           cache[2] - uoffset0);
5930             }
5931             found = TRUE;
5932         }
5933         else if ((*mgp)->mg_len != -1) {
5934             /* If we can take advantage of a passed in offset, do so.  */
5935             /* In fact, offset0 is either 0, or less than offset, so don't
5936                need to worry about the other possibility.  */
5937             boffset = boffset0
5938                 + sv_pos_u2b_midway(start + boffset0, send,
5939                                       uoffset - uoffset0,
5940                                       (*mgp)->mg_len - uoffset0);
5941             found = TRUE;
5942         }
5943     }
5944
5945     if (!found || PL_utf8cache < 0) {
5946         const STRLEN real_boffset
5947             = boffset0 + sv_pos_u2b_forwards(start + boffset0,
5948                                                send, uoffset - uoffset0);
5949
5950         if (found && PL_utf8cache < 0) {
5951             if (real_boffset != boffset) {
5952                 /* Need to turn the assertions off otherwise we may recurse
5953                    infinitely while printing error messages.  */
5954                 SAVEI8(PL_utf8cache);
5955                 PL_utf8cache = 0;
5956                 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
5957                            " real %"UVuf" for %"SVf,
5958                            (UV) boffset, (UV) real_boffset, SVfARG(sv));
5959             }
5960         }
5961         boffset = real_boffset;
5962     }
5963
5964     if (PL_utf8cache)
5965         utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
5966     return boffset;
5967 }
5968
5969
5970 /*
5971 =for apidoc sv_pos_u2b
5972
5973 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5974 the start of the string, to a count of the equivalent number of bytes; if
5975 lenp is non-zero, it does the same to lenp, but this time starting from
5976 the offset, rather than from the start of the string. Handles magic and
5977 type coercion.
5978
5979 =cut
5980 */
5981
5982 /*
5983  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5984  * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5985  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
5986  *
5987  */
5988
5989 void
5990 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
5991 {
5992     const U8 *start;
5993     STRLEN len;
5994
5995     PERL_ARGS_ASSERT_SV_POS_U2B;
5996
5997     if (!sv)
5998         return;
5999
6000     start = (U8*)SvPV_const(sv, len);
6001     if (len) {
6002         STRLEN uoffset = (STRLEN) *offsetp;
6003         const U8 * const send = start + len;
6004         MAGIC *mg = NULL;
6005         const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
6006                                              uoffset, 0, 0);
6007
6008         *offsetp = (I32) boffset;
6009
6010         if (lenp) {
6011             /* Convert the relative offset to absolute.  */
6012             const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
6013             const STRLEN boffset2
6014                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6015                                       uoffset, boffset) - boffset;
6016
6017             *lenp = boffset2;
6018         }
6019     }
6020     else {
6021          *offsetp = 0;
6022          if (lenp)
6023               *lenp = 0;
6024     }
6025
6026     return;
6027 }
6028
6029 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6030    byte length pairing. The (byte) length of the total SV is passed in too,
6031    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6032    may not have updated SvCUR, so we can't rely on reading it directly.
6033
6034    The proffered utf8/byte length pairing isn't used if the cache already has
6035    two pairs, and swapping either for the proffered pair would increase the
6036    RMS of the intervals between known byte offsets.
6037
6038    The cache itself consists of 4 STRLEN values
6039    0: larger UTF-8 offset
6040    1: corresponding byte offset
6041    2: smaller UTF-8 offset
6042    3: corresponding byte offset
6043
6044    Unused cache pairs have the value 0, 0.
6045    Keeping the cache "backwards" means that the invariant of
6046    cache[0] >= cache[2] is maintained even with empty slots, which means that
6047    the code that uses it doesn't need to worry if only 1 entry has actually
6048    been set to non-zero.  It also makes the "position beyond the end of the
6049    cache" logic much simpler, as the first slot is always the one to start
6050    from.
6051 */
6052 static void
6053 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6054                            const STRLEN utf8, const STRLEN blen)
6055 {
6056     STRLEN *cache;
6057
6058     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6059
6060     if (SvREADONLY(sv))
6061         return;
6062
6063     if (!*mgp) {
6064         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6065                            0);
6066         (*mgp)->mg_len = -1;
6067     }
6068     assert(*mgp);
6069
6070     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6071         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6072         (*mgp)->mg_ptr = (char *) cache;
6073     }
6074     assert(cache);
6075
6076     if (PL_utf8cache < 0) {
6077         const U8 *start = (const U8 *) SvPVX_const(sv);
6078         const STRLEN realutf8 = utf8_length(start, start + byte);
6079
6080         if (realutf8 != utf8) {
6081             /* Need to turn the assertions off otherwise we may recurse
6082                infinitely while printing error messages.  */
6083             SAVEI8(PL_utf8cache);
6084             PL_utf8cache = 0;
6085             Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6086                        " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6087         }
6088     }
6089
6090     /* Cache is held with the later position first, to simplify the code
6091        that deals with unbounded ends.  */
6092
6093     ASSERT_UTF8_CACHE(cache);
6094     if (cache[1] == 0) {
6095         /* Cache is totally empty  */
6096         cache[0] = utf8;
6097         cache[1] = byte;
6098     } else if (cache[3] == 0) {
6099         if (byte > cache[1]) {
6100             /* New one is larger, so goes first.  */
6101             cache[2] = cache[0];
6102             cache[3] = cache[1];
6103             cache[0] = utf8;
6104             cache[1] = byte;
6105         } else {
6106             cache[2] = utf8;
6107             cache[3] = byte;
6108         }
6109     } else {
6110 #define THREEWAY_SQUARE(a,b,c,d) \
6111             ((float)((d) - (c))) * ((float)((d) - (c))) \
6112             + ((float)((c) - (b))) * ((float)((c) - (b))) \
6113                + ((float)((b) - (a))) * ((float)((b) - (a)))
6114
6115         /* Cache has 2 slots in use, and we know three potential pairs.
6116            Keep the two that give the lowest RMS distance. Do the
6117            calcualation in bytes simply because we always know the byte
6118            length.  squareroot has the same ordering as the positive value,
6119            so don't bother with the actual square root.  */
6120         const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6121         if (byte > cache[1]) {
6122             /* New position is after the existing pair of pairs.  */
6123             const float keep_earlier
6124                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6125             const float keep_later
6126                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6127
6128             if (keep_later < keep_earlier) {
6129                 if (keep_later < existing) {
6130                     cache[2] = cache[0];
6131                     cache[3] = cache[1];
6132                     cache[0] = utf8;
6133                     cache[1] = byte;
6134                 }
6135             }
6136             else {
6137                 if (keep_earlier < existing) {
6138                     cache[0] = utf8;
6139                     cache[1] = byte;
6140                 }
6141             }
6142         }
6143         else if (byte > cache[3]) {
6144             /* New position is between the existing pair of pairs.  */
6145             const float keep_earlier
6146                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6147             const float keep_later
6148                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6149
6150             if (keep_later < keep_earlier) {
6151                 if (keep_later < existing) {
6152                     cache[2] = utf8;
6153                     cache[3] = byte;
6154                 }
6155             }
6156             else {
6157                 if (keep_earlier < existing) {
6158                     cache[0] = utf8;
6159                     cache[1] = byte;
6160                 }
6161             }
6162         }
6163         else {
6164             /* New position is before the existing pair of pairs.  */
6165             const float keep_earlier
6166                 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6167             const float keep_later
6168                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6169
6170             if (keep_later < keep_earlier) {
6171                 if (keep_later < existing) {
6172                     cache[2] = utf8;
6173                     cache[3] = byte;
6174                 }
6175             }
6176             else {
6177                 if (keep_earlier < existing) {
6178                     cache[0] = cache[2];
6179                     cache[1] = cache[3];
6180                     cache[2] = utf8;
6181                     cache[3] = byte;
6182                 }
6183             }
6184         }
6185     }
6186     ASSERT_UTF8_CACHE(cache);
6187 }
6188
6189 /* We already know all of the way, now we may be able to walk back.  The same
6190    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6191    backward is half the speed of walking forward. */
6192 static STRLEN
6193 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6194                     const U8 *end, STRLEN endu)
6195 {
6196     const STRLEN forw = target - s;
6197     STRLEN backw = end - target;
6198
6199     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6200
6201     if (forw < 2 * backw) {
6202         return utf8_length(s, target);
6203     }
6204
6205     while (end > target) {
6206         end--;
6207         while (UTF8_IS_CONTINUATION(*end)) {
6208             end--;
6209         }
6210         endu--;
6211     }
6212     return endu;
6213 }
6214
6215 /*
6216 =for apidoc sv_pos_b2u
6217
6218 Converts the value pointed to by offsetp from a count of bytes from the
6219 start of the string, to a count of the equivalent number of UTF-8 chars.
6220 Handles magic and type coercion.
6221
6222 =cut
6223 */
6224
6225 /*
6226  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6227  * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6228  * byte offsets.
6229  *
6230  */
6231 void
6232 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6233 {
6234     const U8* s;
6235     const STRLEN byte = *offsetp;
6236     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
6237     STRLEN blen;
6238     MAGIC* mg = NULL;
6239     const U8* send;
6240     bool found = FALSE;
6241
6242     PERL_ARGS_ASSERT_SV_POS_B2U;
6243
6244     if (!sv)
6245         return;
6246
6247     s = (const U8*)SvPV_const(sv, blen);
6248
6249     if (blen < byte)
6250         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6251
6252     send = s + byte;
6253
6254     if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6255         && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
6256         if (mg->mg_ptr) {
6257             STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6258             if (cache[1] == byte) {
6259                 /* An exact match. */
6260                 *offsetp = cache[0];
6261                 return;
6262             }
6263             if (cache[3] == byte) {
6264                 /* An exact match. */
6265                 *offsetp = cache[2];
6266                 return;
6267             }
6268
6269             if (cache[1] < byte) {
6270                 /* We already know part of the way. */
6271                 if (mg->mg_len != -1) {
6272                     /* Actually, we know the end too.  */
6273                     len = cache[0]
6274                         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6275                                               s + blen, mg->mg_len - cache[0]);
6276                 } else {
6277                     len = cache[0] + utf8_length(s + cache[1], send);
6278                 }
6279             }
6280             else if (cache[3] < byte) {
6281                 /* We're between the two cached pairs, so we do the calculation
6282                    offset by the byte/utf-8 positions for the earlier pair,
6283                    then add the utf-8 characters from the string start to
6284                    there.  */
6285                 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6286                                           s + cache[1], cache[0] - cache[2])
6287                     + cache[2];
6288
6289             }
6290             else { /* cache[3] > byte */
6291                 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6292                                           cache[2]);
6293
6294             }
6295             ASSERT_UTF8_CACHE(cache);
6296             found = TRUE;
6297         } else if (mg->mg_len != -1) {
6298             len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6299             found = TRUE;
6300         }
6301     }
6302     if (!found || PL_utf8cache < 0) {
6303         const STRLEN real_len = utf8_length(s, send);
6304
6305         if (found && PL_utf8cache < 0) {
6306             if (len != real_len) {
6307                 /* Need to turn the assertions off otherwise we may recurse
6308                    infinitely while printing error messages.  */
6309                 SAVEI8(PL_utf8cache);
6310                 PL_utf8cache = 0;
6311                 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6312                            " real %"UVuf" for %"SVf,
6313                            (UV) len, (UV) real_len, SVfARG(sv));
6314             }
6315         }
6316         len = real_len;
6317     }
6318     *offsetp = len;
6319
6320     if (PL_utf8cache)
6321         utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6322 }
6323
6324 /*
6325 =for apidoc sv_eq
6326
6327 Returns a boolean indicating whether the strings in the two SVs are
6328 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6329 coerce its args to strings if necessary.
6330
6331 =cut
6332 */
6333
6334 I32
6335 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6336 {
6337     dVAR;
6338     const char *pv1;
6339     STRLEN cur1;
6340     const char *pv2;
6341     STRLEN cur2;
6342     I32  eq     = 0;
6343     char *tpv   = NULL;
6344     SV* svrecode = NULL;
6345
6346     if (!sv1) {
6347         pv1 = "";
6348         cur1 = 0;
6349     }
6350     else {
6351         /* if pv1 and pv2 are the same, second SvPV_const call may
6352          * invalidate pv1, so we may need to make a copy */
6353         if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6354             pv1 = SvPV_const(sv1, cur1);
6355             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6356         }
6357         pv1 = SvPV_const(sv1, cur1);
6358     }
6359
6360     if (!sv2){
6361         pv2 = "";
6362         cur2 = 0;
6363     }
6364     else
6365         pv2 = SvPV_const(sv2, cur2);
6366
6367     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6368         /* Differing utf8ness.
6369          * Do not UTF8size the comparands as a side-effect. */
6370          if (PL_encoding) {
6371               if (SvUTF8(sv1)) {
6372                    svrecode = newSVpvn(pv2, cur2);
6373                    sv_recode_to_utf8(svrecode, PL_encoding);
6374                    pv2 = SvPV_const(svrecode, cur2);
6375               }
6376               else {
6377                    svrecode = newSVpvn(pv1, cur1);
6378                    sv_recode_to_utf8(svrecode, PL_encoding);
6379                    pv1 = SvPV_const(svrecode, cur1);
6380               }
6381               /* Now both are in UTF-8. */
6382               if (cur1 != cur2) {
6383                    SvREFCNT_dec(svrecode);
6384                    return FALSE;
6385               }
6386          }
6387          else {
6388               bool is_utf8 = TRUE;
6389
6390               if (SvUTF8(sv1)) {
6391                    /* sv1 is the UTF-8 one,
6392                     * if is equal it must be downgrade-able */
6393                    char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6394                                                      &cur1, &is_utf8);
6395                    if (pv != pv1)
6396                         pv1 = tpv = pv;
6397               }
6398               else {
6399                    /* sv2 is the UTF-8 one,
6400                     * if is equal it must be downgrade-able */
6401                    char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6402                                                       &cur2, &is_utf8);
6403                    if (pv != pv2)
6404                         pv2 = tpv = pv;
6405               }
6406               if (is_utf8) {
6407                    /* Downgrade not possible - cannot be eq */
6408                    assert (tpv == 0);
6409                    return FALSE;
6410               }
6411          }
6412     }
6413
6414     if (cur1 == cur2)
6415         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6416
6417     SvREFCNT_dec(svrecode);
6418     if (tpv)
6419         Safefree(tpv);
6420
6421     return eq;
6422 }
6423
6424 /*
6425 =for apidoc sv_cmp
6426
6427 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
6428 string in C<sv1> is less than, equal to, or greater than the string in
6429 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6430 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
6431
6432 =cut
6433 */
6434
6435 I32
6436 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6437 {
6438     dVAR;
6439     STRLEN cur1, cur2;
6440     const char *pv1, *pv2;
6441     char *tpv = NULL;
6442     I32  cmp;
6443     SV *svrecode = NULL;
6444
6445     if (!sv1) {
6446         pv1 = "";
6447         cur1 = 0;
6448     }
6449     else
6450         pv1 = SvPV_const(sv1, cur1);
6451
6452     if (!sv2) {
6453         pv2 = "";
6454         cur2 = 0;
6455     }
6456     else
6457         pv2 = SvPV_const(sv2, cur2);
6458
6459     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6460         /* Differing utf8ness.
6461          * Do not UTF8size the comparands as a side-effect. */
6462         if (SvUTF8(sv1)) {
6463             if (PL_encoding) {
6464                  svrecode = newSVpvn(pv2, cur2);
6465                  sv_recode_to_utf8(svrecode, PL_encoding);
6466                  pv2 = SvPV_const(svrecode, cur2);
6467             }
6468             else {
6469                  pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6470             }
6471         }
6472         else {
6473             if (PL_encoding) {
6474                  svrecode = newSVpvn(pv1, cur1);
6475                  sv_recode_to_utf8(svrecode, PL_encoding);
6476                  pv1 = SvPV_const(svrecode, cur1);
6477             }
6478             else {
6479                  pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6480             }
6481         }
6482     }
6483
6484     if (!cur1) {
6485         cmp = cur2 ? -1 : 0;
6486     } else if (!cur2) {
6487         cmp = 1;
6488     } else {
6489         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6490
6491         if (retval) {
6492             cmp = retval < 0 ? -1 : 1;
6493         } else if (cur1 == cur2) {
6494             cmp = 0;
6495         } else {
6496             cmp = cur1 < cur2 ? -1 : 1;
6497         }
6498     }
6499
6500     SvREFCNT_dec(svrecode);
6501     if (tpv)
6502         Safefree(tpv);
6503
6504     return cmp;
6505 }
6506
6507 /*
6508 =for apidoc sv_cmp_locale
6509
6510 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6511 'use bytes' aware, handles get magic, and will coerce its args to strings
6512 if necessary.  See also C<sv_cmp>.
6513
6514 =cut
6515 */
6516
6517 I32
6518 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6519 {
6520     dVAR;
6521 #ifdef USE_LOCALE_COLLATE
6522
6523     char *pv1, *pv2;
6524     STRLEN len1, len2;
6525     I32 retval;
6526
6527     if (PL_collation_standard)
6528         goto raw_compare;
6529
6530     len1 = 0;
6531     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6532     len2 = 0;
6533     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6534
6535     if (!pv1 || !len1) {
6536         if (pv2 && len2)
6537             return -1;
6538         else
6539             goto raw_compare;
6540     }
6541     else {
6542         if (!pv2 || !len2)
6543             return 1;
6544     }
6545
6546     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6547
6548     if (retval)
6549         return retval < 0 ? -1 : 1;
6550
6551     /*
6552      * When the result of collation is equality, that doesn't mean
6553      * that there are no differences -- some locales exclude some
6554      * characters from consideration.  So to avoid false equalities,
6555      * we use the raw string as a tiebreaker.
6556      */
6557
6558   raw_compare:
6559     /*FALLTHROUGH*/
6560
6561 #endif /* USE_LOCALE_COLLATE */
6562
6563     return sv_cmp(sv1, sv2);
6564 }
6565
6566
6567 #ifdef USE_LOCALE_COLLATE
6568
6569 /*
6570 =for apidoc sv_collxfrm
6571
6572 Add Collate Transform magic to an SV if it doesn't already have it.
6573
6574 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6575 scalar data of the variable, but transformed to such a format that a normal
6576 memory comparison can be used to compare the data according to the locale
6577 settings.
6578
6579 =cut
6580 */
6581
6582 char *
6583 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6584 {
6585     dVAR;
6586     MAGIC *mg;
6587
6588     PERL_ARGS_ASSERT_SV_COLLXFRM;
6589
6590     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6591     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6592         const char *s;
6593         char *xf;
6594         STRLEN len, xlen;
6595
6596         if (mg)
6597             Safefree(mg->mg_ptr);
6598         s = SvPV_const(sv, len);
6599         if ((xf = mem_collxfrm(s, len, &xlen))) {
6600             if (! mg) {
6601 #ifdef PERL_OLD_COPY_ON_WRITE
6602                 if (SvIsCOW(sv))
6603                     sv_force_normal_flags(sv, 0);
6604 #endif
6605                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6606                                  0, 0);
6607                 assert(mg);
6608             }
6609             mg->mg_ptr = xf;
6610             mg->mg_len = xlen;
6611         }
6612         else {
6613             if (mg) {
6614                 mg->mg_ptr = NULL;
6615                 mg->mg_len = -1;
6616             }
6617         }
6618     }
6619     if (mg && mg->mg_ptr) {
6620         *nxp = mg->mg_len;
6621         return mg->mg_ptr + sizeof(PL_collation_ix);
6622     }
6623     else {
6624         *nxp = 0;
6625         return NULL;
6626     }
6627 }
6628
6629 #endif /* USE_LOCALE_COLLATE */
6630
6631 /*
6632 =for apidoc sv_gets
6633
6634 Get a line from the filehandle and store it into the SV, optionally
6635 appending to the currently-stored string.
6636
6637 =cut
6638 */
6639
6640 char *
6641 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6642 {
6643     dVAR;
6644     const char *rsptr;
6645     STRLEN rslen;
6646     register STDCHAR rslast;
6647     register STDCHAR *bp;
6648     register I32 cnt;
6649     I32 i = 0;
6650     I32 rspara = 0;
6651
6652     PERL_ARGS_ASSERT_SV_GETS;
6653
6654     if (SvTHINKFIRST(sv))
6655         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6656     /* XXX. If you make this PVIV, then copy on write can copy scalars read
6657        from <>.
6658        However, perlbench says it's slower, because the existing swipe code
6659        is faster than copy on write.
6660        Swings and roundabouts.  */
6661     SvUPGRADE(sv, SVt_PV);
6662
6663     SvSCREAM_off(sv);
6664
6665     if (append) {
6666         if (PerlIO_isutf8(fp)) {
6667             if (!SvUTF8(sv)) {
6668                 sv_utf8_upgrade_nomg(sv);
6669                 sv_pos_u2b(sv,&append,0);
6670             }
6671         } else if (SvUTF8(sv)) {
6672             SV * const tsv = newSV(0);
6673             sv_gets(tsv, fp, 0);
6674             sv_utf8_upgrade_nomg(tsv);
6675             SvCUR_set(sv,append);
6676             sv_catsv(sv,tsv);
6677             sv_free(tsv);
6678             goto return_string_or_null;
6679         }
6680     }
6681
6682     SvPOK_only(sv);
6683     if (PerlIO_isutf8(fp))
6684         SvUTF8_on(sv);
6685
6686     if (IN_PERL_COMPILETIME) {
6687         /* we always read code in line mode */
6688         rsptr = "\n";
6689         rslen = 1;
6690     }
6691     else if (RsSNARF(PL_rs)) {
6692         /* If it is a regular disk file use size from stat() as estimate
6693            of amount we are going to read -- may result in mallocing
6694            more memory than we really need if the layers below reduce
6695            the size we read (e.g. CRLF or a gzip layer).
6696          */
6697         Stat_t st;
6698         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
6699             const Off_t offset = PerlIO_tell(fp);
6700             if (offset != (Off_t) -1 && st.st_size + append > offset) {
6701                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6702             }
6703         }
6704         rsptr = NULL;
6705         rslen = 0;
6706     }
6707     else if (RsRECORD(PL_rs)) {
6708       I32 bytesread;
6709       char *buffer;
6710       U32 recsize;
6711 #ifdef VMS
6712       int fd;
6713 #endif
6714
6715       /* Grab the size of the record we're getting */
6716       recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
6717       buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6718       /* Go yank in */
6719 #ifdef VMS
6720       /* VMS wants read instead of fread, because fread doesn't respect */
6721       /* RMS record boundaries. This is not necessarily a good thing to be */
6722       /* doing, but we've got no other real choice - except avoid stdio
6723          as implementation - perhaps write a :vms layer ?
6724        */
6725       fd = PerlIO_fileno(fp);
6726       if (fd == -1) { /* in-memory file from PerlIO::Scalar */
6727           bytesread = PerlIO_read(fp, buffer, recsize);
6728       }
6729       else {
6730           bytesread = PerlLIO_read(fd, buffer, recsize);
6731       }
6732 #else
6733       bytesread = PerlIO_read(fp, buffer, recsize);
6734 #endif
6735       if (bytesread < 0)
6736           bytesread = 0;
6737       SvCUR_set(sv, bytesread + append);
6738       buffer[bytesread] = '\0';
6739       goto return_string_or_null;
6740     }
6741     else if (RsPARA(PL_rs)) {
6742         rsptr = "\n\n";
6743         rslen = 2;
6744         rspara = 1;
6745     }
6746     else {
6747         /* Get $/ i.e. PL_rs into same encoding as stream wants */
6748         if (PerlIO_isutf8(fp)) {
6749             rsptr = SvPVutf8(PL_rs, rslen);
6750         }
6751         else {
6752             if (SvUTF8(PL_rs)) {
6753                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6754                     Perl_croak(aTHX_ "Wide character in $/");
6755                 }
6756             }
6757             rsptr = SvPV_const(PL_rs, rslen);
6758         }
6759     }
6760
6761     rslast = rslen ? rsptr[rslen - 1] : '\0';
6762
6763     if (rspara) {               /* have to do this both before and after */
6764         do {                    /* to make sure file boundaries work right */
6765             if (PerlIO_eof(fp))
6766                 return 0;
6767             i = PerlIO_getc(fp);
6768             if (i != '\n') {
6769                 if (i == -1)
6770                     return 0;
6771                 PerlIO_ungetc(fp,i);
6772                 break;
6773             }
6774         } while (i != EOF);
6775     }
6776
6777     /* See if we know enough about I/O mechanism to cheat it ! */
6778
6779     /* This used to be #ifdef test - it is made run-time test for ease
6780        of abstracting out stdio interface. One call should be cheap
6781        enough here - and may even be a macro allowing compile
6782        time optimization.
6783      */
6784
6785     if (PerlIO_fast_gets(fp)) {
6786
6787     /*
6788      * We're going to steal some values from the stdio struct
6789      * and put EVERYTHING in the innermost loop into registers.
6790      */
6791     register STDCHAR *ptr;
6792     STRLEN bpx;
6793     I32 shortbuffered;
6794
6795 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6796     /* An ungetc()d char is handled separately from the regular
6797      * buffer, so we getc() it back out and stuff it in the buffer.
6798      */
6799     i = PerlIO_getc(fp);
6800     if (i == EOF) return 0;
6801     *(--((*fp)->_ptr)) = (unsigned char) i;
6802     (*fp)->_cnt++;
6803 #endif
6804
6805     /* Here is some breathtakingly efficient cheating */
6806
6807     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
6808     /* make sure we have the room */
6809     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6810         /* Not room for all of it
6811            if we are looking for a separator and room for some
6812          */
6813         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6814             /* just process what we have room for */
6815             shortbuffered = cnt - SvLEN(sv) + append + 1;
6816             cnt -= shortbuffered;
6817         }
6818         else {
6819             shortbuffered = 0;
6820             /* remember that cnt can be negative */
6821             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6822         }
6823     }
6824     else
6825         shortbuffered = 0;
6826     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
6827     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6828     DEBUG_P(PerlIO_printf(Perl_debug_log,
6829         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6830     DEBUG_P(PerlIO_printf(Perl_debug_log,
6831         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6832                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6833                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6834     for (;;) {
6835       screamer:
6836         if (cnt > 0) {
6837             if (rslen) {
6838                 while (cnt > 0) {                    /* this     |  eat */
6839                     cnt--;
6840                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
6841                         goto thats_all_folks;        /* screams  |  sed :-) */
6842                 }
6843             }
6844             else {
6845                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
6846                 bp += cnt;                           /* screams  |  dust */
6847                 ptr += cnt;                          /* louder   |  sed :-) */
6848                 cnt = 0;
6849             }
6850         }
6851
6852         if (shortbuffered) {            /* oh well, must extend */
6853             cnt = shortbuffered;
6854             shortbuffered = 0;
6855             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6856             SvCUR_set(sv, bpx);
6857             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6858             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6859             continue;
6860         }
6861
6862         DEBUG_P(PerlIO_printf(Perl_debug_log,
6863                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6864                               PTR2UV(ptr),(long)cnt));
6865         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6866 #if 0
6867         DEBUG_P(PerlIO_printf(Perl_debug_log,
6868             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6869             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6870             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6871 #endif
6872         /* This used to call 'filbuf' in stdio form, but as that behaves like
6873            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6874            another abstraction.  */
6875         i   = PerlIO_getc(fp);          /* get more characters */
6876 #if 0
6877         DEBUG_P(PerlIO_printf(Perl_debug_log,
6878             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6879             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6880             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6881 #endif
6882         cnt = PerlIO_get_cnt(fp);
6883         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
6884         DEBUG_P(PerlIO_printf(Perl_debug_log,
6885             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6886
6887         if (i == EOF)                   /* all done for ever? */
6888             goto thats_really_all_folks;
6889
6890         bpx = bp - (STDCHAR*)SvPVX_const(sv);   /* box up before relocation */
6891         SvCUR_set(sv, bpx);
6892         SvGROW(sv, bpx + cnt + 2);
6893         bp = (STDCHAR*)SvPVX_const(sv) + bpx;   /* unbox after relocation */
6894
6895         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
6896
6897         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
6898             goto thats_all_folks;
6899     }
6900
6901 thats_all_folks:
6902     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6903           memNE((char*)bp - rslen, rsptr, rslen))
6904         goto screamer;                          /* go back to the fray */
6905 thats_really_all_folks:
6906     if (shortbuffered)
6907         cnt += shortbuffered;
6908         DEBUG_P(PerlIO_printf(Perl_debug_log,
6909             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6910     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
6911     DEBUG_P(PerlIO_printf(Perl_debug_log,
6912         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6913         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6914         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6915     *bp = '\0';
6916     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));      /* set length */
6917     DEBUG_P(PerlIO_printf(Perl_debug_log,
6918         "Screamer: done, len=%ld, string=|%.*s|\n",
6919         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6920     }
6921    else
6922     {
6923        /*The big, slow, and stupid way. */
6924 #ifdef USE_HEAP_INSTEAD_OF_STACK        /* Even slower way. */
6925         STDCHAR *buf = NULL;
6926         Newx(buf, 8192, STDCHAR);
6927         assert(buf);
6928 #else
6929         STDCHAR buf[8192];
6930 #endif
6931
6932 screamer2:
6933         if (rslen) {
6934             register const STDCHAR * const bpe = buf + sizeof(buf);
6935             bp = buf;
6936             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6937                 ; /* keep reading */
6938             cnt = bp - buf;
6939         }
6940         else {
6941             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6942             /* Accomodate broken VAXC compiler, which applies U8 cast to
6943              * both args of ?: operator, causing EOF to change into 255
6944              */
6945             if (cnt > 0)
6946                  i = (U8)buf[cnt - 1];
6947             else
6948                  i = EOF;
6949         }
6950
6951         if (cnt < 0)
6952             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
6953         if (append)
6954              sv_catpvn(sv, (char *) buf, cnt);
6955         else
6956              sv_setpvn(sv, (char *) buf, cnt);
6957
6958         if (i != EOF &&                 /* joy */
6959             (!rslen ||
6960              SvCUR(sv) < rslen ||
6961              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6962         {
6963             append = -1;
6964             /*
6965              * If we're reading from a TTY and we get a short read,
6966              * indicating that the user hit his EOF character, we need
6967              * to notice it now, because if we try to read from the TTY
6968              * again, the EOF condition will disappear.
6969              *
6970              * The comparison of cnt to sizeof(buf) is an optimization
6971              * that prevents unnecessary calls to feof().
6972              *
6973              * - jik 9/25/96
6974              */
6975             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
6976                 goto screamer2;
6977         }
6978
6979 #ifdef USE_HEAP_INSTEAD_OF_STACK
6980         Safefree(buf);
6981 #endif
6982     }
6983
6984     if (rspara) {               /* have to do this both before and after */
6985         while (i != EOF) {      /* to make sure file boundaries work right */
6986             i = PerlIO_getc(fp);
6987             if (i != '\n') {
6988                 PerlIO_ungetc(fp,i);
6989                 break;
6990             }
6991         }
6992     }
6993
6994 return_string_or_null:
6995     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
6996 }
6997
6998 /*
6999 =for apidoc sv_inc
7000
7001 Auto-increment of the value in the SV, doing string to numeric conversion
7002 if necessary. Handles 'get' magic.
7003
7004 =cut
7005 */
7006
7007 void
7008 Perl_sv_inc(pTHX_ register SV *const sv)
7009 {
7010     dVAR;
7011     register char *d;
7012     int flags;
7013
7014     if (!sv)
7015         return;
7016     SvGETMAGIC(sv);
7017     if (SvTHINKFIRST(sv)) {
7018         if (SvIsCOW(sv))
7019             sv_force_normal_flags(sv, 0);
7020         if (SvREADONLY(sv)) {
7021             if (IN_PERL_RUNTIME)
7022                 Perl_croak(aTHX_ PL_no_modify);
7023         }
7024         if (SvROK(sv)) {
7025             IV i;
7026             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7027                 return;
7028             i = PTR2IV(SvRV(sv));
7029             sv_unref(sv);
7030             sv_setiv(sv, i);
7031         }
7032     }
7033     flags = SvFLAGS(sv);
7034     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7035         /* It's (privately or publicly) a float, but not tested as an
7036            integer, so test it to see. */
7037         (void) SvIV(sv);
7038         flags = SvFLAGS(sv);
7039     }
7040     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7041         /* It's publicly an integer, or privately an integer-not-float */
7042 #ifdef PERL_PRESERVE_IVUV
7043       oops_its_int:
7044 #endif
7045         if (SvIsUV(sv)) {
7046             if (SvUVX(sv) == UV_MAX)
7047                 sv_setnv(sv, UV_MAX_P1);
7048             else
7049                 (void)SvIOK_only_UV(sv);
7050                 SvUV_set(sv, SvUVX(sv) + 1);
7051         } else {
7052             if (SvIVX(sv) == IV_MAX)
7053                 sv_setuv(sv, (UV)IV_MAX + 1);
7054             else {
7055                 (void)SvIOK_only(sv);
7056                 SvIV_set(sv, SvIVX(sv) + 1);
7057             }
7058         }
7059         return;
7060     }
7061     if (flags & SVp_NOK) {
7062         const NV was = SvNVX(sv);
7063         if (NV_OVERFLOWS_INTEGERS_AT &&
7064             was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7065             Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7066                         "Lost precision when incrementing %" NVff " by 1",
7067                         was);
7068         }
7069         (void)SvNOK_only(sv);
7070         SvNV_set(sv, was + 1.0);
7071         return;
7072     }
7073
7074     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7075         if ((flags & SVTYPEMASK) < SVt_PVIV)
7076             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7077         (void)SvIOK_only(sv);
7078         SvIV_set(sv, 1);
7079         return;
7080     }
7081     d = SvPVX(sv);
7082     while (isALPHA(*d)) d++;
7083     while (isDIGIT(*d)) d++;
7084     if (*d) {
7085 #ifdef PERL_PRESERVE_IVUV
7086         /* Got to punt this as an integer if needs be, but we don't issue
7087            warnings. Probably ought to make the sv_iv_please() that does
7088            the conversion if possible, and silently.  */
7089         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7090         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7091             /* Need to try really hard to see if it's an integer.
7092                9.22337203685478e+18 is an integer.
7093                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7094                so $a="9.22337203685478e+18"; $a+0; $a++
7095                needs to be the same as $a="9.22337203685478e+18"; $a++
7096                or we go insane. */
7097
7098             (void) sv_2iv(sv);
7099             if (SvIOK(sv))
7100                 goto oops_its_int;
7101
7102             /* sv_2iv *should* have made this an NV */
7103             if (flags & SVp_NOK) {
7104                 (void)SvNOK_only(sv);
7105                 SvNV_set(sv, SvNVX(sv) + 1.0);
7106                 return;
7107             }
7108             /* I don't think we can get here. Maybe I should assert this
7109                And if we do get here I suspect that sv_setnv will croak. NWC
7110                Fall through. */
7111 #if defined(USE_LONG_DOUBLE)
7112             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",
7113                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7114 #else
7115             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7116                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7117 #endif
7118         }
7119 #endif /* PERL_PRESERVE_IVUV */
7120         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7121         return;
7122     }
7123     d--;
7124     while (d >= SvPVX_const(sv)) {
7125         if (isDIGIT(*d)) {
7126             if (++*d <= '9')
7127                 return;
7128             *(d--) = '0';
7129         }
7130         else {
7131 #ifdef EBCDIC
7132             /* MKS: The original code here died if letters weren't consecutive.
7133              * at least it didn't have to worry about non-C locales.  The
7134              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7135              * arranged in order (although not consecutively) and that only
7136              * [A-Za-z] are accepted by isALPHA in the C locale.
7137              */
7138             if (*d != 'z' && *d != 'Z') {
7139                 do { ++*d; } while (!isALPHA(*d));
7140                 return;
7141             }
7142             *(d--) -= 'z' - 'a';
7143 #else
7144             ++*d;
7145             if (isALPHA(*d))
7146                 return;
7147             *(d--) -= 'z' - 'a' + 1;
7148 #endif
7149         }
7150     }
7151     /* oh,oh, the number grew */
7152     SvGROW(sv, SvCUR(sv) + 2);
7153     SvCUR_set(sv, SvCUR(sv) + 1);
7154     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7155         *d = d[-1];
7156     if (isDIGIT(d[1]))
7157         *d = '1';
7158     else
7159         *d = d[1];
7160 }
7161
7162 /*
7163 =for apidoc sv_dec
7164
7165 Auto-decrement of the value in the SV, doing string to numeric conversion
7166 if necessary. Handles 'get' magic.
7167
7168 =cut
7169 */
7170
7171 void
7172 Perl_sv_dec(pTHX_ register SV *const sv)
7173 {
7174     dVAR;
7175     int flags;
7176
7177     if (!sv)
7178         return;
7179     SvGETMAGIC(sv);
7180     if (SvTHINKFIRST(sv)) {
7181         if (SvIsCOW(sv))
7182             sv_force_normal_flags(sv, 0);
7183         if (SvREADONLY(sv)) {
7184             if (IN_PERL_RUNTIME)
7185                 Perl_croak(aTHX_ PL_no_modify);
7186         }
7187         if (SvROK(sv)) {
7188             IV i;
7189             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7190                 return;
7191             i = PTR2IV(SvRV(sv));
7192             sv_unref(sv);
7193             sv_setiv(sv, i);
7194         }
7195     }
7196     /* Unlike sv_inc we don't have to worry about string-never-numbers
7197        and keeping them magic. But we mustn't warn on punting */
7198     flags = SvFLAGS(sv);
7199     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7200         /* It's publicly an integer, or privately an integer-not-float */
7201 #ifdef PERL_PRESERVE_IVUV
7202       oops_its_int:
7203 #endif
7204         if (SvIsUV(sv)) {
7205             if (SvUVX(sv) == 0) {
7206                 (void)SvIOK_only(sv);
7207                 SvIV_set(sv, -1);
7208             }
7209             else {
7210                 (void)SvIOK_only_UV(sv);
7211                 SvUV_set(sv, SvUVX(sv) - 1);
7212             }
7213         } else {
7214             if (SvIVX(sv) == IV_MIN) {
7215                 sv_setnv(sv, (NV)IV_MIN);
7216                 goto oops_its_num;
7217             }
7218             else {
7219                 (void)SvIOK_only(sv);
7220                 SvIV_set(sv, SvIVX(sv) - 1);
7221             }
7222         }
7223         return;
7224     }
7225     if (flags & SVp_NOK) {
7226     oops_its_num:
7227         {
7228             const NV was = SvNVX(sv);
7229             if (NV_OVERFLOWS_INTEGERS_AT &&
7230                 was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7231                 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7232                             "Lost precision when decrementing %" NVff " by 1",
7233                             was);
7234             }
7235             (void)SvNOK_only(sv);
7236             SvNV_set(sv, was - 1.0);
7237             return;
7238         }
7239     }
7240     if (!(flags & SVp_POK)) {
7241         if ((flags & SVTYPEMASK) < SVt_PVIV)
7242             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7243         SvIV_set(sv, -1);
7244         (void)SvIOK_only(sv);
7245         return;
7246     }
7247 #ifdef PERL_PRESERVE_IVUV
7248     {
7249         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7250         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7251             /* Need to try really hard to see if it's an integer.
7252                9.22337203685478e+18 is an integer.
7253                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7254                so $a="9.22337203685478e+18"; $a+0; $a--
7255                needs to be the same as $a="9.22337203685478e+18"; $a--
7256                or we go insane. */
7257
7258             (void) sv_2iv(sv);
7259             if (SvIOK(sv))
7260                 goto oops_its_int;
7261
7262             /* sv_2iv *should* have made this an NV */
7263             if (flags & SVp_NOK) {
7264                 (void)SvNOK_only(sv);
7265                 SvNV_set(sv, SvNVX(sv) - 1.0);
7266                 return;
7267             }
7268             /* I don't think we can get here. Maybe I should assert this
7269                And if we do get here I suspect that sv_setnv will croak. NWC
7270                Fall through. */
7271 #if defined(USE_LONG_DOUBLE)
7272             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",
7273                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7274 #else
7275             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7276                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7277 #endif
7278         }
7279     }
7280 #endif /* PERL_PRESERVE_IVUV */
7281     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);   /* punt */
7282 }
7283
7284 /*
7285 =for apidoc sv_mortalcopy
7286
7287 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7288 The new SV is marked as mortal. It will be destroyed "soon", either by an
7289 explicit call to FREETMPS, or by an implicit call at places such as
7290 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
7291
7292 =cut
7293 */
7294
7295 /* Make a string that will exist for the duration of the expression
7296  * evaluation.  Actually, it may have to last longer than that, but
7297  * hopefully we won't free it until it has been assigned to a
7298  * permanent location. */
7299
7300 SV *
7301 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7302 {
7303     dVAR;
7304     register SV *sv;
7305
7306     new_SV(sv);
7307     sv_setsv(sv,oldstr);
7308     EXTEND_MORTAL(1);
7309     PL_tmps_stack[++PL_tmps_ix] = sv;
7310     SvTEMP_on(sv);
7311     return sv;
7312 }
7313
7314 /*
7315 =for apidoc sv_newmortal
7316
7317 Creates a new null SV which is mortal.  The reference count of the SV is
7318 set to 1. It will be destroyed "soon", either by an explicit call to
7319 FREETMPS, or by an implicit call at places such as statement boundaries.
7320 See also C<sv_mortalcopy> and C<sv_2mortal>.
7321
7322 =cut
7323 */
7324
7325 SV *
7326 Perl_sv_newmortal(pTHX)
7327 {
7328     dVAR;
7329     register SV *sv;
7330
7331     new_SV(sv);
7332     SvFLAGS(sv) = SVs_TEMP;
7333     EXTEND_MORTAL(1);
7334     PL_tmps_stack[++PL_tmps_ix] = sv;
7335     return sv;
7336 }
7337
7338
7339 /*
7340 =for apidoc newSVpvn_flags
7341
7342 Creates a new SV and copies a string into it.  The reference count for the
7343 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7344 string.  You are responsible for ensuring that the source string is at least
7345 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7346 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7347 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7348 returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
7349 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7350
7351     #define newSVpvn_utf8(s, len, u)                    \
7352         newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7353
7354 =cut
7355 */
7356
7357 SV *
7358 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7359 {
7360     dVAR;
7361     register SV *sv;
7362
7363     /* All the flags we don't support must be zero.
7364        And we're new code so I'm going to assert this from the start.  */
7365     assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7366     new_SV(sv);
7367     sv_setpvn(sv,s,len);
7368     SvFLAGS(sv) |= (flags & SVf_UTF8);
7369     return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
7370 }
7371
7372 /*
7373 =for apidoc sv_2mortal
7374
7375 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
7376 by an explicit call to FREETMPS, or by an implicit call at places such as
7377 statement boundaries.  SvTEMP() is turned on which means that the SV's
7378 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7379 and C<sv_mortalcopy>.
7380
7381 =cut
7382 */
7383
7384 SV *
7385 Perl_sv_2mortal(pTHX_ register SV *const sv)
7386 {
7387     dVAR;
7388     if (!sv)
7389         return NULL;
7390     if (SvREADONLY(sv) && SvIMMORTAL(sv))
7391         return sv;
7392     EXTEND_MORTAL(1);
7393     PL_tmps_stack[++PL_tmps_ix] = sv;
7394     SvTEMP_on(sv);
7395     return sv;
7396 }
7397
7398 /*
7399 =for apidoc newSVpv
7400
7401 Creates a new SV and copies a string into it.  The reference count for the
7402 SV is set to 1.  If C<len> is zero, Perl will compute the length using
7403 strlen().  For efficiency, consider using C<newSVpvn> instead.
7404
7405 =cut
7406 */
7407
7408 SV *
7409 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7410 {
7411     dVAR;
7412     register SV *sv;
7413
7414     new_SV(sv);
7415     sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7416     return sv;
7417 }
7418
7419 /*
7420 =for apidoc newSVpvn
7421
7422 Creates a new SV and copies a string into it.  The reference count for the
7423 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7424 string.  You are responsible for ensuring that the source string is at least
7425 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7426
7427 =cut
7428 */
7429
7430 SV *
7431 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7432 {
7433     dVAR;
7434     register SV *sv;
7435
7436     new_SV(sv);
7437     sv_setpvn(sv,s,len);
7438     return sv;
7439 }
7440
7441 /*
7442 =for apidoc newSVhek
7443
7444 Creates a new SV from the hash key structure.  It will generate scalars that
7445 point to the shared string table where possible. Returns a new (undefined)
7446 SV if the hek is NULL.
7447
7448 =cut
7449 */
7450
7451 SV *
7452 Perl_newSVhek(pTHX_ const HEK *const hek)
7453 {
7454     dVAR;
7455     if (!hek) {
7456         SV *sv;
7457
7458         new_SV(sv);
7459         return sv;
7460     }
7461
7462     if (HEK_LEN(hek) == HEf_SVKEY) {
7463         return newSVsv(*(SV**)HEK_KEY(hek));
7464     } else {
7465         const int flags = HEK_FLAGS(hek);
7466         if (flags & HVhek_WASUTF8) {
7467             /* Trouble :-)
7468                Andreas would like keys he put in as utf8 to come back as utf8
7469             */
7470             STRLEN utf8_len = HEK_LEN(hek);
7471             const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7472             SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7473
7474             SvUTF8_on (sv);
7475             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7476             return sv;
7477         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7478             /* We don't have a pointer to the hv, so we have to replicate the
7479                flag into every HEK. This hv is using custom a hasing
7480                algorithm. Hence we can't return a shared string scalar, as
7481                that would contain the (wrong) hash value, and might get passed
7482                into an hv routine with a regular hash.
7483                Similarly, a hash that isn't using shared hash keys has to have
7484                the flag in every key so that we know not to try to call
7485                share_hek_kek on it.  */
7486
7487             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7488             if (HEK_UTF8(hek))
7489                 SvUTF8_on (sv);
7490             return sv;
7491         }
7492         /* This will be overwhelminly the most common case.  */
7493         {
7494             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7495                more efficient than sharepvn().  */
7496             SV *sv;
7497
7498             new_SV(sv);
7499             sv_upgrade(sv, SVt_PV);
7500             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7501             SvCUR_set(sv, HEK_LEN(hek));
7502             SvLEN_set(sv, 0);
7503             SvREADONLY_on(sv);
7504             SvFAKE_on(sv);
7505             SvPOK_on(sv);
7506             if (HEK_UTF8(hek))
7507                 SvUTF8_on(sv);
7508             return sv;
7509         }
7510     }
7511 }
7512
7513 /*
7514 =for apidoc newSVpvn_share
7515
7516 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7517 table. If the string does not already exist in the table, it is created
7518 first.  Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7519 value is used; otherwise the hash is computed. The string's hash can be later
7520 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7521 that as the string table is used for shared hash keys these strings will have
7522 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7523
7524 =cut
7525 */
7526
7527 SV *
7528 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7529 {
7530     dVAR;
7531     register SV *sv;
7532     bool is_utf8 = FALSE;
7533     const char *const orig_src = src;
7534
7535     if (len < 0) {
7536         STRLEN tmplen = -len;
7537         is_utf8 = TRUE;
7538         /* See the note in hv.c:hv_fetch() --jhi */
7539         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7540         len = tmplen;
7541     }
7542     if (!hash)
7543         PERL_HASH(hash, src, len);
7544     new_SV(sv);
7545     /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7546        changes here, update it there too.  */
7547     sv_upgrade(sv, SVt_PV);
7548     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7549     SvCUR_set(sv, len);
7550     SvLEN_set(sv, 0);
7551     SvREADONLY_on(sv);
7552     SvFAKE_on(sv);
7553     SvPOK_on(sv);
7554     if (is_utf8)
7555         SvUTF8_on(sv);
7556     if (src != orig_src)
7557         Safefree(src);
7558     return sv;
7559 }
7560
7561
7562 #if defined(PERL_IMPLICIT_CONTEXT)
7563
7564 /* pTHX_ magic can't cope with varargs, so this is a no-context
7565  * version of the main function, (which may itself be aliased to us).
7566  * Don't access this version directly.
7567  */
7568
7569 SV *
7570 Perl_newSVpvf_nocontext(const char *const pat, ...)
7571 {
7572     dTHX;
7573     register SV *sv;
7574     va_list args;
7575
7576     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7577
7578     va_start(args, pat);
7579     sv = vnewSVpvf(pat, &args);
7580     va_end(args);
7581     return sv;
7582 }
7583 #endif
7584
7585 /*
7586 =for apidoc newSVpvf
7587
7588 Creates a new SV and initializes it with the string formatted like
7589 C<sprintf>.
7590
7591 =cut
7592 */
7593
7594 SV *
7595 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7596 {
7597     register SV *sv;
7598     va_list args;
7599
7600     PERL_ARGS_ASSERT_NEWSVPVF;
7601
7602     va_start(args, pat);
7603     sv = vnewSVpvf(pat, &args);
7604     va_end(args);
7605     return sv;
7606 }
7607
7608 /* backend for newSVpvf() and newSVpvf_nocontext() */
7609
7610 SV *
7611 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7612 {
7613     dVAR;
7614     register SV *sv;
7615
7616     PERL_ARGS_ASSERT_VNEWSVPVF;
7617
7618     new_SV(sv);
7619     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7620     return sv;
7621 }
7622
7623 /*
7624 =for apidoc newSVnv
7625
7626 Creates a new SV and copies a floating point value into it.
7627 The reference count for the SV is set to 1.
7628
7629 =cut
7630 */
7631
7632 SV *
7633 Perl_newSVnv(pTHX_ const NV n)
7634 {
7635     dVAR;
7636     register SV *sv;
7637
7638     new_SV(sv);
7639     sv_setnv(sv,n);
7640     return sv;
7641 }
7642
7643 /*
7644 =for apidoc newSViv
7645
7646 Creates a new SV and copies an integer into it.  The reference count for the
7647 SV is set to 1.
7648
7649 =cut
7650 */
7651
7652 SV *
7653 Perl_newSViv(pTHX_ const IV i)
7654 {
7655     dVAR;
7656     register SV *sv;
7657
7658     new_SV(sv);
7659     sv_setiv(sv,i);
7660     return sv;
7661 }
7662
7663 /*
7664 =for apidoc newSVuv
7665
7666 Creates a new SV and copies an unsigned integer into it.
7667 The reference count for the SV is set to 1.
7668
7669 =cut
7670 */
7671
7672 SV *
7673 Perl_newSVuv(pTHX_ const UV u)
7674 {
7675     dVAR;
7676     register SV *sv;
7677
7678     new_SV(sv);
7679     sv_setuv(sv,u);
7680     return sv;
7681 }
7682
7683 /*
7684 =for apidoc newSV_type
7685
7686 Creates a new SV, of the type specified.  The reference count for the new SV
7687 is set to 1.
7688
7689 =cut
7690 */
7691
7692 SV *
7693 Perl_newSV_type(pTHX_ const svtype type)
7694 {
7695     register SV *sv;
7696
7697     new_SV(sv);
7698     sv_upgrade(sv, type);
7699     return sv;
7700 }
7701
7702 /*
7703 =for apidoc newRV_noinc
7704
7705 Creates an RV wrapper for an SV.  The reference count for the original
7706 SV is B<not> incremented.
7707
7708 =cut
7709 */
7710
7711 SV *
7712 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
7713 {
7714     dVAR;
7715     register SV *sv = newSV_type(SVt_IV);
7716
7717     PERL_ARGS_ASSERT_NEWRV_NOINC;
7718
7719     SvTEMP_off(tmpRef);
7720     SvRV_set(sv, tmpRef);
7721     SvROK_on(sv);
7722     return sv;
7723 }
7724
7725 /* newRV_inc is the official function name to use now.
7726  * newRV_inc is in fact #defined to newRV in sv.h
7727  */
7728
7729 SV *
7730 Perl_newRV(pTHX_ SV *const sv)
7731 {
7732     dVAR;
7733
7734     PERL_ARGS_ASSERT_NEWRV;
7735
7736     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
7737 }
7738
7739 /*
7740 =for apidoc newSVsv
7741
7742 Creates a new SV which is an exact duplicate of the original SV.
7743 (Uses C<sv_setsv>).
7744
7745 =cut
7746 */
7747
7748 SV *
7749 Perl_newSVsv(pTHX_ register SV *const old)
7750 {
7751     dVAR;
7752     register SV *sv;
7753
7754     if (!old)
7755         return NULL;
7756     if (SvTYPE(old) == SVTYPEMASK) {
7757         if (ckWARN_d(WARN_INTERNAL))
7758             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7759         return NULL;
7760     }
7761     new_SV(sv);
7762     /* SV_GMAGIC is the default for sv_setv()
7763        SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7764        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
7765     sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7766     return sv;
7767 }
7768
7769 /*
7770 =for apidoc sv_reset
7771
7772 Underlying implementation for the C<reset> Perl function.
7773 Note that the perl-level function is vaguely deprecated.
7774
7775 =cut
7776 */
7777
7778 void
7779 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
7780 {
7781     dVAR;
7782     char todo[PERL_UCHAR_MAX+1];
7783
7784     PERL_ARGS_ASSERT_SV_RESET;
7785
7786     if (!stash)
7787         return;
7788
7789     if (!*s) {          /* reset ?? searches */
7790         MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7791         if (mg) {
7792             const U32 count = mg->mg_len / sizeof(PMOP**);
7793             PMOP **pmp = (PMOP**) mg->mg_ptr;
7794             PMOP *const *const end = pmp + count;
7795
7796             while (pmp < end) {
7797 #ifdef USE_ITHREADS
7798                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
7799 #else
7800                 (*pmp)->op_pmflags &= ~PMf_USED;
7801 #endif
7802                 ++pmp;
7803             }
7804         }
7805         return;
7806     }
7807
7808     /* reset variables */
7809
7810     if (!HvARRAY(stash))
7811         return;
7812
7813     Zero(todo, 256, char);
7814     while (*s) {
7815         I32 max;
7816         I32 i = (unsigned char)*s;
7817         if (s[1] == '-') {
7818             s += 2;
7819         }
7820         max = (unsigned char)*s++;
7821         for ( ; i <= max; i++) {
7822             todo[i] = 1;
7823         }
7824         for (i = 0; i <= (I32) HvMAX(stash); i++) {
7825             HE *entry;
7826             for (entry = HvARRAY(stash)[i];
7827                  entry;
7828                  entry = HeNEXT(entry))
7829             {
7830                 register GV *gv;
7831                 register SV *sv;
7832
7833                 if (!todo[(U8)*HeKEY(entry)])
7834                     continue;
7835                 gv = (GV*)HeVAL(entry);
7836                 sv = GvSV(gv);
7837                 if (sv) {
7838                     if (SvTHINKFIRST(sv)) {
7839                         if (!SvREADONLY(sv) && SvROK(sv))
7840                             sv_unref(sv);
7841                         /* XXX Is this continue a bug? Why should THINKFIRST
7842                            exempt us from resetting arrays and hashes?  */
7843                         continue;
7844                     }
7845                     SvOK_off(sv);
7846                     if (SvTYPE(sv) >= SVt_PV) {
7847                         SvCUR_set(sv, 0);
7848                         if (SvPVX_const(sv) != NULL)
7849                             *SvPVX(sv) = '\0';
7850                         SvTAINT(sv);
7851                     }
7852                 }
7853                 if (GvAV(gv)) {
7854                     av_clear(GvAV(gv));
7855                 }
7856                 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7857 #if defined(VMS)
7858                     Perl_die(aTHX_ "Can't reset %%ENV on this system");
7859 #else /* ! VMS */
7860                     hv_clear(GvHV(gv));
7861 #  if defined(USE_ENVIRON_ARRAY)
7862                     if (gv == PL_envgv)
7863                         my_clearenv();
7864 #  endif /* USE_ENVIRON_ARRAY */
7865 #endif /* VMS */
7866                 }
7867             }
7868         }
7869     }
7870 }
7871
7872 /*
7873 =for apidoc sv_2io
7874
7875 Using various gambits, try to get an IO from an SV: the IO slot if its a
7876 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7877 named after the PV if we're a string.
7878
7879 =cut
7880 */
7881
7882 IO*
7883 Perl_sv_2io(pTHX_ SV *const sv)
7884 {
7885     IO* io;
7886     GV* gv;
7887
7888     PERL_ARGS_ASSERT_SV_2IO;
7889
7890     switch (SvTYPE(sv)) {
7891     case SVt_PVIO:
7892         io = (IO*)sv;
7893         break;
7894     case SVt_PVGV:
7895         if (isGV_with_GP(sv)) {
7896             gv = (GV*)sv;
7897             io = GvIO(gv);
7898             if (!io)
7899                 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7900             break;
7901         }
7902         /* FALL THROUGH */
7903     default:
7904         if (!SvOK(sv))
7905             Perl_croak(aTHX_ PL_no_usym, "filehandle");
7906         if (SvROK(sv))
7907             return sv_2io(SvRV(sv));
7908         gv = gv_fetchsv(sv, 0, SVt_PVIO);
7909         if (gv)
7910             io = GvIO(gv);
7911         else
7912             io = 0;
7913         if (!io)
7914             Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
7915         break;
7916     }
7917     return io;
7918 }
7919
7920 /*
7921 =for apidoc sv_2cv
7922
7923 Using various gambits, try to get a CV from an SV; in addition, try if
7924 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7925 The flags in C<lref> are passed to sv_fetchsv.
7926
7927 =cut
7928 */
7929
7930 CV *
7931 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
7932 {
7933     dVAR;
7934     GV *gv = NULL;
7935     CV *cv = NULL;
7936
7937     PERL_ARGS_ASSERT_SV_2CV;
7938
7939     if (!sv) {
7940         *st = NULL;
7941         *gvp = NULL;
7942         return NULL;
7943     }
7944     switch (SvTYPE(sv)) {
7945     case SVt_PVCV:
7946         *st = CvSTASH(sv);
7947         *gvp = NULL;
7948         return MUTABLE_CV(sv);
7949     case SVt_PVHV:
7950     case SVt_PVAV:
7951         *st = NULL;
7952         *gvp = NULL;
7953         return NULL;
7954     case SVt_PVGV:
7955         if (isGV_with_GP(sv)) {
7956             gv = (GV*)sv;
7957             *gvp = gv;
7958             *st = GvESTASH(gv);
7959             goto fix_gv;
7960         }
7961         /* FALL THROUGH */
7962
7963     default:
7964         if (SvROK(sv)) {
7965             SV * const *sp = &sv;       /* Used in tryAMAGICunDEREF macro. */
7966             SvGETMAGIC(sv);
7967             tryAMAGICunDEREF(to_cv);
7968
7969             sv = SvRV(sv);
7970             if (SvTYPE(sv) == SVt_PVCV) {
7971                 cv = MUTABLE_CV(sv);
7972                 *gvp = NULL;
7973                 *st = CvSTASH(cv);
7974                 return cv;
7975             }
7976             else if(isGV_with_GP(sv))
7977                 gv = (GV*)sv;
7978             else
7979                 Perl_croak(aTHX_ "Not a subroutine reference");
7980         }
7981         else if (isGV_with_GP(sv)) {
7982             SvGETMAGIC(sv);
7983             gv = (GV*)sv;
7984         }
7985         else
7986             gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
7987         *gvp = gv;
7988         if (!gv) {
7989             *st = NULL;
7990             return NULL;
7991         }
7992         /* Some flags to gv_fetchsv mean don't really create the GV  */
7993         if (!isGV_with_GP(gv)) {
7994             *st = NULL;
7995             return NULL;
7996         }
7997         *st = GvESTASH(gv);
7998     fix_gv:
7999         if (lref && !GvCVu(gv)) {
8000             SV *tmpsv;
8001             ENTER;
8002             tmpsv = newSV(0);
8003             gv_efullname3(tmpsv, gv, NULL);
8004             /* XXX this is probably not what they think they're getting.
8005              * It has the same effect as "sub name;", i.e. just a forward
8006              * declaration! */
8007             newSUB(start_subparse(FALSE, 0),
8008                    newSVOP(OP_CONST, 0, tmpsv),
8009                    NULL, NULL);
8010             LEAVE;
8011             if (!GvCVu(gv))
8012                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8013                            SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8014         }
8015         return GvCVu(gv);
8016     }
8017 }
8018
8019 /*
8020 =for apidoc sv_true
8021
8022 Returns true if the SV has a true value by Perl's rules.
8023 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8024 instead use an in-line version.
8025
8026 =cut
8027 */
8028
8029 I32
8030 Perl_sv_true(pTHX_ register SV *const sv)
8031 {
8032     if (!sv)
8033         return 0;
8034     if (SvPOK(sv)) {
8035         register const XPV* const tXpv = (XPV*)SvANY(sv);
8036         if (tXpv &&
8037                 (tXpv->xpv_cur > 1 ||
8038                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8039             return 1;
8040         else
8041             return 0;
8042     }
8043     else {
8044         if (SvIOK(sv))
8045             return SvIVX(sv) != 0;
8046         else {
8047             if (SvNOK(sv))
8048                 return SvNVX(sv) != 0.0;
8049             else
8050                 return sv_2bool(sv);
8051         }
8052     }
8053 }
8054
8055 /*
8056 =for apidoc sv_pvn_force
8057
8058 Get a sensible string out of the SV somehow.
8059 A private implementation of the C<SvPV_force> macro for compilers which
8060 can't cope with complex macro expressions. Always use the macro instead.
8061
8062 =for apidoc sv_pvn_force_flags
8063
8064 Get a sensible string out of the SV somehow.
8065 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8066 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8067 implemented in terms of this function.
8068 You normally want to use the various wrapper macros instead: see
8069 C<SvPV_force> and C<SvPV_force_nomg>
8070
8071 =cut
8072 */
8073
8074 char *
8075 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8076 {
8077     dVAR;
8078
8079     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8080
8081     if (SvTHINKFIRST(sv) && !SvROK(sv))
8082         sv_force_normal_flags(sv, 0);
8083
8084     if (SvPOK(sv)) {
8085         if (lp)
8086             *lp = SvCUR(sv);
8087     }
8088     else {
8089         char *s;
8090         STRLEN len;
8091
8092         if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8093             const char * const ref = sv_reftype(sv,0);
8094             if (PL_op)
8095                 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8096                            ref, OP_NAME(PL_op));
8097             else
8098                 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8099         }
8100         if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8101             || isGV_with_GP(sv))
8102             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8103                 OP_NAME(PL_op));
8104         s = sv_2pv_flags(sv, &len, flags);
8105         if (lp)
8106             *lp = len;
8107
8108         if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
8109             if (SvROK(sv))
8110                 sv_unref(sv);
8111             SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
8112             SvGROW(sv, len + 1);
8113             Move(s,SvPVX(sv),len,char);
8114             SvCUR_set(sv, len);
8115             SvPVX(sv)[len] = '\0';
8116         }
8117         if (!SvPOK(sv)) {
8118             SvPOK_on(sv);               /* validate pointer */
8119             SvTAINT(sv);
8120             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8121                                   PTR2UV(sv),SvPVX_const(sv)));
8122         }
8123     }
8124     return SvPVX_mutable(sv);
8125 }
8126
8127 /*
8128 =for apidoc sv_pvbyten_force
8129
8130 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8131
8132 =cut
8133 */
8134
8135 char *
8136 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8137 {
8138     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8139
8140     sv_pvn_force(sv,lp);
8141     sv_utf8_downgrade(sv,0);
8142     *lp = SvCUR(sv);
8143     return SvPVX(sv);
8144 }
8145
8146 /*
8147 =for apidoc sv_pvutf8n_force
8148
8149 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8150
8151 =cut
8152 */
8153
8154 char *
8155 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8156 {
8157     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8158
8159     sv_pvn_force(sv,lp);
8160     sv_utf8_upgrade(sv);
8161     *lp = SvCUR(sv);
8162     return SvPVX(sv);
8163 }
8164
8165 /*
8166 =for apidoc sv_reftype
8167
8168 Returns a string describing what the SV is a reference to.
8169
8170 =cut
8171 */
8172
8173 const char *
8174 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8175 {
8176     PERL_ARGS_ASSERT_SV_REFTYPE;
8177
8178     /* The fact that I don't need to downcast to char * everywhere, only in ?:
8179        inside return suggests a const propagation bug in g++.  */
8180     if (ob && SvOBJECT(sv)) {
8181         char * const name = HvNAME_get(SvSTASH(sv));
8182         return name ? name : (char *) "__ANON__";
8183     }
8184     else {
8185         switch (SvTYPE(sv)) {
8186         case SVt_NULL:
8187         case SVt_IV:
8188         case SVt_NV:
8189         case SVt_PV:
8190         case SVt_PVIV:
8191         case SVt_PVNV:
8192         case SVt_PVMG:
8193                                 if (SvVOK(sv))
8194                                     return "VSTRING";
8195                                 if (SvROK(sv))
8196                                     return "REF";
8197                                 else
8198                                     return "SCALAR";
8199
8200         case SVt_PVLV:          return (char *)  (SvROK(sv) ? "REF"
8201                                 /* tied lvalues should appear to be
8202                                  * scalars for backwards compatitbility */
8203                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8204                                     ? "SCALAR" : "LVALUE");
8205         case SVt_PVAV:          return "ARRAY";
8206         case SVt_PVHV:          return "HASH";
8207         case SVt_PVCV:          return "CODE";
8208         case SVt_PVGV:          return (char *) (isGV_with_GP(sv)
8209                                     ? "GLOB" : "SCALAR");
8210         case SVt_PVFM:          return "FORMAT";
8211         case SVt_PVIO:          return "IO";
8212         case SVt_BIND:          return "BIND";
8213         case SVt_REGEXP:        return "REGEXP";
8214         default:                return "UNKNOWN";
8215         }
8216     }
8217 }
8218
8219 /*
8220 =for apidoc sv_isobject
8221
8222 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8223 object.  If the SV is not an RV, or if the object is not blessed, then this
8224 will return false.
8225
8226 =cut
8227 */
8228
8229 int
8230 Perl_sv_isobject(pTHX_ SV *sv)
8231 {
8232     if (!sv)
8233         return 0;
8234     SvGETMAGIC(sv);
8235     if (!SvROK(sv))
8236         return 0;
8237     sv = (SV*)SvRV(sv);
8238     if (!SvOBJECT(sv))
8239         return 0;
8240     return 1;
8241 }
8242
8243 /*
8244 =for apidoc sv_isa
8245
8246 Returns a boolean indicating whether the SV is blessed into the specified
8247 class.  This does not check for subtypes; use C<sv_derived_from> to verify
8248 an inheritance relationship.
8249
8250 =cut
8251 */
8252
8253 int
8254 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8255 {
8256     const char *hvname;
8257
8258     PERL_ARGS_ASSERT_SV_ISA;
8259
8260     if (!sv)
8261         return 0;
8262     SvGETMAGIC(sv);
8263     if (!SvROK(sv))
8264         return 0;
8265     sv = (SV*)SvRV(sv);
8266     if (!SvOBJECT(sv))
8267         return 0;
8268     hvname = HvNAME_get(SvSTASH(sv));
8269     if (!hvname)
8270         return 0;
8271
8272     return strEQ(hvname, name);
8273 }
8274
8275 /*
8276 =for apidoc newSVrv
8277
8278 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
8279 it will be upgraded to one.  If C<classname> is non-null then the new SV will
8280 be blessed in the specified package.  The new SV is returned and its
8281 reference count is 1.
8282
8283 =cut
8284 */
8285
8286 SV*
8287 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8288 {
8289     dVAR;
8290     SV *sv;
8291
8292     PERL_ARGS_ASSERT_NEWSVRV;
8293
8294     new_SV(sv);
8295
8296     SV_CHECK_THINKFIRST_COW_DROP(rv);
8297     (void)SvAMAGIC_off(rv);
8298
8299     if (SvTYPE(rv) >= SVt_PVMG) {
8300         const U32 refcnt = SvREFCNT(rv);
8301         SvREFCNT(rv) = 0;
8302         sv_clear(rv);
8303         SvFLAGS(rv) = 0;
8304         SvREFCNT(rv) = refcnt;
8305
8306         sv_upgrade(rv, SVt_IV);
8307     } else if (SvROK(rv)) {
8308         SvREFCNT_dec(SvRV(rv));
8309     } else {
8310         prepare_SV_for_RV(rv);
8311     }
8312
8313     SvOK_off(rv);
8314     SvRV_set(rv, sv);
8315     SvROK_on(rv);
8316
8317     if (classname) {
8318         HV* const stash = gv_stashpv(classname, GV_ADD);
8319         (void)sv_bless(rv, stash);
8320     }
8321     return sv;
8322 }
8323
8324 /*
8325 =for apidoc sv_setref_pv
8326
8327 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
8328 argument will be upgraded to an RV.  That RV will be modified to point to
8329 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8330 into the SV.  The C<classname> argument indicates the package for the
8331 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8332 will have a reference count of 1, and the RV will be returned.
8333
8334 Do not use with other Perl types such as HV, AV, SV, CV, because those
8335 objects will become corrupted by the pointer copy process.
8336
8337 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8338
8339 =cut
8340 */
8341
8342 SV*
8343 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8344 {
8345     dVAR;
8346
8347     PERL_ARGS_ASSERT_SV_SETREF_PV;
8348
8349     if (!pv) {
8350         sv_setsv(rv, &PL_sv_undef);
8351         SvSETMAGIC(rv);
8352     }
8353     else
8354         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8355     return rv;
8356 }
8357
8358 /*
8359 =for apidoc sv_setref_iv
8360
8361 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
8362 argument will be upgraded to an RV.  That RV will be modified to point to
8363 the new SV.  The C<classname> argument indicates the package for the
8364 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8365 will have a reference count of 1, and the RV will be returned.
8366
8367 =cut
8368 */
8369
8370 SV*
8371 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8372 {
8373     PERL_ARGS_ASSERT_SV_SETREF_IV;
8374
8375     sv_setiv(newSVrv(rv,classname), iv);
8376     return rv;
8377 }
8378
8379 /*
8380 =for apidoc sv_setref_uv
8381
8382 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
8383 argument will be upgraded to an RV.  That RV will be modified to point to
8384 the new SV.  The C<classname> argument indicates the package for the
8385 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8386 will have a reference count of 1, and the RV will be returned.
8387
8388 =cut
8389 */
8390
8391 SV*
8392 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8393 {
8394     PERL_ARGS_ASSERT_SV_SETREF_UV;
8395
8396     sv_setuv(newSVrv(rv,classname), uv);
8397     return rv;
8398 }
8399
8400 /*
8401 =for apidoc sv_setref_nv
8402
8403 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
8404 argument will be upgraded to an RV.  That RV will be modified to point to
8405 the new SV.  The C<classname> argument indicates the package for the
8406 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8407 will have a reference count of 1, and the RV will be returned.
8408
8409 =cut
8410 */
8411
8412 SV*
8413 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8414 {
8415     PERL_ARGS_ASSERT_SV_SETREF_NV;
8416
8417     sv_setnv(newSVrv(rv,classname), nv);
8418     return rv;
8419 }
8420
8421 /*
8422 =for apidoc sv_setref_pvn
8423
8424 Copies a string into a new SV, optionally blessing the SV.  The length of the
8425 string must be specified with C<n>.  The C<rv> argument will be upgraded to
8426 an RV.  That RV will be modified to point to the new SV.  The C<classname>
8427 argument indicates the package for the blessing.  Set C<classname> to
8428 C<NULL> to avoid the blessing.  The new SV will have a reference count
8429 of 1, and the RV will be returned.
8430
8431 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8432
8433 =cut
8434 */
8435
8436 SV*
8437 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8438                    const char *const pv, const STRLEN n)
8439 {
8440     PERL_ARGS_ASSERT_SV_SETREF_PVN;
8441
8442     sv_setpvn(newSVrv(rv,classname), pv, n);
8443     return rv;
8444 }
8445
8446 /*
8447 =for apidoc sv_bless
8448
8449 Blesses an SV into a specified package.  The SV must be an RV.  The package
8450 must be designated by its stash (see C<gv_stashpv()>).  The reference count
8451 of the SV is unaffected.
8452
8453 =cut
8454 */
8455
8456 SV*
8457 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8458 {
8459     dVAR;
8460     SV *tmpRef;
8461
8462     PERL_ARGS_ASSERT_SV_BLESS;
8463
8464     if (!SvROK(sv))
8465         Perl_croak(aTHX_ "Can't bless non-reference value");
8466     tmpRef = SvRV(sv);
8467     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8468         if (SvIsCOW(tmpRef))
8469             sv_force_normal_flags(tmpRef, 0);
8470         if (SvREADONLY(tmpRef))
8471             Perl_croak(aTHX_ PL_no_modify);
8472         if (SvOBJECT(tmpRef)) {
8473             if (SvTYPE(tmpRef) != SVt_PVIO)
8474                 --PL_sv_objcount;
8475             SvREFCNT_dec(SvSTASH(tmpRef));
8476         }
8477     }
8478     SvOBJECT_on(tmpRef);
8479     if (SvTYPE(tmpRef) != SVt_PVIO)
8480         ++PL_sv_objcount;
8481     SvUPGRADE(tmpRef, SVt_PVMG);
8482     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8483
8484     if (Gv_AMG(stash))
8485         SvAMAGIC_on(sv);
8486     else
8487         (void)SvAMAGIC_off(sv);
8488
8489     if(SvSMAGICAL(tmpRef))
8490         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8491             mg_set(tmpRef);
8492
8493
8494
8495     return sv;
8496 }
8497
8498 /* Downgrades a PVGV to a PVMG.
8499  */
8500
8501 STATIC void
8502 S_sv_unglob(pTHX_ SV *const sv)
8503 {
8504     dVAR;
8505     void *xpvmg;
8506     HV *stash;
8507     SV * const temp = sv_newmortal();
8508
8509     PERL_ARGS_ASSERT_SV_UNGLOB;
8510
8511     assert(SvTYPE(sv) == SVt_PVGV);
8512     SvFAKE_off(sv);
8513     gv_efullname3(temp, (GV *) sv, "*");
8514
8515     if (GvGP(sv)) {
8516         if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
8517             mro_method_changed_in(stash);
8518         gp_free((GV*)sv);
8519     }
8520     if (GvSTASH(sv)) {
8521         sv_del_backref((SV*)GvSTASH(sv), sv);
8522         GvSTASH(sv) = NULL;
8523     }
8524     GvMULTI_off(sv);
8525     if (GvNAME_HEK(sv)) {
8526         unshare_hek(GvNAME_HEK(sv));
8527     }
8528     isGV_with_GP_off(sv);
8529
8530     /* need to keep SvANY(sv) in the right arena */
8531     xpvmg = new_XPVMG();
8532     StructCopy(SvANY(sv), xpvmg, XPVMG);
8533     del_XPVGV(SvANY(sv));
8534     SvANY(sv) = xpvmg;
8535
8536     SvFLAGS(sv) &= ~SVTYPEMASK;
8537     SvFLAGS(sv) |= SVt_PVMG;
8538
8539     /* Intentionally not calling any local SET magic, as this isn't so much a
8540        set operation as merely an internal storage change.  */
8541     sv_setsv_flags(sv, temp, 0);
8542 }
8543
8544 /*
8545 =for apidoc sv_unref_flags
8546
8547 Unsets the RV status of the SV, and decrements the reference count of
8548 whatever was being referenced by the RV.  This can almost be thought of
8549 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
8550 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8551 (otherwise the decrementing is conditional on the reference count being
8552 different from one or the reference being a readonly SV).
8553 See C<SvROK_off>.
8554
8555 =cut
8556 */
8557
8558 void
8559 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8560 {
8561     SV* const target = SvRV(ref);
8562
8563     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8564
8565     if (SvWEAKREF(ref)) {
8566         sv_del_backref(target, ref);
8567         SvWEAKREF_off(ref);
8568         SvRV_set(ref, NULL);
8569         return;
8570     }
8571     SvRV_set(ref, NULL);
8572     SvROK_off(ref);
8573     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8574        assigned to as BEGIN {$a = \"Foo"} will fail.  */
8575     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8576         SvREFCNT_dec(target);
8577     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8578         sv_2mortal(target);     /* Schedule for freeing later */
8579 }
8580
8581 /*
8582 =for apidoc sv_untaint
8583
8584 Untaint an SV. Use C<SvTAINTED_off> instead.
8585 =cut
8586 */
8587
8588 void
8589 Perl_sv_untaint(pTHX_ SV *const sv)
8590 {
8591     PERL_ARGS_ASSERT_SV_UNTAINT;
8592
8593     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8594         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8595         if (mg)
8596             mg->mg_len &= ~1;
8597     }
8598 }
8599
8600 /*
8601 =for apidoc sv_tainted
8602
8603 Test an SV for taintedness. Use C<SvTAINTED> instead.
8604 =cut
8605 */
8606
8607 bool
8608 Perl_sv_tainted(pTHX_ SV *const sv)
8609 {
8610     PERL_ARGS_ASSERT_SV_TAINTED;
8611
8612     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8613         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8614         if (mg && (mg->mg_len & 1) )
8615             return TRUE;
8616     }
8617     return FALSE;
8618 }
8619
8620 /*
8621 =for apidoc sv_setpviv
8622
8623 Copies an integer into the given SV, also updating its string value.
8624 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
8625
8626 =cut
8627 */
8628
8629 void
8630 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8631 {
8632     char buf[TYPE_CHARS(UV)];
8633     char *ebuf;
8634     char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8635
8636     PERL_ARGS_ASSERT_SV_SETPVIV;
8637
8638     sv_setpvn(sv, ptr, ebuf - ptr);
8639 }
8640
8641 /*
8642 =for apidoc sv_setpviv_mg
8643
8644 Like C<sv_setpviv>, but also handles 'set' magic.
8645
8646 =cut
8647 */
8648
8649 void
8650 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8651 {
8652     PERL_ARGS_ASSERT_SV_SETPVIV_MG;
8653
8654     sv_setpviv(sv, iv);
8655     SvSETMAGIC(sv);
8656 }
8657
8658 #if defined(PERL_IMPLICIT_CONTEXT)
8659
8660 /* pTHX_ magic can't cope with varargs, so this is a no-context
8661  * version of the main function, (which may itself be aliased to us).
8662  * Don't access this version directly.
8663  */
8664
8665 void
8666 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
8667 {
8668     dTHX;
8669     va_list args;
8670
8671     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
8672
8673     va_start(args, pat);
8674     sv_vsetpvf(sv, pat, &args);
8675     va_end(args);
8676 }
8677
8678 /* pTHX_ magic can't cope with varargs, so this is a no-context
8679  * version of the main function, (which may itself be aliased to us).
8680  * Don't access this version directly.
8681  */
8682
8683 void
8684 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8685 {
8686     dTHX;
8687     va_list args;
8688
8689     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
8690
8691     va_start(args, pat);
8692     sv_vsetpvf_mg(sv, pat, &args);
8693     va_end(args);
8694 }
8695 #endif
8696
8697 /*
8698 =for apidoc sv_setpvf
8699
8700 Works like C<sv_catpvf> but copies the text into the SV instead of
8701 appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
8702
8703 =cut
8704 */
8705
8706 void
8707 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
8708 {
8709     va_list args;
8710
8711     PERL_ARGS_ASSERT_SV_SETPVF;
8712
8713     va_start(args, pat);
8714     sv_vsetpvf(sv, pat, &args);
8715     va_end(args);
8716 }
8717
8718 /*
8719 =for apidoc sv_vsetpvf
8720
8721 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8722 appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
8723
8724 Usually used via its frontend C<sv_setpvf>.
8725
8726 =cut
8727 */
8728
8729 void
8730 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8731 {
8732     PERL_ARGS_ASSERT_SV_VSETPVF;
8733
8734     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8735 }
8736
8737 /*
8738 =for apidoc sv_setpvf_mg
8739
8740 Like C<sv_setpvf>, but also handles 'set' magic.
8741
8742 =cut
8743 */
8744
8745 void
8746 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8747 {
8748     va_list args;
8749
8750     PERL_ARGS_ASSERT_SV_SETPVF_MG;
8751
8752     va_start(args, pat);
8753     sv_vsetpvf_mg(sv, pat, &args);
8754     va_end(args);
8755 }
8756
8757 /*
8758 =for apidoc sv_vsetpvf_mg
8759
8760 Like C<sv_vsetpvf>, but also handles 'set' magic.
8761
8762 Usually used via its frontend C<sv_setpvf_mg>.
8763
8764 =cut
8765 */
8766
8767 void
8768 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8769 {
8770     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
8771
8772     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8773     SvSETMAGIC(sv);
8774 }
8775
8776 #if defined(PERL_IMPLICIT_CONTEXT)
8777
8778 /* pTHX_ magic can't cope with varargs, so this is a no-context
8779  * version of the main function, (which may itself be aliased to us).
8780  * Don't access this version directly.
8781  */
8782
8783 void
8784 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
8785 {
8786     dTHX;
8787     va_list args;
8788
8789     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
8790
8791     va_start(args, pat);
8792     sv_vcatpvf(sv, pat, &args);
8793     va_end(args);
8794 }
8795
8796 /* pTHX_ magic can't cope with varargs, so this is a no-context
8797  * version of the main function, (which may itself be aliased to us).
8798  * Don't access this version directly.
8799  */
8800
8801 void
8802 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8803 {
8804     dTHX;
8805     va_list args;
8806
8807     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
8808
8809     va_start(args, pat);
8810     sv_vcatpvf_mg(sv, pat, &args);
8811     va_end(args);
8812 }
8813 #endif
8814
8815 /*
8816 =for apidoc sv_catpvf
8817
8818 Processes its arguments like C<sprintf> and appends the formatted
8819 output to an SV.  If the appended data contains "wide" characters
8820 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8821 and characters >255 formatted with %c), the original SV might get
8822 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
8823 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8824 valid UTF-8; if the original SV was bytes, the pattern should be too.
8825
8826 =cut */
8827
8828 void
8829 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
8830 {
8831     va_list args;
8832
8833     PERL_ARGS_ASSERT_SV_CATPVF;
8834
8835     va_start(args, pat);
8836     sv_vcatpvf(sv, pat, &args);
8837     va_end(args);
8838 }
8839
8840 /*
8841 =for apidoc sv_vcatpvf
8842
8843 Processes its arguments like C<vsprintf> and appends the formatted output
8844 to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
8845
8846 Usually used via its frontend C<sv_catpvf>.
8847
8848 =cut
8849 */
8850
8851 void
8852 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8853 {
8854     PERL_ARGS_ASSERT_SV_VCATPVF;
8855
8856     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8857 }
8858
8859 /*
8860 =for apidoc sv_catpvf_mg
8861
8862 Like C<sv_catpvf>, but also handles 'set' magic.
8863
8864 =cut
8865 */
8866
8867 void
8868 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8869 {
8870     va_list args;
8871
8872     PERL_ARGS_ASSERT_SV_CATPVF_MG;
8873
8874     va_start(args, pat);
8875     sv_vcatpvf_mg(sv, pat, &args);
8876     va_end(args);
8877 }
8878
8879 /*
8880 =for apidoc sv_vcatpvf_mg
8881
8882 Like C<sv_vcatpvf>, but also handles 'set' magic.
8883
8884 Usually used via its frontend C<sv_catpvf_mg>.
8885
8886 =cut
8887 */
8888
8889 void
8890 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8891 {
8892     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
8893
8894     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8895     SvSETMAGIC(sv);
8896 }
8897
8898 /*
8899 =for apidoc sv_vsetpvfn
8900
8901 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8902 appending it.
8903
8904 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8905
8906 =cut
8907 */
8908
8909 void
8910 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
8911                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
8912 {
8913     PERL_ARGS_ASSERT_SV_VSETPVFN;
8914
8915     sv_setpvn(sv, "", 0);
8916     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8917 }
8918
8919 STATIC I32
8920 S_expect_number(pTHX_ char **const pattern)
8921 {
8922     dVAR;
8923     I32 var = 0;
8924
8925     PERL_ARGS_ASSERT_EXPECT_NUMBER;
8926
8927     switch (**pattern) {
8928     case '1': case '2': case '3':
8929     case '4': case '5': case '6':
8930     case '7': case '8': case '9':
8931         var = *(*pattern)++ - '0';
8932         while (isDIGIT(**pattern)) {
8933             const I32 tmp = var * 10 + (*(*pattern)++ - '0');
8934             if (tmp < var)
8935                 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
8936             var = tmp;
8937         }
8938     }
8939     return var;
8940 }
8941
8942 STATIC char *
8943 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
8944 {
8945     const int neg = nv < 0;
8946     UV uv;
8947
8948     PERL_ARGS_ASSERT_F0CONVERT;
8949
8950     if (neg)
8951         nv = -nv;
8952     if (nv < UV_MAX) {
8953         char *p = endbuf;
8954         nv += 0.5;
8955         uv = (UV)nv;
8956         if (uv & 1 && uv == nv)
8957             uv--;                       /* Round to even */
8958         do {
8959             const unsigned dig = uv % 10;
8960             *--p = '0' + dig;
8961         } while (uv /= 10);
8962         if (neg)
8963             *--p = '-';
8964         *len = endbuf - p;
8965         return p;
8966     }
8967     return NULL;
8968 }
8969
8970
8971 /*
8972 =for apidoc sv_vcatpvfn
8973
8974 Processes its arguments like C<vsprintf> and appends the formatted output
8975 to an SV.  Uses an array of SVs if the C style variable argument list is
8976 missing (NULL).  When running with taint checks enabled, indicates via
8977 C<maybe_tainted> if results are untrustworthy (often due to the use of
8978 locales).
8979
8980 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8981
8982 =cut
8983 */
8984
8985
8986 #define VECTORIZE_ARGS  vecsv = va_arg(*args, SV*);\
8987                         vecstr = (U8*)SvPV_const(vecsv,veclen);\
8988                         vec_utf8 = DO_UTF8(vecsv);
8989
8990 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8991
8992 void
8993 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
8994                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
8995 {
8996     dVAR;
8997     char *p;
8998     char *q;
8999     const char *patend;
9000     STRLEN origlen;
9001     I32 svix = 0;
9002     static const char nullstr[] = "(null)";
9003     SV *argsv = NULL;
9004     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
9005     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9006     SV *nsv = NULL;
9007     /* Times 4: a decimal digit takes more than 3 binary digits.
9008      * NV_DIG: mantissa takes than many decimal digits.
9009      * Plus 32: Playing safe. */
9010     char ebuf[IV_DIG * 4 + NV_DIG + 32];
9011     /* large enough for "%#.#f" --chip */
9012     /* what about long double NVs? --jhi */
9013
9014     PERL_ARGS_ASSERT_SV_VCATPVFN;
9015     PERL_UNUSED_ARG(maybe_tainted);
9016
9017     /* no matter what, this is a string now */
9018     (void)SvPV_force(sv, origlen);
9019
9020     /* special-case "", "%s", and "%-p" (SVf - see below) */
9021     if (patlen == 0)
9022         return;
9023     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9024         if (args) {
9025             const char * const s = va_arg(*args, char*);
9026             sv_catpv(sv, s ? s : nullstr);
9027         }
9028         else if (svix < svmax) {
9029             sv_catsv(sv, *svargs);
9030         }
9031         return;
9032     }
9033     if (args && patlen == 3 && pat[0] == '%' &&
9034                 pat[1] == '-' && pat[2] == 'p') {
9035         argsv = (SV*)va_arg(*args, void*);
9036         sv_catsv(sv, argsv);
9037         return;
9038     }
9039
9040 #ifndef USE_LONG_DOUBLE
9041     /* special-case "%.<number>[gf]" */
9042     if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9043          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9044         unsigned digits = 0;
9045         const char *pp;
9046
9047         pp = pat + 2;
9048         while (*pp >= '0' && *pp <= '9')
9049             digits = 10 * digits + (*pp++ - '0');
9050         if (pp - pat == (int)patlen - 1) {
9051             NV nv;
9052
9053             if (svix < svmax)
9054                 nv = SvNV(*svargs);
9055             else
9056                 return;
9057             if (*pp == 'g') {
9058                 /* Add check for digits != 0 because it seems that some
9059                    gconverts are buggy in this case, and we don't yet have
9060                    a Configure test for this.  */
9061                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9062                      /* 0, point, slack */
9063                     Gconvert(nv, (int)digits, 0, ebuf);
9064                     sv_catpv(sv, ebuf);
9065                     if (*ebuf)  /* May return an empty string for digits==0 */
9066                         return;
9067                 }
9068             } else if (!digits) {
9069                 STRLEN l;
9070
9071                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9072                     sv_catpvn(sv, p, l);
9073                     return;
9074                 }
9075             }
9076         }
9077     }
9078 #endif /* !USE_LONG_DOUBLE */
9079
9080     if (!args && svix < svmax && DO_UTF8(*svargs))
9081         has_utf8 = TRUE;
9082
9083     patend = (char*)pat + patlen;
9084     for (p = (char*)pat; p < patend; p = q) {
9085         bool alt = FALSE;
9086         bool left = FALSE;
9087         bool vectorize = FALSE;
9088         bool vectorarg = FALSE;
9089         bool vec_utf8 = FALSE;
9090         char fill = ' ';
9091         char plus = 0;
9092         char intsize = 0;
9093         STRLEN width = 0;
9094         STRLEN zeros = 0;
9095         bool has_precis = FALSE;
9096         STRLEN precis = 0;
9097         const I32 osvix = svix;
9098         bool is_utf8 = FALSE;  /* is this item utf8?   */
9099 #ifdef HAS_LDBL_SPRINTF_BUG
9100         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9101            with sfio - Allen <allens@cpan.org> */
9102         bool fix_ldbl_sprintf_bug = FALSE;
9103 #endif
9104
9105         char esignbuf[4];
9106         U8 utf8buf[UTF8_MAXBYTES+1];
9107         STRLEN esignlen = 0;
9108
9109         const char *eptr = NULL;
9110         STRLEN elen = 0;
9111         SV *vecsv = NULL;
9112         const U8 *vecstr = NULL;
9113         STRLEN veclen = 0;
9114         char c = 0;
9115         int i;
9116         unsigned base = 0;
9117         IV iv = 0;
9118         UV uv = 0;
9119         /* we need a long double target in case HAS_LONG_DOUBLE but
9120            not USE_LONG_DOUBLE
9121         */
9122 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9123         long double nv;
9124 #else
9125         NV nv;
9126 #endif
9127         STRLEN have;
9128         STRLEN need;
9129         STRLEN gap;
9130         const char *dotstr = ".";
9131         STRLEN dotstrlen = 1;
9132         I32 efix = 0; /* explicit format parameter index */
9133         I32 ewix = 0; /* explicit width index */
9134         I32 epix = 0; /* explicit precision index */
9135         I32 evix = 0; /* explicit vector index */
9136         bool asterisk = FALSE;
9137
9138         /* echo everything up to the next format specification */
9139         for (q = p; q < patend && *q != '%'; ++q) ;
9140         if (q > p) {
9141             if (has_utf8 && !pat_utf8)
9142                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9143             else
9144                 sv_catpvn(sv, p, q - p);
9145             p = q;
9146         }
9147         if (q++ >= patend)
9148             break;
9149
9150 /*
9151     We allow format specification elements in this order:
9152         \d+\$              explicit format parameter index
9153         [-+ 0#]+           flags
9154         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
9155         0                  flag (as above): repeated to allow "v02"
9156         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
9157         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9158         [hlqLV]            size
9159     [%bcdefginopsuxDFOUX] format (mandatory)
9160 */
9161
9162         if (args) {
9163 /*
9164         As of perl5.9.3, printf format checking is on by default.
9165         Internally, perl uses %p formats to provide an escape to
9166         some extended formatting.  This block deals with those
9167         extensions: if it does not match, (char*)q is reset and
9168         the normal format processing code is used.
9169
9170         Currently defined extensions are:
9171                 %p              include pointer address (standard)
9172                 %-p     (SVf)   include an SV (previously %_)
9173                 %-<num>p        include an SV with precision <num>
9174                 %<num>p         reserved for future extensions
9175
9176         Robin Barker 2005-07-14
9177
9178                 %1p     (VDf)   removed.  RMB 2007-10-19
9179 */
9180             char* r = q;
9181             bool sv = FALSE;
9182             STRLEN n = 0;
9183             if (*q == '-')
9184                 sv = *q++;
9185             n = expect_number(&q);
9186             if (*q++ == 'p') {
9187                 if (sv) {                       /* SVf */
9188                     if (n) {
9189                         precis = n;
9190                         has_precis = TRUE;
9191                     }
9192                     argsv = (SV*)va_arg(*args, void*);
9193                     eptr = SvPV_const(argsv, elen);
9194                     if (DO_UTF8(argsv))
9195                         is_utf8 = TRUE;
9196                     goto string;
9197                 }
9198                 else if (n) {
9199                     if (ckWARN_d(WARN_INTERNAL))
9200                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9201                         "internal %%<num>p might conflict with future printf extensions");
9202                 }
9203             }
9204             q = r;
9205         }
9206
9207         if ( (width = expect_number(&q)) ) {
9208             if (*q == '$') {
9209                 ++q;
9210                 efix = width;
9211             } else {
9212                 goto gotwidth;
9213             }
9214         }
9215
9216         /* FLAGS */
9217
9218         while (*q) {
9219             switch (*q) {
9220             case ' ':
9221             case '+':
9222                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9223                     q++;
9224                 else
9225                     plus = *q++;
9226                 continue;
9227
9228             case '-':
9229                 left = TRUE;
9230                 q++;
9231                 continue;
9232
9233             case '0':
9234                 fill = *q++;
9235                 continue;
9236
9237             case '#':
9238                 alt = TRUE;
9239                 q++;
9240                 continue;
9241
9242             default:
9243                 break;
9244             }
9245             break;
9246         }
9247
9248       tryasterisk:
9249         if (*q == '*') {
9250             q++;
9251             if ( (ewix = expect_number(&q)) )
9252                 if (*q++ != '$')
9253                     goto unknown;
9254             asterisk = TRUE;
9255         }
9256         if (*q == 'v') {
9257             q++;
9258             if (vectorize)
9259                 goto unknown;
9260             if ((vectorarg = asterisk)) {
9261                 evix = ewix;
9262                 ewix = 0;
9263                 asterisk = FALSE;
9264             }
9265             vectorize = TRUE;
9266             goto tryasterisk;
9267         }
9268
9269         if (!asterisk)
9270         {
9271             if( *q == '0' )
9272                 fill = *q++;
9273             width = expect_number(&q);
9274         }
9275
9276         if (vectorize) {
9277             if (vectorarg) {
9278                 if (args)
9279                     vecsv = va_arg(*args, SV*);
9280                 else if (evix) {
9281                     vecsv = (evix > 0 && evix <= svmax)
9282                         ? svargs[evix-1] : &PL_sv_undef;
9283                 } else {
9284                     vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
9285                 }
9286                 dotstr = SvPV_const(vecsv, dotstrlen);
9287                 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9288                    bad with tied or overloaded values that return UTF8.  */
9289                 if (DO_UTF8(vecsv))
9290                     is_utf8 = TRUE;
9291                 else if (has_utf8) {
9292                     vecsv = sv_mortalcopy(vecsv);
9293                     sv_utf8_upgrade(vecsv);
9294                     dotstr = SvPV_const(vecsv, dotstrlen);
9295                     is_utf8 = TRUE;
9296                 }
9297             }
9298             if (args) {
9299                 VECTORIZE_ARGS
9300             }
9301             else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9302                 vecsv = svargs[efix ? efix-1 : svix++];
9303                 vecstr = (U8*)SvPV_const(vecsv,veclen);
9304                 vec_utf8 = DO_UTF8(vecsv);
9305
9306                 /* if this is a version object, we need to convert
9307                  * back into v-string notation and then let the
9308                  * vectorize happen normally
9309                  */
9310                 if (sv_derived_from(vecsv, "version")) {
9311                     char *version = savesvpv(vecsv);
9312                     if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9313                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9314                         "vector argument not supported with alpha versions");
9315                         goto unknown;
9316                     }
9317                     vecsv = sv_newmortal();
9318                     scan_vstring(version, version + veclen, vecsv);
9319                     vecstr = (U8*)SvPV_const(vecsv, veclen);
9320                     vec_utf8 = DO_UTF8(vecsv);
9321                     Safefree(version);
9322                 }
9323             }
9324             else {
9325                 vecstr = (U8*)"";
9326                 veclen = 0;
9327             }
9328         }
9329
9330         if (asterisk) {
9331             if (args)
9332                 i = va_arg(*args, int);
9333             else
9334                 i = (ewix ? ewix <= svmax : svix < svmax) ?
9335                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9336             left |= (i < 0);
9337             width = (i < 0) ? -i : i;
9338         }
9339       gotwidth:
9340
9341         /* PRECISION */
9342
9343         if (*q == '.') {
9344             q++;
9345             if (*q == '*') {
9346                 q++;
9347                 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9348                     goto unknown;
9349                 /* XXX: todo, support specified precision parameter */
9350                 if (epix)
9351                     goto unknown;
9352                 if (args)
9353                     i = va_arg(*args, int);
9354                 else
9355                     i = (ewix ? ewix <= svmax : svix < svmax)
9356                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9357                 precis = i;
9358                 has_precis = !(i < 0);
9359             }
9360             else {
9361                 precis = 0;
9362                 while (isDIGIT(*q))
9363                     precis = precis * 10 + (*q++ - '0');
9364                 has_precis = TRUE;
9365             }
9366         }
9367
9368         /* SIZE */
9369
9370         switch (*q) {
9371 #ifdef WIN32
9372         case 'I':                       /* Ix, I32x, and I64x */
9373 #  ifdef WIN64
9374             if (q[1] == '6' && q[2] == '4') {
9375                 q += 3;
9376                 intsize = 'q';
9377                 break;
9378             }
9379 #  endif
9380             if (q[1] == '3' && q[2] == '2') {
9381                 q += 3;
9382                 break;
9383             }
9384 #  ifdef WIN64
9385             intsize = 'q';
9386 #  endif
9387             q++;
9388             break;
9389 #endif
9390 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9391         case 'L':                       /* Ld */
9392             /*FALLTHROUGH*/
9393 #ifdef HAS_QUAD
9394         case 'q':                       /* qd */
9395 #endif
9396             intsize = 'q';
9397             q++;
9398             break;
9399 #endif
9400         case 'l':
9401 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9402             if (*(q + 1) == 'l') {      /* lld, llf */
9403                 intsize = 'q';
9404                 q += 2;
9405                 break;
9406              }
9407 #endif
9408             /*FALLTHROUGH*/
9409         case 'h':
9410             /*FALLTHROUGH*/
9411         case 'V':
9412             intsize = *q++;
9413             break;
9414         }
9415
9416         /* CONVERSION */
9417
9418         if (*q == '%') {
9419             eptr = q++;
9420             elen = 1;
9421             if (vectorize) {
9422                 c = '%';
9423                 goto unknown;
9424             }
9425             goto string;
9426         }
9427
9428         if (!vectorize && !args) {
9429             if (efix) {
9430                 const I32 i = efix-1;
9431                 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
9432             } else {
9433                 argsv = (svix >= 0 && svix < svmax)
9434                     ? svargs[svix++] : &PL_sv_undef;
9435             }
9436         }
9437
9438         switch (c = *q++) {
9439
9440             /* STRINGS */
9441
9442         case 'c':
9443             if (vectorize)
9444                 goto unknown;
9445             uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9446             if ((uv > 255 ||
9447                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9448                 && !IN_BYTES) {
9449                 eptr = (char*)utf8buf;
9450                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9451                 is_utf8 = TRUE;
9452             }
9453             else {
9454                 c = (char)uv;
9455                 eptr = &c;
9456                 elen = 1;
9457             }
9458             goto string;
9459
9460         case 's':
9461             if (vectorize)
9462                 goto unknown;
9463             if (args) {
9464                 eptr = va_arg(*args, char*);
9465                 if (eptr)
9466 #ifdef MACOS_TRADITIONAL
9467                   /* On MacOS, %#s format is used for Pascal strings */
9468                   if (alt)
9469                     elen = *eptr++;
9470                   else
9471 #endif
9472                     elen = strlen(eptr);
9473                 else {
9474                     eptr = (char *)nullstr;
9475                     elen = sizeof nullstr - 1;
9476                 }
9477             }
9478             else {
9479                 eptr = SvPV_const(argsv, elen);
9480                 if (DO_UTF8(argsv)) {
9481                     I32 old_precis = precis;
9482                     if (has_precis && precis < elen) {
9483                         I32 p = precis;
9484                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9485                         precis = p;
9486                     }
9487                     if (width) { /* fudge width (can't fudge elen) */
9488                         if (has_precis && precis < elen)
9489                             width += precis - old_precis;
9490                         else
9491                             width += elen - sv_len_utf8(argsv);
9492                     }
9493                     is_utf8 = TRUE;
9494                 }
9495             }
9496
9497         string:
9498             if (has_precis && elen > precis)
9499                 elen = precis;
9500             break;
9501
9502             /* INTEGERS */
9503
9504         case 'p':
9505             if (alt || vectorize)
9506                 goto unknown;
9507             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9508             base = 16;
9509             goto integer;
9510
9511         case 'D':
9512 #ifdef IV_IS_QUAD
9513             intsize = 'q';
9514 #else
9515             intsize = 'l';
9516 #endif
9517             /*FALLTHROUGH*/
9518         case 'd':
9519         case 'i':
9520 #if vdNUMBER
9521         format_vd:
9522 #endif
9523             if (vectorize) {
9524                 STRLEN ulen;
9525                 if (!veclen)
9526                     continue;
9527                 if (vec_utf8)
9528                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9529                                         UTF8_ALLOW_ANYUV);
9530                 else {
9531                     uv = *vecstr;
9532                     ulen = 1;
9533                 }
9534                 vecstr += ulen;
9535                 veclen -= ulen;
9536                 if (plus)
9537                      esignbuf[esignlen++] = plus;
9538             }
9539             else if (args) {
9540                 switch (intsize) {
9541                 case 'h':       iv = (short)va_arg(*args, int); break;
9542                 case 'l':       iv = va_arg(*args, long); break;
9543                 case 'V':       iv = va_arg(*args, IV); break;
9544                 default:        iv = va_arg(*args, int); break;
9545 #ifdef HAS_QUAD
9546                 case 'q':       iv = va_arg(*args, Quad_t); break;
9547 #endif
9548                 }
9549             }
9550             else {
9551                 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9552                 switch (intsize) {
9553                 case 'h':       iv = (short)tiv; break;
9554                 case 'l':       iv = (long)tiv; break;
9555                 case 'V':
9556                 default:        iv = tiv; break;
9557 #ifdef HAS_QUAD
9558                 case 'q':       iv = (Quad_t)tiv; break;
9559 #endif
9560                 }
9561             }
9562             if ( !vectorize )   /* we already set uv above */
9563             {
9564                 if (iv >= 0) {
9565                     uv = iv;
9566                     if (plus)
9567                         esignbuf[esignlen++] = plus;
9568                 }
9569                 else {
9570                     uv = -iv;
9571                     esignbuf[esignlen++] = '-';
9572                 }
9573             }
9574             base = 10;
9575             goto integer;
9576
9577         case 'U':
9578 #ifdef IV_IS_QUAD
9579             intsize = 'q';
9580 #else
9581             intsize = 'l';
9582 #endif
9583             /*FALLTHROUGH*/
9584         case 'u':
9585             base = 10;
9586             goto uns_integer;
9587
9588         case 'B':
9589         case 'b':
9590             base = 2;
9591             goto uns_integer;
9592
9593         case 'O':
9594 #ifdef IV_IS_QUAD
9595             intsize = 'q';
9596 #else
9597             intsize = 'l';
9598 #endif
9599             /*FALLTHROUGH*/
9600         case 'o':
9601             base = 8;
9602             goto uns_integer;
9603
9604         case 'X':
9605         case 'x':
9606             base = 16;
9607
9608         uns_integer:
9609             if (vectorize) {
9610                 STRLEN ulen;
9611         vector:
9612                 if (!veclen)
9613                     continue;
9614                 if (vec_utf8)
9615                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9616                                         UTF8_ALLOW_ANYUV);
9617                 else {
9618                     uv = *vecstr;
9619                     ulen = 1;
9620                 }
9621                 vecstr += ulen;
9622                 veclen -= ulen;
9623             }
9624             else if (args) {
9625                 switch (intsize) {
9626                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
9627                 case 'l':  uv = va_arg(*args, unsigned long); break;
9628                 case 'V':  uv = va_arg(*args, UV); break;
9629                 default:   uv = va_arg(*args, unsigned); break;
9630 #ifdef HAS_QUAD
9631                 case 'q':  uv = va_arg(*args, Uquad_t); break;
9632 #endif
9633                 }
9634             }
9635             else {
9636                 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9637                 switch (intsize) {
9638                 case 'h':       uv = (unsigned short)tuv; break;
9639                 case 'l':       uv = (unsigned long)tuv; break;
9640                 case 'V':
9641                 default:        uv = tuv; break;
9642 #ifdef HAS_QUAD
9643                 case 'q':       uv = (Uquad_t)tuv; break;
9644 #endif
9645                 }
9646             }
9647
9648         integer:
9649             {
9650                 char *ptr = ebuf + sizeof ebuf;
9651                 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
9652                 zeros = 0;
9653
9654                 switch (base) {
9655                     unsigned dig;
9656                 case 16:
9657                     p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
9658                     do {
9659                         dig = uv & 15;
9660                         *--ptr = p[dig];
9661                     } while (uv >>= 4);
9662                     if (tempalt) {
9663                         esignbuf[esignlen++] = '0';
9664                         esignbuf[esignlen++] = c;  /* 'x' or 'X' */
9665                     }
9666                     break;
9667                 case 8:
9668                     do {
9669                         dig = uv & 7;
9670                         *--ptr = '0' + dig;
9671                     } while (uv >>= 3);
9672                     if (alt && *ptr != '0')
9673                         *--ptr = '0';
9674                     break;
9675                 case 2:
9676                     do {
9677                         dig = uv & 1;
9678                         *--ptr = '0' + dig;
9679                     } while (uv >>= 1);
9680                     if (tempalt) {
9681                         esignbuf[esignlen++] = '0';
9682                         esignbuf[esignlen++] = c;
9683                     }
9684                     break;
9685                 default:                /* it had better be ten or less */
9686                     do {
9687                         dig = uv % base;
9688                         *--ptr = '0' + dig;
9689                     } while (uv /= base);
9690                     break;
9691                 }
9692                 elen = (ebuf + sizeof ebuf) - ptr;
9693                 eptr = ptr;
9694                 if (has_precis) {
9695                     if (precis > elen)
9696                         zeros = precis - elen;
9697                     else if (precis == 0 && elen == 1 && *eptr == '0'
9698                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
9699                         elen = 0;
9700
9701                 /* a precision nullifies the 0 flag. */
9702                     if (fill == '0')
9703                         fill = ' ';
9704                 }
9705             }
9706             break;
9707
9708             /* FLOATING POINT */
9709
9710         case 'F':
9711             c = 'f';            /* maybe %F isn't supported here */
9712             /*FALLTHROUGH*/
9713         case 'e': case 'E':
9714         case 'f':
9715         case 'g': case 'G':
9716             if (vectorize)
9717                 goto unknown;
9718
9719             /* This is evil, but floating point is even more evil */
9720
9721             /* for SV-style calling, we can only get NV
9722                for C-style calling, we assume %f is double;
9723                for simplicity we allow any of %Lf, %llf, %qf for long double
9724             */
9725             switch (intsize) {
9726             case 'V':
9727 #if defined(USE_LONG_DOUBLE)
9728                 intsize = 'q';
9729 #endif
9730                 break;
9731 /* [perl #20339] - we should accept and ignore %lf rather than die */
9732             case 'l':
9733                 /*FALLTHROUGH*/
9734             default:
9735 #if defined(USE_LONG_DOUBLE)
9736                 intsize = args ? 0 : 'q';
9737 #endif
9738                 break;
9739             case 'q':
9740 #if defined(HAS_LONG_DOUBLE)
9741                 break;
9742 #else
9743                 /*FALLTHROUGH*/
9744 #endif
9745             case 'h':
9746                 goto unknown;
9747             }
9748
9749             /* now we need (long double) if intsize == 'q', else (double) */
9750             nv = (args) ?
9751 #if LONG_DOUBLESIZE > DOUBLESIZE
9752                 intsize == 'q' ?
9753                     va_arg(*args, long double) :
9754                     va_arg(*args, double)
9755 #else
9756                     va_arg(*args, double)
9757 #endif
9758                 : SvNV(argsv);
9759
9760             need = 0;
9761             /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
9762                else. frexp() has some unspecified behaviour for those three */
9763             if (c != 'e' && c != 'E' && (nv * 0) == 0) {
9764                 i = PERL_INT_MIN;
9765                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9766                    will cast our (long double) to (double) */
9767                 (void)Perl_frexp(nv, &i);
9768                 if (i == PERL_INT_MIN)
9769                     Perl_die(aTHX_ "panic: frexp");
9770                 if (i > 0)
9771                     need = BIT_DIGITS(i);
9772             }
9773             need += has_precis ? precis : 6; /* known default */
9774
9775             if (need < width)
9776                 need = width;
9777
9778 #ifdef HAS_LDBL_SPRINTF_BUG
9779             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9780                with sfio - Allen <allens@cpan.org> */
9781
9782 #  ifdef DBL_MAX
9783 #    define MY_DBL_MAX DBL_MAX
9784 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9785 #    if DOUBLESIZE >= 8
9786 #      define MY_DBL_MAX 1.7976931348623157E+308L
9787 #    else
9788 #      define MY_DBL_MAX 3.40282347E+38L
9789 #    endif
9790 #  endif
9791
9792 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9793 #    define MY_DBL_MAX_BUG 1L
9794 #  else
9795 #    define MY_DBL_MAX_BUG MY_DBL_MAX
9796 #  endif
9797
9798 #  ifdef DBL_MIN
9799 #    define MY_DBL_MIN DBL_MIN
9800 #  else  /* XXX guessing! -Allen */
9801 #    if DOUBLESIZE >= 8
9802 #      define MY_DBL_MIN 2.2250738585072014E-308L
9803 #    else
9804 #      define MY_DBL_MIN 1.17549435E-38L
9805 #    endif
9806 #  endif
9807
9808             if ((intsize == 'q') && (c == 'f') &&
9809                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9810                 (need < DBL_DIG)) {
9811                 /* it's going to be short enough that
9812                  * long double precision is not needed */
9813
9814                 if ((nv <= 0L) && (nv >= -0L))
9815                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9816                 else {
9817                     /* would use Perl_fp_class as a double-check but not
9818                      * functional on IRIX - see perl.h comments */
9819
9820                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9821                         /* It's within the range that a double can represent */
9822 #if defined(DBL_MAX) && !defined(DBL_MIN)
9823                         if ((nv >= ((long double)1/DBL_MAX)) ||
9824                             (nv <= (-(long double)1/DBL_MAX)))
9825 #endif
9826                         fix_ldbl_sprintf_bug = TRUE;
9827                     }
9828                 }
9829                 if (fix_ldbl_sprintf_bug == TRUE) {
9830                     double temp;
9831
9832                     intsize = 0;
9833                     temp = (double)nv;
9834                     nv = (NV)temp;
9835                 }
9836             }
9837
9838 #  undef MY_DBL_MAX
9839 #  undef MY_DBL_MAX_BUG
9840 #  undef MY_DBL_MIN
9841
9842 #endif /* HAS_LDBL_SPRINTF_BUG */
9843
9844             need += 20; /* fudge factor */
9845             if (PL_efloatsize < need) {
9846                 Safefree(PL_efloatbuf);
9847                 PL_efloatsize = need + 20; /* more fudge */
9848                 Newx(PL_efloatbuf, PL_efloatsize, char);
9849                 PL_efloatbuf[0] = '\0';
9850             }
9851
9852             if ( !(width || left || plus || alt) && fill != '0'
9853                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
9854                 /* See earlier comment about buggy Gconvert when digits,
9855                    aka precis is 0  */
9856                 if ( c == 'g' && precis) {
9857                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9858                     /* May return an empty string for digits==0 */
9859                     if (*PL_efloatbuf) {
9860                         elen = strlen(PL_efloatbuf);
9861                         goto float_converted;
9862                     }
9863                 } else if ( c == 'f' && !precis) {
9864                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9865                         break;
9866                 }
9867             }
9868             {
9869                 char *ptr = ebuf + sizeof ebuf;
9870                 *--ptr = '\0';
9871                 *--ptr = c;
9872                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9873 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9874                 if (intsize == 'q') {
9875                     /* Copy the one or more characters in a long double
9876                      * format before the 'base' ([efgEFG]) character to
9877                      * the format string. */
9878                     static char const prifldbl[] = PERL_PRIfldbl;
9879                     char const *p = prifldbl + sizeof(prifldbl) - 3;
9880                     while (p >= prifldbl) { *--ptr = *p--; }
9881                 }
9882 #endif
9883                 if (has_precis) {
9884                     base = precis;
9885                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
9886                     *--ptr = '.';
9887                 }
9888                 if (width) {
9889                     base = width;
9890                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
9891                 }
9892                 if (fill == '0')
9893                     *--ptr = fill;
9894                 if (left)
9895                     *--ptr = '-';
9896                 if (plus)
9897                     *--ptr = plus;
9898                 if (alt)
9899                     *--ptr = '#';
9900                 *--ptr = '%';
9901
9902                 /* No taint.  Otherwise we are in the strange situation
9903                  * where printf() taints but print($float) doesn't.
9904                  * --jhi */
9905 #if defined(HAS_LONG_DOUBLE)
9906                 elen = ((intsize == 'q')
9907                         ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
9908                         : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
9909 #else
9910                 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9911 #endif
9912             }
9913         float_converted:
9914             eptr = PL_efloatbuf;
9915             break;
9916
9917             /* SPECIAL */
9918
9919         case 'n':
9920             if (vectorize)
9921                 goto unknown;
9922             i = SvCUR(sv) - origlen;
9923             if (args) {
9924                 switch (intsize) {
9925                 case 'h':       *(va_arg(*args, short*)) = i; break;
9926                 default:        *(va_arg(*args, int*)) = i; break;
9927                 case 'l':       *(va_arg(*args, long*)) = i; break;
9928                 case 'V':       *(va_arg(*args, IV*)) = i; break;
9929 #ifdef HAS_QUAD
9930                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
9931 #endif
9932                 }
9933             }
9934             else
9935                 sv_setuv_mg(argsv, (UV)i);
9936             continue;   /* not "break" */
9937
9938             /* UNKNOWN */
9939
9940         default:
9941       unknown:
9942             if (!args
9943                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9944                 && ckWARN(WARN_PRINTF))
9945             {
9946                 SV * const msg = sv_newmortal();
9947                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9948                           (PL_op->op_type == OP_PRTF) ? "" : "s");
9949                 if (c) {
9950                     if (isPRINT(c))
9951                         Perl_sv_catpvf(aTHX_ msg,
9952                                        "\"%%%c\"", c & 0xFF);
9953                     else
9954                         Perl_sv_catpvf(aTHX_ msg,
9955                                        "\"%%\\%03"UVof"\"",
9956                                        (UV)c & 0xFF);
9957                 } else
9958                     sv_catpvs(msg, "end of string");
9959                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
9960             }
9961
9962             /* output mangled stuff ... */
9963             if (c == '\0')
9964                 --q;
9965             eptr = p;
9966             elen = q - p;
9967
9968             /* ... right here, because formatting flags should not apply */
9969             SvGROW(sv, SvCUR(sv) + elen + 1);
9970             p = SvEND(sv);
9971             Copy(eptr, p, elen, char);
9972             p += elen;
9973             *p = '\0';
9974             SvCUR_set(sv, p - SvPVX_const(sv));
9975             svix = osvix;
9976             continue;   /* not "break" */
9977         }
9978
9979         if (is_utf8 != has_utf8) {
9980             if (is_utf8) {
9981                 if (SvCUR(sv))
9982                     sv_utf8_upgrade(sv);
9983             }
9984             else {
9985                 const STRLEN old_elen = elen;
9986                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
9987                 sv_utf8_upgrade(nsv);
9988                 eptr = SvPVX_const(nsv);
9989                 elen = SvCUR(nsv);
9990
9991                 if (width) { /* fudge width (can't fudge elen) */
9992                     width += elen - old_elen;
9993                 }
9994                 is_utf8 = TRUE;
9995             }
9996         }
9997
9998         have = esignlen + zeros + elen;
9999         if (have < zeros)
10000             Perl_croak_nocontext(PL_memory_wrap);
10001
10002         need = (have > width ? have : width);
10003         gap = need - have;
10004
10005         if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10006             Perl_croak_nocontext(PL_memory_wrap);
10007         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10008         p = SvEND(sv);
10009         if (esignlen && fill == '0') {
10010             int i;
10011             for (i = 0; i < (int)esignlen; i++)
10012                 *p++ = esignbuf[i];
10013         }
10014         if (gap && !left) {
10015             memset(p, fill, gap);
10016             p += gap;
10017         }
10018         if (esignlen && fill != '0') {
10019             int i;
10020             for (i = 0; i < (int)esignlen; i++)
10021                 *p++ = esignbuf[i];
10022         }
10023         if (zeros) {
10024             int i;
10025             for (i = zeros; i; i--)
10026                 *p++ = '0';
10027         }
10028         if (elen) {
10029             Copy(eptr, p, elen, char);
10030             p += elen;
10031         }
10032         if (gap && left) {
10033             memset(p, ' ', gap);
10034             p += gap;
10035         }
10036         if (vectorize) {
10037             if (veclen) {
10038                 Copy(dotstr, p, dotstrlen, char);
10039                 p += dotstrlen;
10040             }
10041             else
10042                 vectorize = FALSE;              /* done iterating over vecstr */
10043         }
10044         if (is_utf8)
10045             has_utf8 = TRUE;
10046         if (has_utf8)
10047             SvUTF8_on(sv);
10048         *p = '\0';
10049         SvCUR_set(sv, p - SvPVX_const(sv));
10050         if (vectorize) {
10051             esignlen = 0;
10052             goto vector;
10053         }
10054     }
10055 }
10056
10057 /* =========================================================================
10058
10059 =head1 Cloning an interpreter
10060
10061 All the macros and functions in this section are for the private use of
10062 the main function, perl_clone().
10063
10064 The foo_dup() functions make an exact copy of an existing foo thingy.
10065 During the course of a cloning, a hash table is used to map old addresses
10066 to new addresses. The table is created and manipulated with the
10067 ptr_table_* functions.
10068
10069 =cut
10070
10071 ============================================================================*/
10072
10073
10074 #if defined(USE_ITHREADS)
10075
10076 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10077 #ifndef GpREFCNT_inc
10078 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10079 #endif
10080
10081
10082 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10083    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10084    If this changes, please unmerge ss_dup.  */
10085 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10086 #define sv_dup_inc_NN(s,t)      SvREFCNT_inc_NN(sv_dup(s,t))
10087 #define av_dup(s,t)     MUTABLE_AV(sv_dup((const SV *)s,t))
10088 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10089 #define hv_dup(s,t)     MUTABLE_HV(sv_dup((const SV *)s,t))
10090 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10091 #define cv_dup(s,t)     MUTABLE_CV(sv_dup((SV*)s,t))
10092 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10093 #define io_dup(s,t)     (IO*)sv_dup((SV*)s,t)
10094 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((const SV *)s,t))
10095 #define gv_dup(s,t)     (GV*)sv_dup((SV*)s,t)
10096 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((const SV *)s,t))
10097 #define SAVEPV(p)       ((p) ? savepv(p) : NULL)
10098 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
10099
10100 /* clone a parser */
10101
10102 yy_parser *
10103 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10104 {
10105     yy_parser *parser;
10106
10107     PERL_ARGS_ASSERT_PARSER_DUP;
10108
10109     if (!proto)
10110         return NULL;
10111
10112     /* look for it in the table first */
10113     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10114     if (parser)
10115         return parser;
10116
10117     /* create anew and remember what it is */
10118     Newxz(parser, 1, yy_parser);
10119     ptr_table_store(PL_ptr_table, proto, parser);
10120
10121     parser->yyerrstatus = 0;
10122     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
10123
10124     /* XXX these not yet duped */
10125     parser->old_parser = NULL;
10126     parser->stack = NULL;
10127     parser->ps = NULL;
10128     parser->stack_size = 0;
10129     /* XXX parser->stack->state = 0; */
10130
10131     /* XXX eventually, just Copy() most of the parser struct ? */
10132
10133     parser->lex_brackets = proto->lex_brackets;
10134     parser->lex_casemods = proto->lex_casemods;
10135     parser->lex_brackstack = savepvn(proto->lex_brackstack,
10136                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10137     parser->lex_casestack = savepvn(proto->lex_casestack,
10138                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10139     parser->lex_defer   = proto->lex_defer;
10140     parser->lex_dojoin  = proto->lex_dojoin;
10141     parser->lex_expect  = proto->lex_expect;
10142     parser->lex_formbrack = proto->lex_formbrack;
10143     parser->lex_inpat   = proto->lex_inpat;
10144     parser->lex_inwhat  = proto->lex_inwhat;
10145     parser->lex_op      = proto->lex_op;
10146     parser->lex_repl    = sv_dup_inc(proto->lex_repl, param);
10147     parser->lex_starts  = proto->lex_starts;
10148     parser->lex_stuff   = sv_dup_inc(proto->lex_stuff, param);
10149     parser->multi_close = proto->multi_close;
10150     parser->multi_open  = proto->multi_open;
10151     parser->multi_start = proto->multi_start;
10152     parser->multi_end   = proto->multi_end;
10153     parser->pending_ident = proto->pending_ident;
10154     parser->preambled   = proto->preambled;
10155     parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10156     parser->linestr     = sv_dup_inc(proto->linestr, param);
10157     parser->expect      = proto->expect;
10158     parser->copline     = proto->copline;
10159     parser->last_lop_op = proto->last_lop_op;
10160     parser->lex_state   = proto->lex_state;
10161     parser->rsfp        = fp_dup(proto->rsfp, '<', param);
10162     /* rsfp_filters entries have fake IoDIRP() */
10163     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10164     parser->in_my       = proto->in_my;
10165     parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10166     parser->error_count = proto->error_count;
10167
10168
10169     parser->linestr     = sv_dup_inc(proto->linestr, param);
10170
10171     {
10172         char * const ols = SvPVX(proto->linestr);
10173         char * const ls  = SvPVX(parser->linestr);
10174
10175         parser->bufptr      = ls + (proto->bufptr >= ols ?
10176                                     proto->bufptr -  ols : 0);
10177         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
10178                                     proto->oldbufptr -  ols : 0);
10179         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10180                                     proto->oldoldbufptr -  ols : 0);
10181         parser->linestart   = ls + (proto->linestart >= ols ?
10182                                     proto->linestart -  ols : 0);
10183         parser->last_uni    = ls + (proto->last_uni >= ols ?
10184                                     proto->last_uni -  ols : 0);
10185         parser->last_lop    = ls + (proto->last_lop >= ols ?
10186                                     proto->last_lop -  ols : 0);
10187
10188         parser->bufend      = ls + SvCUR(parser->linestr);
10189     }
10190
10191     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10192
10193
10194 #ifdef PERL_MAD
10195     parser->endwhite    = proto->endwhite;
10196     parser->faketokens  = proto->faketokens;
10197     parser->lasttoke    = proto->lasttoke;
10198     parser->nextwhite   = proto->nextwhite;
10199     parser->realtokenstart = proto->realtokenstart;
10200     parser->skipwhite   = proto->skipwhite;
10201     parser->thisclose   = proto->thisclose;
10202     parser->thismad     = proto->thismad;
10203     parser->thisopen    = proto->thisopen;
10204     parser->thisstuff   = proto->thisstuff;
10205     parser->thistoken   = proto->thistoken;
10206     parser->thiswhite   = proto->thiswhite;
10207
10208     Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10209     parser->curforce    = proto->curforce;
10210 #else
10211     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10212     Copy(proto->nexttype, parser->nexttype, 5,  I32);
10213     parser->nexttoke    = proto->nexttoke;
10214 #endif
10215     return parser;
10216 }
10217
10218
10219 /* duplicate a file handle */
10220
10221 PerlIO *
10222 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10223 {
10224     PerlIO *ret;
10225
10226     PERL_ARGS_ASSERT_FP_DUP;
10227     PERL_UNUSED_ARG(type);
10228
10229     if (!fp)
10230         return (PerlIO*)NULL;
10231
10232     /* look for it in the table first */
10233     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10234     if (ret)
10235         return ret;
10236
10237     /* create anew and remember what it is */
10238     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10239     ptr_table_store(PL_ptr_table, fp, ret);
10240     return ret;
10241 }
10242
10243 /* duplicate a directory handle */
10244
10245 DIR *
10246 Perl_dirp_dup(pTHX_ DIR *const dp)
10247 {
10248     PERL_UNUSED_CONTEXT;
10249     if (!dp)
10250         return (DIR*)NULL;
10251     /* XXX TODO */
10252     return dp;
10253 }
10254
10255 /* duplicate a typeglob */
10256
10257 GP *
10258 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10259 {
10260     GP *ret;
10261
10262     PERL_ARGS_ASSERT_GP_DUP;
10263
10264     if (!gp)
10265         return (GP*)NULL;
10266     /* look for it in the table first */
10267     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10268     if (ret)
10269         return ret;
10270
10271     /* create anew and remember what it is */
10272     Newxz(ret, 1, GP);
10273     ptr_table_store(PL_ptr_table, gp, ret);
10274
10275     /* clone */
10276     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
10277     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
10278     ret->gp_io          = io_dup_inc(gp->gp_io, param);
10279     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
10280     ret->gp_av          = av_dup_inc(gp->gp_av, param);
10281     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
10282     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10283     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
10284     ret->gp_cvgen       = gp->gp_cvgen;
10285     ret->gp_line        = gp->gp_line;
10286     ret->gp_file_hek    = hek_dup(gp->gp_file_hek, param);
10287     return ret;
10288 }
10289
10290 /* duplicate a chain of magic */
10291
10292 MAGIC *
10293 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10294 {
10295     MAGIC *mgprev = (MAGIC*)NULL;
10296     MAGIC *mgret;
10297
10298     PERL_ARGS_ASSERT_MG_DUP;
10299
10300     if (!mg)
10301         return (MAGIC*)NULL;
10302     /* look for it in the table first */
10303     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10304     if (mgret)
10305         return mgret;
10306
10307     for (; mg; mg = mg->mg_moremagic) {
10308         MAGIC *nmg;
10309         Newxz(nmg, 1, MAGIC);
10310         if (mgprev)
10311             mgprev->mg_moremagic = nmg;
10312         else
10313             mgret = nmg;
10314         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
10315         nmg->mg_private = mg->mg_private;
10316         nmg->mg_type    = mg->mg_type;
10317         nmg->mg_flags   = mg->mg_flags;
10318         /* FIXME for plugins
10319         if (mg->mg_type == PERL_MAGIC_qr) {
10320             nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param);
10321         }
10322         else
10323         */
10324         if(mg->mg_type == PERL_MAGIC_backref) {
10325             /* The backref AV has its reference count deliberately bumped by
10326                1.  */
10327             nmg->mg_obj
10328                 = SvREFCNT_inc(av_dup_inc((const AV *) mg->mg_obj, param));
10329         }
10330         else {
10331             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10332                               ? sv_dup_inc(mg->mg_obj, param)
10333                               : sv_dup(mg->mg_obj, param);
10334         }
10335         nmg->mg_len     = mg->mg_len;
10336         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
10337         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10338             if (mg->mg_len > 0) {
10339                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
10340                 if (mg->mg_type == PERL_MAGIC_overload_table &&
10341                         AMT_AMAGIC((AMT*)mg->mg_ptr))
10342                 {
10343                     const AMT * const amtp = (AMT*)mg->mg_ptr;
10344                     AMT * const namtp = (AMT*)nmg->mg_ptr;
10345                     I32 i;
10346                     for (i = 1; i < NofAMmeth; i++) {
10347                         namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10348                     }
10349                 }
10350             }
10351             else if (mg->mg_len == HEf_SVKEY)
10352                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10353         }
10354         if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10355             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10356         }
10357         mgprev = nmg;
10358     }
10359     return mgret;
10360 }
10361
10362 #endif /* USE_ITHREADS */
10363
10364 /* create a new pointer-mapping table */
10365
10366 PTR_TBL_t *
10367 Perl_ptr_table_new(pTHX)
10368 {
10369     PTR_TBL_t *tbl;
10370     PERL_UNUSED_CONTEXT;
10371
10372     Newxz(tbl, 1, PTR_TBL_t);
10373     tbl->tbl_max        = 511;
10374     tbl->tbl_items      = 0;
10375     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10376     return tbl;
10377 }
10378
10379 #define PTR_TABLE_HASH(ptr) \
10380   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10381
10382 /*
10383    we use the PTE_SVSLOT 'reservation' made above, both here (in the
10384    following define) and at call to new_body_inline made below in
10385    Perl_ptr_table_store()
10386  */
10387
10388 #define del_pte(p)     del_body_type(p, PTE_SVSLOT)
10389
10390 /* map an existing pointer using a table */
10391
10392 STATIC PTR_TBL_ENT_t *
10393 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10394 {
10395     PTR_TBL_ENT_t *tblent;
10396     const UV hash = PTR_TABLE_HASH(sv);
10397
10398     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10399
10400     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10401     for (; tblent; tblent = tblent->next) {
10402         if (tblent->oldval == sv)
10403             return tblent;
10404     }
10405     return NULL;
10406 }
10407
10408 void *
10409 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10410 {
10411     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10412
10413     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10414     PERL_UNUSED_CONTEXT;
10415
10416     return tblent ? tblent->newval : NULL;
10417 }
10418
10419 /* add a new entry to a pointer-mapping table */
10420
10421 void
10422 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10423 {
10424     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10425
10426     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10427     PERL_UNUSED_CONTEXT;
10428
10429     if (tblent) {
10430         tblent->newval = newsv;
10431     } else {
10432         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10433
10434         new_body_inline(tblent, PTE_SVSLOT);
10435
10436         tblent->oldval = oldsv;
10437         tblent->newval = newsv;
10438         tblent->next = tbl->tbl_ary[entry];
10439         tbl->tbl_ary[entry] = tblent;
10440         tbl->tbl_items++;
10441         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10442             ptr_table_split(tbl);
10443     }
10444 }
10445
10446 /* double the hash bucket size of an existing ptr table */
10447
10448 void
10449 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10450 {
10451     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10452     const UV oldsize = tbl->tbl_max + 1;
10453     UV newsize = oldsize * 2;
10454     UV i;
10455
10456     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10457     PERL_UNUSED_CONTEXT;
10458
10459     Renew(ary, newsize, PTR_TBL_ENT_t*);
10460     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10461     tbl->tbl_max = --newsize;
10462     tbl->tbl_ary = ary;
10463     for (i=0; i < oldsize; i++, ary++) {
10464         PTR_TBL_ENT_t **curentp, **entp, *ent;
10465         if (!*ary)
10466             continue;
10467         curentp = ary + oldsize;
10468         for (entp = ary, ent = *ary; ent; ent = *entp) {
10469             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10470                 *entp = ent->next;
10471                 ent->next = *curentp;
10472                 *curentp = ent;
10473                 continue;
10474             }
10475             else
10476                 entp = &ent->next;
10477         }
10478     }
10479 }
10480
10481 /* remove all the entries from a ptr table */
10482
10483 void
10484 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10485 {
10486     if (tbl && tbl->tbl_items) {
10487         register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
10488         UV riter = tbl->tbl_max;
10489
10490         do {
10491             PTR_TBL_ENT_t *entry = array[riter];
10492
10493             while (entry) {
10494                 PTR_TBL_ENT_t * const oentry = entry;
10495                 entry = entry->next;
10496                 del_pte(oentry);
10497             }
10498         } while (riter--);
10499
10500         tbl->tbl_items = 0;
10501     }
10502 }
10503
10504 /* clear and free a ptr table */
10505
10506 void
10507 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10508 {
10509     if (!tbl) {
10510         return;
10511     }
10512     ptr_table_clear(tbl);
10513     Safefree(tbl->tbl_ary);
10514     Safefree(tbl);
10515 }
10516
10517 #if defined(USE_ITHREADS)
10518
10519 void
10520 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10521 {
10522     PERL_ARGS_ASSERT_RVPV_DUP;
10523
10524     if (SvROK(sstr)) {
10525         SvRV_set(dstr, SvWEAKREF(sstr)
10526                        ? sv_dup(SvRV(sstr), param)
10527                        : sv_dup_inc(SvRV(sstr), param));
10528
10529     }
10530     else if (SvPVX_const(sstr)) {
10531         /* Has something there */
10532         if (SvLEN(sstr)) {
10533             /* Normal PV - clone whole allocated space */
10534             SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10535             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10536                 /* Not that normal - actually sstr is copy on write.
10537                    But we are a true, independant SV, so:  */
10538                 SvREADONLY_off(dstr);
10539                 SvFAKE_off(dstr);
10540             }
10541         }
10542         else {
10543             /* Special case - not normally malloced for some reason */
10544             if (isGV_with_GP(sstr)) {
10545                 /* Don't need to do anything here.  */
10546             }
10547             else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10548                 /* A "shared" PV - clone it as "shared" PV */
10549                 SvPV_set(dstr,
10550                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10551                                          param)));
10552             }
10553             else {
10554                 /* Some other special case - random pointer */
10555                 SvPV_set(dstr, SvPVX(sstr));
10556             }
10557         }
10558     }
10559     else {
10560         /* Copy the NULL */
10561         SvPV_set(dstr, NULL);
10562     }
10563 }
10564
10565 /* duplicate an SV of any type (including AV, HV etc) */
10566
10567 SV *
10568 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10569 {
10570     dVAR;
10571     SV *dstr;
10572
10573     PERL_ARGS_ASSERT_SV_DUP;
10574
10575     if (!sstr)
10576         return NULL;
10577     if (SvTYPE(sstr) == SVTYPEMASK) {
10578 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10579         abort();
10580 #endif
10581         return NULL;
10582     }
10583     /* look for it in the table first */
10584     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10585     if (dstr)
10586         return dstr;
10587
10588     if(param->flags & CLONEf_JOIN_IN) {
10589         /** We are joining here so we don't want do clone
10590             something that is bad **/
10591         if (SvTYPE(sstr) == SVt_PVHV) {
10592             const HEK * const hvname = HvNAME_HEK(sstr);
10593             if (hvname)
10594                 /** don't clone stashes if they already exist **/
10595                 return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0);
10596         }
10597     }
10598
10599     /* create anew and remember what it is */
10600     new_SV(dstr);
10601
10602 #ifdef DEBUG_LEAKING_SCALARS
10603     dstr->sv_debug_optype = sstr->sv_debug_optype;
10604     dstr->sv_debug_line = sstr->sv_debug_line;
10605     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10606     dstr->sv_debug_cloned = 1;
10607     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10608 #endif
10609
10610     ptr_table_store(PL_ptr_table, sstr, dstr);
10611
10612     /* clone */
10613     SvFLAGS(dstr)       = SvFLAGS(sstr);
10614     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
10615     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
10616
10617 #ifdef DEBUGGING
10618     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10619         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10620                       (void*)PL_watch_pvx, SvPVX_const(sstr));
10621 #endif
10622
10623     /* don't clone objects whose class has asked us not to */
10624     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10625         SvFLAGS(dstr) = 0;
10626         return dstr;
10627     }
10628
10629     switch (SvTYPE(sstr)) {
10630     case SVt_NULL:
10631         SvANY(dstr)     = NULL;
10632         break;
10633     case SVt_IV:
10634         SvANY(dstr)     = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10635         if(SvROK(sstr)) {
10636             Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10637         } else {
10638             SvIV_set(dstr, SvIVX(sstr));
10639         }
10640         break;
10641     case SVt_NV:
10642         SvANY(dstr)     = new_XNV();
10643         SvNV_set(dstr, SvNVX(sstr));
10644         break;
10645         /* case SVt_BIND: */
10646     default:
10647         {
10648             /* These are all the types that need complex bodies allocating.  */
10649             void *new_body;
10650             const svtype sv_type = SvTYPE(sstr);
10651             const struct body_details *const sv_type_details
10652                 = bodies_by_type + sv_type;
10653
10654             switch (sv_type) {
10655             default:
10656                 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10657                 break;
10658
10659             case SVt_PVGV:
10660                 if (GvUNIQUE((GV*)sstr)) {
10661                     NOOP;   /* Do sharing here, and fall through */
10662                 }
10663             case SVt_PVIO:
10664             case SVt_PVFM:
10665             case SVt_PVHV:
10666             case SVt_PVAV:
10667             case SVt_PVCV:
10668             case SVt_PVLV:
10669             case SVt_REGEXP:
10670             case SVt_PVMG:
10671             case SVt_PVNV:
10672             case SVt_PVIV:
10673             case SVt_PV:
10674                 assert(sv_type_details->body_size);
10675                 if (sv_type_details->arena) {
10676                     new_body_inline(new_body, sv_type);
10677                     new_body
10678                         = (void*)((char*)new_body - sv_type_details->offset);
10679                 } else {
10680                     new_body = new_NOARENA(sv_type_details);
10681                 }
10682             }
10683             assert(new_body);
10684             SvANY(dstr) = new_body;
10685
10686 #ifndef PURIFY
10687             Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
10688                  ((char*)SvANY(dstr)) + sv_type_details->offset,
10689                  sv_type_details->copy, char);
10690 #else
10691             Copy(((char*)SvANY(sstr)),
10692                  ((char*)SvANY(dstr)),
10693                  sv_type_details->body_size + sv_type_details->offset, char);
10694 #endif
10695
10696             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
10697                 && !isGV_with_GP(dstr))
10698                 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10699
10700             /* The Copy above means that all the source (unduplicated) pointers
10701                are now in the destination.  We can check the flags and the
10702                pointers in either, but it's possible that there's less cache
10703                missing by always going for the destination.
10704                FIXME - instrument and check that assumption  */
10705             if (sv_type >= SVt_PVMG) {
10706                 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
10707                     SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
10708                 } else if (SvMAGIC(dstr))
10709                     SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10710                 if (SvSTASH(dstr))
10711                     SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10712             }
10713
10714             /* The cast silences a GCC warning about unhandled types.  */
10715             switch ((int)sv_type) {
10716             case SVt_PV:
10717                 break;
10718             case SVt_PVIV:
10719                 break;
10720             case SVt_PVNV:
10721                 break;
10722             case SVt_PVMG:
10723                 break;
10724             case SVt_REGEXP:
10725                 /* FIXME for plugins */
10726                 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
10727                 break;
10728             case SVt_PVLV:
10729                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10730                 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10731                     LvTARG(dstr) = dstr;
10732                 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10733                     LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10734                 else
10735                     LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10736             case SVt_PVGV:
10737                 if(isGV_with_GP(sstr)) {
10738                     if (GvNAME_HEK(dstr))
10739                         GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
10740                     /* Don't call sv_add_backref here as it's going to be
10741                        created as part of the magic cloning of the symbol
10742                        table.  */
10743                     /* Danger Will Robinson - GvGP(dstr) isn't initialised
10744                        at the point of this comment.  */
10745                     GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10746                     GvGP(dstr)  = gp_dup(GvGP(sstr), param);
10747                     (void)GpREFCNT_inc(GvGP(dstr));
10748                 } else
10749                     Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10750                 break;
10751             case SVt_PVIO:
10752                 IoIFP(dstr)     = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10753                 if (IoOFP(dstr) == IoIFP(sstr))
10754                     IoOFP(dstr) = IoIFP(dstr);
10755                 else
10756                     IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10757                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
10758                 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10759                     /* I have no idea why fake dirp (rsfps)
10760                        should be treated differently but otherwise
10761                        we end up with leaks -- sky*/
10762                     IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
10763                     IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
10764                     IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10765                 } else {
10766                     IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
10767                     IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
10768                     IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
10769                     if (IoDIRP(dstr)) {
10770                         IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr));
10771                     } else {
10772                         NOOP;
10773                         /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
10774                     }
10775                 }
10776                 IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
10777                 IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
10778                 IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
10779                 break;
10780             case SVt_PVAV:
10781                 if (AvARRAY((const AV *)sstr)) {
10782                     SV **dst_ary, **src_ary;
10783                     SSize_t items = AvFILLp((const AV *)sstr) + 1;
10784
10785                     src_ary = AvARRAY((const AV *)sstr);
10786                     Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
10787                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10788                     AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
10789                     AvALLOC((const AV *)dstr) = dst_ary;
10790                     if (AvREAL((const AV *)sstr)) {
10791                         while (items-- > 0)
10792                             *dst_ary++ = sv_dup_inc(*src_ary++, param);
10793                     }
10794                     else {
10795                         while (items-- > 0)
10796                             *dst_ary++ = sv_dup(*src_ary++, param);
10797                     }
10798                     items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
10799                     while (items-- > 0) {
10800                         *dst_ary++ = &PL_sv_undef;
10801                     }
10802                 }
10803                 else {
10804                     AvARRAY(MUTABLE_AV(dstr))   = NULL;
10805                     AvALLOC((const AV *)dstr)   = (SV**)NULL;
10806                 }
10807                 break;
10808             case SVt_PVHV:
10809                 if (HvARRAY((const HV *)sstr)) {
10810                     STRLEN i = 0;
10811                     const bool sharekeys = !!HvSHAREKEYS(sstr);
10812                     XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10813                     XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10814                     char *darray;
10815                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10816                         + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10817                         char);
10818                     HvARRAY(dstr) = (HE**)darray;
10819                     while (i <= sxhv->xhv_max) {
10820                         const HE * const source = HvARRAY(sstr)[i];
10821                         HvARRAY(dstr)[i] = source
10822                             ? he_dup(source, sharekeys, param) : 0;
10823                         ++i;
10824                     }
10825                     if (SvOOK(sstr)) {
10826                         HEK *hvname;
10827                         const struct xpvhv_aux * const saux = HvAUX(sstr);
10828                         struct xpvhv_aux * const daux = HvAUX(dstr);
10829                         /* This flag isn't copied.  */
10830                         /* SvOOK_on(hv) attacks the IV flags.  */
10831                         SvFLAGS(dstr) |= SVf_OOK;
10832
10833                         hvname = saux->xhv_name;
10834                         daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
10835
10836                         daux->xhv_riter = saux->xhv_riter;
10837                         daux->xhv_eiter = saux->xhv_eiter
10838                             ? he_dup(saux->xhv_eiter,
10839                                         (bool)!!HvSHAREKEYS(sstr), param) : 0;
10840                         /* backref array needs refcnt=2; see sv_add_backref */
10841                         daux->xhv_backreferences =
10842                             saux->xhv_backreferences
10843                             ? MUTABLE_AV(SvREFCNT_inc(
10844                                                       sv_dup_inc((SV*)saux->xhv_backreferences, param)))
10845                                 : 0;
10846
10847                         daux->xhv_mro_meta = saux->xhv_mro_meta
10848                             ? mro_meta_dup(saux->xhv_mro_meta, param)
10849                             : 0;
10850
10851                         /* Record stashes for possible cloning in Perl_clone(). */
10852                         if (hvname)
10853                             av_push(param->stashes, dstr);
10854                     }
10855                 }
10856                 else
10857                     HvARRAY(MUTABLE_HV(dstr)) = NULL;
10858                 break;
10859             case SVt_PVCV:
10860                 if (!(param->flags & CLONEf_COPY_STACKS)) {
10861                     CvDEPTH(dstr) = 0;
10862                 }
10863             case SVt_PVFM:
10864                 /* NOTE: not refcounted */
10865                 CvSTASH(dstr)   = hv_dup(CvSTASH(dstr), param);
10866                 OP_REFCNT_LOCK;
10867                 if (!CvISXSUB(dstr))
10868                     CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10869                 OP_REFCNT_UNLOCK;
10870                 if (CvCONST(dstr) && CvISXSUB(dstr)) {
10871                     CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10872                         SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10873                         sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10874                 }
10875                 /* don't dup if copying back - CvGV isn't refcounted, so the
10876                  * duped GV may never be freed. A bit of a hack! DAPM */
10877                 CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
10878                     NULL : gv_dup(CvGV(dstr), param) ;
10879                 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10880                 CvOUTSIDE(dstr) =
10881                     CvWEAKOUTSIDE(sstr)
10882                     ? cv_dup(    CvOUTSIDE(dstr), param)
10883                     : cv_dup_inc(CvOUTSIDE(dstr), param);
10884                 if (!CvISXSUB(dstr))
10885                     CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10886                 break;
10887             }
10888         }
10889     }
10890
10891     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10892         ++PL_sv_objcount;
10893
10894     return dstr;
10895  }
10896
10897 /* duplicate a context */
10898
10899 PERL_CONTEXT *
10900 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10901 {
10902     PERL_CONTEXT *ncxs;
10903
10904     PERL_ARGS_ASSERT_CX_DUP;
10905
10906     if (!cxs)
10907         return (PERL_CONTEXT*)NULL;
10908
10909     /* look for it in the table first */
10910     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10911     if (ncxs)
10912         return ncxs;
10913
10914     /* create anew and remember what it is */
10915     Newx(ncxs, max + 1, PERL_CONTEXT);
10916     ptr_table_store(PL_ptr_table, cxs, ncxs);
10917     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
10918
10919     while (ix >= 0) {
10920         PERL_CONTEXT * const ncx = &ncxs[ix];
10921         if (CxTYPE(ncx) == CXt_SUBST) {
10922             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10923         }
10924         else {
10925             switch (CxTYPE(ncx)) {
10926             case CXt_SUB:
10927                 ncx->blk_sub.cv         = (ncx->blk_sub.olddepth == 0
10928                                            ? cv_dup_inc(ncx->blk_sub.cv, param)
10929                                            : cv_dup(ncx->blk_sub.cv,param));
10930                 ncx->blk_sub.argarray   = (CxHASARGS(ncx)
10931                                            ? av_dup_inc(ncx->blk_sub.argarray,
10932                                                         param)
10933                                            : NULL);
10934                 ncx->blk_sub.savearray  = av_dup_inc(ncx->blk_sub.savearray,
10935                                                      param);
10936                 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
10937                                            ncx->blk_sub.oldcomppad);
10938                 break;
10939             case CXt_EVAL:
10940                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
10941                                                       param);
10942                 ncx->blk_eval.cur_text  = sv_dup(ncx->blk_eval.cur_text, param);
10943                 break;
10944             case CXt_LOOP_LAZYSV:
10945                 ncx->blk_loop.state_u.lazysv.end
10946                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
10947                 /* We are taking advantage of av_dup_inc and sv_dup_inc
10948                    actually being the same function, and order equivalance of
10949                    the two unions.
10950                    We can assert the later [but only at run time :-(]  */
10951                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
10952                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
10953             case CXt_LOOP_FOR:
10954                 ncx->blk_loop.state_u.ary.ary
10955                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
10956             case CXt_LOOP_LAZYIV:
10957             case CXt_LOOP_PLAIN:
10958                 if (CxPADLOOP(ncx)) {
10959                     ncx->blk_loop.oldcomppad
10960                         = (PAD*)ptr_table_fetch(PL_ptr_table,
10961                                                 ncx->blk_loop.oldcomppad);
10962                 } else {
10963                     ncx->blk_loop.oldcomppad
10964                         = (PAD*)gv_dup((GV*)ncx->blk_loop.oldcomppad, param);
10965                 }
10966                 break;
10967             case CXt_FORMAT:
10968                 ncx->blk_format.cv      = cv_dup(ncx->blk_format.cv, param);
10969                 ncx->blk_format.gv      = gv_dup(ncx->blk_format.gv, param);
10970                 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
10971                                                      param);
10972                 break;
10973             case CXt_BLOCK:
10974             case CXt_NULL:
10975                 break;
10976             }
10977         }
10978         --ix;
10979     }
10980     return ncxs;
10981 }
10982
10983 /* duplicate a stack info structure */
10984
10985 PERL_SI *
10986 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10987 {
10988     PERL_SI *nsi;
10989
10990     PERL_ARGS_ASSERT_SI_DUP;
10991
10992     if (!si)
10993         return (PERL_SI*)NULL;
10994
10995     /* look for it in the table first */
10996     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10997     if (nsi)
10998         return nsi;
10999
11000     /* create anew and remember what it is */
11001     Newxz(nsi, 1, PERL_SI);
11002     ptr_table_store(PL_ptr_table, si, nsi);
11003
11004     nsi->si_stack       = av_dup_inc(si->si_stack, param);
11005     nsi->si_cxix        = si->si_cxix;
11006     nsi->si_cxmax       = si->si_cxmax;
11007     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11008     nsi->si_type        = si->si_type;
11009     nsi->si_prev        = si_dup(si->si_prev, param);
11010     nsi->si_next        = si_dup(si->si_next, param);
11011     nsi->si_markoff     = si->si_markoff;
11012
11013     return nsi;
11014 }
11015
11016 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
11017 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
11018 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
11019 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
11020 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
11021 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
11022 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
11023 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
11024 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
11025 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
11026 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
11027 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
11028 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11029 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11030
11031 /* XXXXX todo */
11032 #define pv_dup_inc(p)   SAVEPV(p)
11033 #define pv_dup(p)       SAVEPV(p)
11034 #define svp_dup_inc(p,pp)       any_dup(p,pp)
11035
11036 /* map any object to the new equivent - either something in the
11037  * ptr table, or something in the interpreter structure
11038  */
11039
11040 void *
11041 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11042 {
11043     void *ret;
11044
11045     PERL_ARGS_ASSERT_ANY_DUP;
11046
11047     if (!v)
11048         return (void*)NULL;
11049
11050     /* look for it in the table first */
11051     ret = ptr_table_fetch(PL_ptr_table, v);
11052     if (ret)
11053         return ret;
11054
11055     /* see if it is part of the interpreter structure */
11056     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11057         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11058     else {
11059         ret = v;
11060     }
11061
11062     return ret;
11063 }
11064
11065 /* duplicate the save stack */
11066
11067 ANY *
11068 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11069 {
11070     dVAR;
11071     ANY * const ss      = proto_perl->Isavestack;
11072     const I32 max       = proto_perl->Isavestack_max;
11073     I32 ix              = proto_perl->Isavestack_ix;
11074     ANY *nss;
11075     SV *sv;
11076     const GV *gv;
11077     const AV *av;
11078     const HV *hv;
11079     void* ptr;
11080     int intval;
11081     long longval;
11082     GP *gp;
11083     IV iv;
11084     I32 i;
11085     char *c = NULL;
11086     void (*dptr) (void*);
11087     void (*dxptr) (pTHX_ void*);
11088
11089     PERL_ARGS_ASSERT_SS_DUP;
11090
11091     Newxz(nss, max, ANY);
11092
11093     while (ix > 0) {
11094         const I32 type = POPINT(ss,ix);
11095         TOPINT(nss,ix) = type;
11096         switch (type) {
11097         case SAVEt_HELEM:               /* hash element */
11098             sv = (SV*)POPPTR(ss,ix);
11099             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11100             /* fall through */
11101         case SAVEt_ITEM:                        /* normal string */
11102         case SAVEt_SV:                          /* scalar reference */
11103             sv = (SV*)POPPTR(ss,ix);
11104             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11105             /* fall through */
11106         case SAVEt_FREESV:
11107         case SAVEt_MORTALIZESV:
11108             sv = (SV*)POPPTR(ss,ix);
11109             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11110             break;
11111         case SAVEt_SHARED_PVREF:                /* char* in shared space */
11112             c = (char*)POPPTR(ss,ix);
11113             TOPPTR(nss,ix) = savesharedpv(c);
11114             ptr = POPPTR(ss,ix);
11115             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11116             break;
11117         case SAVEt_GENERIC_SVREF:               /* generic sv */
11118         case SAVEt_SVREF:                       /* scalar reference */
11119             sv = (SV*)POPPTR(ss,ix);
11120             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11121             ptr = POPPTR(ss,ix);
11122             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11123             break;
11124         case SAVEt_HV:                          /* hash reference */
11125         case SAVEt_AV:                          /* array reference */
11126             sv = (SV*) POPPTR(ss,ix);
11127             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11128             /* fall through */
11129         case SAVEt_COMPPAD:
11130         case SAVEt_NSTAB:
11131             sv = (SV*) POPPTR(ss,ix);
11132             TOPPTR(nss,ix) = sv_dup(sv, param);
11133             break;
11134         case SAVEt_INT:                         /* int reference */
11135             ptr = POPPTR(ss,ix);
11136             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11137             intval = (int)POPINT(ss,ix);
11138             TOPINT(nss,ix) = intval;
11139             break;
11140         case SAVEt_LONG:                        /* long reference */
11141             ptr = POPPTR(ss,ix);
11142             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11143             /* fall through */
11144         case SAVEt_CLEARSV:
11145             longval = (long)POPLONG(ss,ix);
11146             TOPLONG(nss,ix) = longval;
11147             break;
11148         case SAVEt_I32:                         /* I32 reference */
11149         case SAVEt_I16:                         /* I16 reference */
11150         case SAVEt_I8:                          /* I8 reference */
11151         case SAVEt_COP_ARYBASE:                 /* call CopARYBASE_set */
11152             ptr = POPPTR(ss,ix);
11153             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11154             i = POPINT(ss,ix);
11155             TOPINT(nss,ix) = i;
11156             break;
11157         case SAVEt_IV:                          /* IV reference */
11158             ptr = POPPTR(ss,ix);
11159             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11160             iv = POPIV(ss,ix);
11161             TOPIV(nss,ix) = iv;
11162             break;
11163         case SAVEt_HPTR:                        /* HV* reference */
11164         case SAVEt_APTR:                        /* AV* reference */
11165         case SAVEt_SPTR:                        /* SV* reference */
11166             ptr = POPPTR(ss,ix);
11167             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11168             sv = (SV*)POPPTR(ss,ix);
11169             TOPPTR(nss,ix) = sv_dup(sv, param);
11170             break;
11171         case SAVEt_VPTR:                        /* random* reference */
11172             ptr = POPPTR(ss,ix);
11173             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11174             ptr = POPPTR(ss,ix);
11175             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11176             break;
11177         case SAVEt_GENERIC_PVREF:               /* generic char* */
11178         case SAVEt_PPTR:                        /* char* reference */
11179             ptr = POPPTR(ss,ix);
11180             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11181             c = (char*)POPPTR(ss,ix);
11182             TOPPTR(nss,ix) = pv_dup(c);
11183             break;
11184         case SAVEt_GP:                          /* scalar reference */
11185             gp = (GP*)POPPTR(ss,ix);
11186             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11187             (void)GpREFCNT_inc(gp);
11188             gv = (GV*)POPPTR(ss,ix);
11189             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11190             break;
11191         case SAVEt_FREEOP:
11192             ptr = POPPTR(ss,ix);
11193             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11194                 /* these are assumed to be refcounted properly */
11195                 OP *o;
11196                 switch (((OP*)ptr)->op_type) {
11197                 case OP_LEAVESUB:
11198                 case OP_LEAVESUBLV:
11199                 case OP_LEAVEEVAL:
11200                 case OP_LEAVE:
11201                 case OP_SCOPE:
11202                 case OP_LEAVEWRITE:
11203                     TOPPTR(nss,ix) = ptr;
11204                     o = (OP*)ptr;
11205                     OP_REFCNT_LOCK;
11206                     (void) OpREFCNT_inc(o);
11207                     OP_REFCNT_UNLOCK;
11208                     break;
11209                 default:
11210                     TOPPTR(nss,ix) = NULL;
11211                     break;
11212                 }
11213             }
11214             else
11215                 TOPPTR(nss,ix) = NULL;
11216             break;
11217         case SAVEt_FREEPV:
11218             c = (char*)POPPTR(ss,ix);
11219             TOPPTR(nss,ix) = pv_dup_inc(c);
11220             break;
11221         case SAVEt_DELETE:
11222             hv = (const HV *)POPPTR(ss,ix);
11223             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11224             c = (char*)POPPTR(ss,ix);
11225             TOPPTR(nss,ix) = pv_dup_inc(c);
11226             /* fall through */
11227         case SAVEt_STACK_POS:           /* Position on Perl stack */
11228             i = POPINT(ss,ix);
11229             TOPINT(nss,ix) = i;
11230             break;
11231         case SAVEt_DESTRUCTOR:
11232             ptr = POPPTR(ss,ix);
11233             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11234             dptr = POPDPTR(ss,ix);
11235             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11236                                         any_dup(FPTR2DPTR(void *, dptr),
11237                                                 proto_perl));
11238             break;
11239         case SAVEt_DESTRUCTOR_X:
11240             ptr = POPPTR(ss,ix);
11241             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11242             dxptr = POPDXPTR(ss,ix);
11243             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11244                                          any_dup(FPTR2DPTR(void *, dxptr),
11245                                                  proto_perl));
11246             break;
11247         case SAVEt_REGCONTEXT:
11248         case SAVEt_ALLOC:
11249             i = POPINT(ss,ix);
11250             TOPINT(nss,ix) = i;
11251             ix -= i;
11252             break;
11253         case SAVEt_AELEM:               /* array element */
11254             sv = (SV*)POPPTR(ss,ix);
11255             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11256             i = POPINT(ss,ix);
11257             TOPINT(nss,ix) = i;
11258             av = (const AV *)POPPTR(ss,ix);
11259             TOPPTR(nss,ix) = av_dup_inc(av, param);
11260             break;
11261         case SAVEt_OP:
11262             ptr = POPPTR(ss,ix);
11263             TOPPTR(nss,ix) = ptr;
11264             break;
11265         case SAVEt_HINTS:
11266             i = POPINT(ss,ix);
11267             TOPINT(nss,ix) = i;
11268             ptr = POPPTR(ss,ix);
11269             if (ptr) {
11270                 HINTS_REFCNT_LOCK;
11271                 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11272                 HINTS_REFCNT_UNLOCK;
11273             }
11274             TOPPTR(nss,ix) = ptr;
11275             if (i & HINT_LOCALIZE_HH) {
11276                 hv = (const HV *)POPPTR(ss,ix);
11277                 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11278             }
11279             break;
11280         case SAVEt_PADSV_AND_MORTALIZE:
11281             longval = (long)POPLONG(ss,ix);
11282             TOPLONG(nss,ix) = longval;
11283             ptr = POPPTR(ss,ix);
11284             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11285             sv = (SV*)POPPTR(ss,ix);
11286             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11287             break;
11288         case SAVEt_BOOL:
11289             ptr = POPPTR(ss,ix);
11290             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11291             longval = (long)POPBOOL(ss,ix);
11292             TOPBOOL(nss,ix) = (bool)longval;
11293             break;
11294         case SAVEt_SET_SVFLAGS:
11295             i = POPINT(ss,ix);
11296             TOPINT(nss,ix) = i;
11297             i = POPINT(ss,ix);
11298             TOPINT(nss,ix) = i;
11299             sv = (SV*)POPPTR(ss,ix);
11300             TOPPTR(nss,ix) = sv_dup(sv, param);
11301             break;
11302         case SAVEt_RE_STATE:
11303             {
11304                 const struct re_save_state *const old_state
11305                     = (struct re_save_state *)
11306                     (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11307                 struct re_save_state *const new_state
11308                     = (struct re_save_state *)
11309                     (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11310
11311                 Copy(old_state, new_state, 1, struct re_save_state);
11312                 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11313
11314                 new_state->re_state_bostr
11315                     = pv_dup(old_state->re_state_bostr);
11316                 new_state->re_state_reginput
11317                     = pv_dup(old_state->re_state_reginput);
11318                 new_state->re_state_regeol
11319                     = pv_dup(old_state->re_state_regeol);
11320                 new_state->re_state_regoffs
11321                     = (regexp_paren_pair*)
11322                         any_dup(old_state->re_state_regoffs, proto_perl);
11323                 new_state->re_state_reglastparen
11324                     = (U32*) any_dup(old_state->re_state_reglastparen,
11325                               proto_perl);
11326                 new_state->re_state_reglastcloseparen
11327                     = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11328                               proto_perl);
11329                 /* XXX This just has to be broken. The old save_re_context
11330                    code did SAVEGENERICPV(PL_reg_start_tmp);
11331                    PL_reg_start_tmp is char **.
11332                    Look above to what the dup code does for
11333                    SAVEt_GENERIC_PVREF
11334                    It can never have worked.
11335                    So this is merely a faithful copy of the exiting bug:  */
11336                 new_state->re_state_reg_start_tmp
11337                     = (char **) pv_dup((char *)
11338                                       old_state->re_state_reg_start_tmp);
11339                 /* I assume that it only ever "worked" because no-one called
11340                    (pseudo)fork while the regexp engine had re-entered itself.
11341                 */
11342 #ifdef PERL_OLD_COPY_ON_WRITE
11343                 new_state->re_state_nrs
11344                     = sv_dup(old_state->re_state_nrs, param);
11345 #endif
11346                 new_state->re_state_reg_magic
11347                     = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11348                                proto_perl);
11349                 new_state->re_state_reg_oldcurpm
11350                     = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11351                               proto_perl);
11352                 new_state->re_state_reg_curpm
11353                     = (PMOP*)  any_dup(old_state->re_state_reg_curpm,
11354                                proto_perl);
11355                 new_state->re_state_reg_oldsaved
11356                     = pv_dup(old_state->re_state_reg_oldsaved);
11357                 new_state->re_state_reg_poscache
11358                     = pv_dup(old_state->re_state_reg_poscache);
11359                 new_state->re_state_reg_starttry
11360                     = pv_dup(old_state->re_state_reg_starttry);
11361                 break;
11362             }
11363         case SAVEt_COMPILE_WARNINGS:
11364             ptr = POPPTR(ss,ix);
11365             TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11366             break;
11367         case SAVEt_PARSER:
11368             ptr = POPPTR(ss,ix);
11369             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11370             break;
11371         default:
11372             Perl_croak(aTHX_
11373                        "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11374         }
11375     }
11376
11377     return nss;
11378 }
11379
11380
11381 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11382  * flag to the result. This is done for each stash before cloning starts,
11383  * so we know which stashes want their objects cloned */
11384
11385 static void
11386 do_mark_cloneable_stash(pTHX_ SV *const sv)
11387 {
11388     const HEK * const hvname = HvNAME_HEK((const HV *)sv);
11389     if (hvname) {
11390         GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
11391         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11392         if (cloner && GvCV(cloner)) {
11393             dSP;
11394             UV status;
11395
11396             ENTER;
11397             SAVETMPS;
11398             PUSHMARK(SP);
11399             mXPUSHs(newSVhek(hvname));
11400             PUTBACK;
11401             call_sv((SV*)GvCV(cloner), G_SCALAR);
11402             SPAGAIN;
11403             status = POPu;
11404             PUTBACK;
11405             FREETMPS;
11406             LEAVE;
11407             if (status)
11408                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11409         }
11410     }
11411 }
11412
11413
11414
11415 /*
11416 =for apidoc perl_clone
11417
11418 Create and return a new interpreter by cloning the current one.
11419
11420 perl_clone takes these flags as parameters:
11421
11422 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11423 without it we only clone the data and zero the stacks,
11424 with it we copy the stacks and the new perl interpreter is
11425 ready to run at the exact same point as the previous one.
11426 The pseudo-fork code uses COPY_STACKS while the
11427 threads->create doesn't.
11428
11429 CLONEf_KEEP_PTR_TABLE
11430 perl_clone keeps a ptr_table with the pointer of the old
11431 variable as a key and the new variable as a value,
11432 this allows it to check if something has been cloned and not
11433 clone it again but rather just use the value and increase the
11434 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11435 the ptr_table using the function
11436 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11437 reason to keep it around is if you want to dup some of your own
11438 variable who are outside the graph perl scans, example of this
11439 code is in threads.xs create
11440
11441 CLONEf_CLONE_HOST
11442 This is a win32 thing, it is ignored on unix, it tells perls
11443 win32host code (which is c++) to clone itself, this is needed on
11444 win32 if you want to run two threads at the same time,
11445 if you just want to do some stuff in a separate perl interpreter
11446 and then throw it away and return to the original one,
11447 you don't need to do anything.
11448
11449 =cut
11450 */
11451
11452 /* XXX the above needs expanding by someone who actually understands it ! */
11453 EXTERN_C PerlInterpreter *
11454 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11455
11456 PerlInterpreter *
11457 perl_clone(PerlInterpreter *proto_perl, UV flags)
11458 {
11459    dVAR;
11460 #ifdef PERL_IMPLICIT_SYS
11461
11462     PERL_ARGS_ASSERT_PERL_CLONE;
11463
11464    /* perlhost.h so we need to call into it
11465    to clone the host, CPerlHost should have a c interface, sky */
11466
11467    if (flags & CLONEf_CLONE_HOST) {
11468        return perl_clone_host(proto_perl,flags);
11469    }
11470    return perl_clone_using(proto_perl, flags,
11471                             proto_perl->IMem,
11472                             proto_perl->IMemShared,
11473                             proto_perl->IMemParse,
11474                             proto_perl->IEnv,
11475                             proto_perl->IStdIO,
11476                             proto_perl->ILIO,
11477                             proto_perl->IDir,
11478                             proto_perl->ISock,
11479                             proto_perl->IProc);
11480 }
11481
11482 PerlInterpreter *
11483 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11484                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
11485                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11486                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11487                  struct IPerlDir* ipD, struct IPerlSock* ipS,
11488                  struct IPerlProc* ipP)
11489 {
11490     /* XXX many of the string copies here can be optimized if they're
11491      * constants; they need to be allocated as common memory and just
11492      * their pointers copied. */
11493
11494     IV i;
11495     CLONE_PARAMS clone_params;
11496     CLONE_PARAMS* const param = &clone_params;
11497
11498     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11499
11500     PERL_ARGS_ASSERT_PERL_CLONE_USING;
11501
11502     /* for each stash, determine whether its objects should be cloned */
11503     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11504     PERL_SET_THX(my_perl);
11505
11506 #  ifdef DEBUGGING
11507     PoisonNew(my_perl, 1, PerlInterpreter);
11508     PL_op = NULL;
11509     PL_curcop = NULL;
11510     PL_markstack = 0;
11511     PL_scopestack = 0;
11512     PL_savestack = 0;
11513     PL_savestack_ix = 0;
11514     PL_savestack_max = -1;
11515     PL_sig_pending = 0;
11516     PL_parser = NULL;
11517     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11518 #  else /* !DEBUGGING */
11519     Zero(my_perl, 1, PerlInterpreter);
11520 #  endif        /* DEBUGGING */
11521
11522     /* host pointers */
11523     PL_Mem              = ipM;
11524     PL_MemShared        = ipMS;
11525     PL_MemParse         = ipMP;
11526     PL_Env              = ipE;
11527     PL_StdIO            = ipStd;
11528     PL_LIO              = ipLIO;
11529     PL_Dir              = ipD;
11530     PL_Sock             = ipS;
11531     PL_Proc             = ipP;
11532 #else           /* !PERL_IMPLICIT_SYS */
11533     IV i;
11534     CLONE_PARAMS clone_params;
11535     CLONE_PARAMS* param = &clone_params;
11536     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11537
11538     PERL_ARGS_ASSERT_PERL_CLONE;
11539
11540     /* for each stash, determine whether its objects should be cloned */
11541     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11542     PERL_SET_THX(my_perl);
11543
11544 #    ifdef DEBUGGING
11545     PoisonNew(my_perl, 1, PerlInterpreter);
11546     PL_op = NULL;
11547     PL_curcop = NULL;
11548     PL_markstack = 0;
11549     PL_scopestack = 0;
11550     PL_savestack = 0;
11551     PL_savestack_ix = 0;
11552     PL_savestack_max = -1;
11553     PL_sig_pending = 0;
11554     PL_parser = NULL;
11555     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11556 #    else       /* !DEBUGGING */
11557     Zero(my_perl, 1, PerlInterpreter);
11558 #    endif      /* DEBUGGING */
11559 #endif          /* PERL_IMPLICIT_SYS */
11560     param->flags = flags;
11561     param->proto_perl = proto_perl;
11562
11563     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11564
11565     PL_body_arenas = NULL;
11566     Zero(&PL_body_roots, 1, PL_body_roots);
11567
11568     PL_nice_chunk       = NULL;
11569     PL_nice_chunk_size  = 0;
11570     PL_sv_count         = 0;
11571     PL_sv_objcount      = 0;
11572     PL_sv_root          = NULL;
11573     PL_sv_arenaroot     = NULL;
11574
11575     PL_debug            = proto_perl->Idebug;
11576
11577     PL_hash_seed        = proto_perl->Ihash_seed;
11578     PL_rehash_seed      = proto_perl->Irehash_seed;
11579
11580 #ifdef USE_REENTRANT_API
11581     /* XXX: things like -Dm will segfault here in perlio, but doing
11582      *  PERL_SET_CONTEXT(proto_perl);
11583      * breaks too many other things
11584      */
11585     Perl_reentrant_init(aTHX);
11586 #endif
11587
11588     /* create SV map for pointer relocation */
11589     PL_ptr_table = ptr_table_new();
11590
11591     /* initialize these special pointers as early as possible */
11592     SvANY(&PL_sv_undef)         = NULL;
11593     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
11594     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
11595     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11596
11597     SvANY(&PL_sv_no)            = new_XPVNV();
11598     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
11599     SvFLAGS(&PL_sv_no)          = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11600                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11601     SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
11602     SvCUR_set(&PL_sv_no, 0);
11603     SvLEN_set(&PL_sv_no, 1);
11604     SvIV_set(&PL_sv_no, 0);
11605     SvNV_set(&PL_sv_no, 0);
11606     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11607
11608     SvANY(&PL_sv_yes)           = new_XPVNV();
11609     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
11610     SvFLAGS(&PL_sv_yes)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11611                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11612     SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
11613     SvCUR_set(&PL_sv_yes, 1);
11614     SvLEN_set(&PL_sv_yes, 2);
11615     SvIV_set(&PL_sv_yes, 1);
11616     SvNV_set(&PL_sv_yes, 1);
11617     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11618
11619     /* create (a non-shared!) shared string table */
11620     PL_strtab           = newHV();
11621     HvSHAREKEYS_off(PL_strtab);
11622     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11623     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11624
11625     PL_compiling = proto_perl->Icompiling;
11626
11627     /* These two PVs will be free'd special way so must set them same way op.c does */
11628     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11629     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11630
11631     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
11632     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11633
11634     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11635     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
11636     if (PL_compiling.cop_hints_hash) {
11637         HINTS_REFCNT_LOCK;
11638         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
11639         HINTS_REFCNT_UNLOCK;
11640     }
11641     PL_curcop           = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
11642 #ifdef PERL_DEBUG_READONLY_OPS
11643     PL_slabs = NULL;
11644     PL_slab_count = 0;
11645 #endif
11646
11647     /* pseudo environmental stuff */
11648     PL_origargc         = proto_perl->Iorigargc;
11649     PL_origargv         = proto_perl->Iorigargv;
11650
11651     param->stashes      = newAV();  /* Setup array of objects to call clone on */
11652
11653     /* Set tainting stuff before PerlIO_debug can possibly get called */
11654     PL_tainting         = proto_perl->Itainting;
11655     PL_taint_warn       = proto_perl->Itaint_warn;
11656
11657 #ifdef PERLIO_LAYERS
11658     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11659     PerlIO_clone(aTHX_ proto_perl, param);
11660 #endif
11661
11662     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
11663     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
11664     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
11665     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
11666     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
11667     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
11668
11669     /* switches */
11670     PL_minus_c          = proto_perl->Iminus_c;
11671     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
11672     PL_localpatches     = proto_perl->Ilocalpatches;
11673     PL_splitstr         = proto_perl->Isplitstr;
11674     PL_minus_n          = proto_perl->Iminus_n;
11675     PL_minus_p          = proto_perl->Iminus_p;
11676     PL_minus_l          = proto_perl->Iminus_l;
11677     PL_minus_a          = proto_perl->Iminus_a;
11678     PL_minus_E          = proto_perl->Iminus_E;
11679     PL_minus_F          = proto_perl->Iminus_F;
11680     PL_doswitches       = proto_perl->Idoswitches;
11681     PL_dowarn           = proto_perl->Idowarn;
11682     PL_doextract        = proto_perl->Idoextract;
11683     PL_sawampersand     = proto_perl->Isawampersand;
11684     PL_unsafe           = proto_perl->Iunsafe;
11685     PL_inplace          = SAVEPV(proto_perl->Iinplace);
11686     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
11687     PL_perldb           = proto_perl->Iperldb;
11688     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11689     PL_exit_flags       = proto_perl->Iexit_flags;
11690
11691     /* magical thingies */
11692     /* XXX time(&PL_basetime) when asked for? */
11693     PL_basetime         = proto_perl->Ibasetime;
11694     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
11695
11696     PL_maxsysfd         = proto_perl->Imaxsysfd;
11697     PL_statusvalue      = proto_perl->Istatusvalue;
11698 #ifdef VMS
11699     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
11700 #else
11701     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11702 #endif
11703     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
11704
11705     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
11706     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
11707     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
11708
11709
11710     /* RE engine related */
11711     Zero(&PL_reg_state, 1, struct re_save_state);
11712     PL_reginterp_cnt    = 0;
11713     PL_regmatch_slab    = NULL;
11714
11715     /* Clone the regex array */
11716     /* ORANGE FIXME for plugins, probably in the SV dup code.
11717        newSViv(PTR2IV(CALLREGDUPE(
11718        INT2PTR(REGEXP *, SvIVX(regex)), param))))
11719     */
11720     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
11721     PL_regex_pad = AvARRAY(PL_regex_padav);
11722
11723     /* shortcuts to various I/O objects */
11724     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
11725     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
11726     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
11727     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
11728     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
11729     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
11730
11731     /* shortcuts to regexp stuff */
11732     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
11733
11734     /* shortcuts to misc objects */
11735     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
11736
11737     /* shortcuts to debugging objects */
11738     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
11739     PL_DBline           = gv_dup(proto_perl->IDBline, param);
11740     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
11741     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
11742     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
11743     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
11744     PL_dbargs           = av_dup(proto_perl->Idbargs, param);
11745
11746     /* symbol tables */
11747     PL_defstash         = hv_dup_inc(proto_perl->Idefstash, param);
11748     PL_curstash         = hv_dup(proto_perl->Icurstash, param);
11749     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
11750     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
11751     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
11752
11753     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
11754     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
11755     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
11756     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
11757     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
11758     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
11759     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
11760     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
11761
11762     PL_sub_generation   = proto_perl->Isub_generation;
11763     PL_isarev           = hv_dup_inc(proto_perl->Iisarev, param);
11764
11765     /* funky return mechanisms */
11766     PL_forkprocess      = proto_perl->Iforkprocess;
11767
11768     /* subprocess state */
11769     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
11770
11771     /* internal state */
11772     PL_maxo             = proto_perl->Imaxo;
11773     if (proto_perl->Iop_mask)
11774         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11775     else
11776         PL_op_mask      = NULL;
11777     /* PL_asserting        = proto_perl->Iasserting; */
11778
11779     /* current interpreter roots */
11780     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
11781     OP_REFCNT_LOCK;
11782     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
11783     OP_REFCNT_UNLOCK;
11784     PL_main_start       = proto_perl->Imain_start;
11785     PL_eval_root        = proto_perl->Ieval_root;
11786     PL_eval_start       = proto_perl->Ieval_start;
11787
11788     /* runtime control stuff */
11789     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11790
11791     PL_filemode         = proto_perl->Ifilemode;
11792     PL_lastfd           = proto_perl->Ilastfd;
11793     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
11794     PL_Argv             = NULL;
11795     PL_Cmd              = NULL;
11796     PL_gensym           = proto_perl->Igensym;
11797     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
11798     PL_laststatval      = proto_perl->Ilaststatval;
11799     PL_laststype        = proto_perl->Ilaststype;
11800     PL_mess_sv          = NULL;
11801
11802     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
11803
11804     /* interpreter atexit processing */
11805     PL_exitlistlen      = proto_perl->Iexitlistlen;
11806     if (PL_exitlistlen) {
11807         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11808         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11809     }
11810     else
11811         PL_exitlist     = (PerlExitListEntry*)NULL;
11812
11813     PL_my_cxt_size = proto_perl->Imy_cxt_size;
11814     if (PL_my_cxt_size) {
11815         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
11816         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
11817 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
11818         Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
11819         Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
11820 #endif
11821     }
11822     else {
11823         PL_my_cxt_list  = (void**)NULL;
11824 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
11825         PL_my_cxt_keys  = (const char**)NULL;
11826 #endif
11827     }
11828     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
11829     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
11830     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11831
11832     PL_profiledata      = NULL;
11833
11834     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
11835
11836     PAD_CLONE_VARS(proto_perl, param);
11837
11838 #ifdef HAVE_INTERP_INTERN
11839     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11840 #endif
11841
11842     /* more statics moved here */
11843     PL_generation       = proto_perl->Igeneration;
11844     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
11845
11846     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
11847     PL_in_clean_all     = proto_perl->Iin_clean_all;
11848
11849     PL_uid              = proto_perl->Iuid;
11850     PL_euid             = proto_perl->Ieuid;
11851     PL_gid              = proto_perl->Igid;
11852     PL_egid             = proto_perl->Iegid;
11853     PL_nomemok          = proto_perl->Inomemok;
11854     PL_an               = proto_perl->Ian;
11855     PL_evalseq          = proto_perl->Ievalseq;
11856     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
11857     PL_origalen         = proto_perl->Iorigalen;
11858 #ifdef PERL_USES_PL_PIDSTATUS
11859     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
11860 #endif
11861     PL_osname           = SAVEPV(proto_perl->Iosname);
11862     PL_sighandlerp      = proto_perl->Isighandlerp;
11863
11864     PL_runops           = proto_perl->Irunops;
11865
11866     PL_parser           = parser_dup(proto_perl->Iparser, param);
11867
11868     PL_subline          = proto_perl->Isubline;
11869     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
11870
11871 #ifdef FCRYPT
11872     PL_cryptseen        = proto_perl->Icryptseen;
11873 #endif
11874
11875     PL_hints            = proto_perl->Ihints;
11876
11877     PL_amagic_generation        = proto_perl->Iamagic_generation;
11878
11879 #ifdef USE_LOCALE_COLLATE
11880     PL_collation_ix     = proto_perl->Icollation_ix;
11881     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
11882     PL_collation_standard       = proto_perl->Icollation_standard;
11883     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
11884     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
11885 #endif /* USE_LOCALE_COLLATE */
11886
11887 #ifdef USE_LOCALE_NUMERIC
11888     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
11889     PL_numeric_standard = proto_perl->Inumeric_standard;
11890     PL_numeric_local    = proto_perl->Inumeric_local;
11891     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11892 #endif /* !USE_LOCALE_NUMERIC */
11893
11894     /* utf8 character classes */
11895     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11896     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11897     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11898     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11899     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
11900     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11901     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
11902     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
11903     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
11904     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
11905     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
11906     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
11907     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11908     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
11909     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11910     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11911     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11912     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11913     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11914     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11915
11916     /* Did the locale setup indicate UTF-8? */
11917     PL_utf8locale       = proto_perl->Iutf8locale;
11918     /* Unicode features (see perlrun/-C) */
11919     PL_unicode          = proto_perl->Iunicode;
11920
11921     /* Pre-5.8 signals control */
11922     PL_signals          = proto_perl->Isignals;
11923
11924     /* times() ticks per second */
11925     PL_clocktick        = proto_perl->Iclocktick;
11926
11927     /* Recursion stopper for PerlIO_find_layer */
11928     PL_in_load_module   = proto_perl->Iin_load_module;
11929
11930     /* sort() routine */
11931     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
11932
11933     /* Not really needed/useful since the reenrant_retint is "volatile",
11934      * but do it for consistency's sake. */
11935     PL_reentrant_retint = proto_perl->Ireentrant_retint;
11936
11937     /* Hooks to shared SVs and locks. */
11938     PL_sharehook        = proto_perl->Isharehook;
11939     PL_lockhook         = proto_perl->Ilockhook;
11940     PL_unlockhook       = proto_perl->Iunlockhook;
11941     PL_threadhook       = proto_perl->Ithreadhook;
11942     PL_destroyhook      = proto_perl->Idestroyhook;
11943
11944 #ifdef THREADS_HAVE_PIDS
11945     PL_ppid             = proto_perl->Ippid;
11946 #endif
11947
11948     /* swatch cache */
11949     PL_last_swash_hv    = NULL; /* reinits on demand */
11950     PL_last_swash_klen  = 0;
11951     PL_last_swash_key[0]= '\0';
11952     PL_last_swash_tmps  = (U8*)NULL;
11953     PL_last_swash_slen  = 0;
11954
11955     PL_glob_index       = proto_perl->Iglob_index;
11956     PL_srand_called     = proto_perl->Isrand_called;
11957     PL_bitcount         = NULL; /* reinits on demand */
11958
11959     if (proto_perl->Ipsig_pend) {
11960         Newxz(PL_psig_pend, SIG_SIZE, int);
11961     }
11962     else {
11963         PL_psig_pend    = (int*)NULL;
11964     }
11965
11966     if (proto_perl->Ipsig_ptr) {
11967         Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
11968         Newxz(PL_psig_name, SIG_SIZE, SV*);
11969         for (i = 1; i < SIG_SIZE; i++) {
11970             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11971             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11972         }
11973     }
11974     else {
11975         PL_psig_ptr     = (SV**)NULL;
11976         PL_psig_name    = (SV**)NULL;
11977     }
11978
11979     /* intrpvar.h stuff */
11980
11981     if (flags & CLONEf_COPY_STACKS) {
11982         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11983         PL_tmps_ix              = proto_perl->Itmps_ix;
11984         PL_tmps_max             = proto_perl->Itmps_max;
11985         PL_tmps_floor           = proto_perl->Itmps_floor;
11986         Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11987         i = 0;
11988         while (i <= PL_tmps_ix) {
11989             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Itmps_stack[i], param);
11990             ++i;
11991         }
11992
11993         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11994         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
11995         Newxz(PL_markstack, i, I32);
11996         PL_markstack_max        = PL_markstack + (proto_perl->Imarkstack_max
11997                                                   - proto_perl->Imarkstack);
11998         PL_markstack_ptr        = PL_markstack + (proto_perl->Imarkstack_ptr
11999                                                   - proto_perl->Imarkstack);
12000         Copy(proto_perl->Imarkstack, PL_markstack,
12001              PL_markstack_ptr - PL_markstack + 1, I32);
12002
12003         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12004          * NOTE: unlike the others! */
12005         PL_scopestack_ix        = proto_perl->Iscopestack_ix;
12006         PL_scopestack_max       = proto_perl->Iscopestack_max;
12007         Newxz(PL_scopestack, PL_scopestack_max, I32);
12008         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12009
12010         /* NOTE: si_dup() looks at PL_markstack */
12011         PL_curstackinfo         = si_dup(proto_perl->Icurstackinfo, param);
12012
12013         /* PL_curstack          = PL_curstackinfo->si_stack; */
12014         PL_curstack             = av_dup(proto_perl->Icurstack, param);
12015         PL_mainstack            = av_dup(proto_perl->Imainstack, param);
12016
12017         /* next PUSHs() etc. set *(PL_stack_sp+1) */
12018         PL_stack_base           = AvARRAY(PL_curstack);
12019         PL_stack_sp             = PL_stack_base + (proto_perl->Istack_sp
12020                                                    - proto_perl->Istack_base);
12021         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
12022
12023         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12024          * NOTE: unlike the others! */
12025         PL_savestack_ix         = proto_perl->Isavestack_ix;
12026         PL_savestack_max        = proto_perl->Isavestack_max;
12027         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12028         PL_savestack            = ss_dup(proto_perl, param);
12029     }
12030     else {
12031         init_stacks();
12032         ENTER;                  /* perl_destruct() wants to LEAVE; */
12033
12034         /* although we're not duplicating the tmps stack, we should still
12035          * add entries for any SVs on the tmps stack that got cloned by a
12036          * non-refcount means (eg a temp in @_); otherwise they will be
12037          * orphaned
12038          */
12039         for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12040             SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
12041                     proto_perl->Itmps_stack[i]);
12042             if (nsv && !SvREFCNT(nsv)) {
12043                 EXTEND_MORTAL(1);
12044                 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
12045             }
12046         }
12047     }
12048
12049     PL_start_env        = proto_perl->Istart_env;       /* XXXXXX */
12050     PL_top_env          = &PL_start_env;
12051
12052     PL_op               = proto_perl->Iop;
12053
12054     PL_Sv               = NULL;
12055     PL_Xpv              = (XPV*)NULL;
12056     my_perl->Ina        = proto_perl->Ina;
12057
12058     PL_statbuf          = proto_perl->Istatbuf;
12059     PL_statcache        = proto_perl->Istatcache;
12060     PL_statgv           = gv_dup(proto_perl->Istatgv, param);
12061     PL_statname         = sv_dup_inc(proto_perl->Istatname, param);
12062 #ifdef HAS_TIMES
12063     PL_timesbuf         = proto_perl->Itimesbuf;
12064 #endif
12065
12066     PL_tainted          = proto_perl->Itainted;
12067     PL_curpm            = proto_perl->Icurpm;   /* XXX No PMOP ref count */
12068     PL_rs               = sv_dup_inc(proto_perl->Irs, param);
12069     PL_last_in_gv       = gv_dup(proto_perl->Ilast_in_gv, param);
12070     PL_ofs_sv           = sv_dup_inc(proto_perl->Iofs_sv, param);
12071     PL_defoutgv         = gv_dup_inc(proto_perl->Idefoutgv, param);
12072     PL_chopset          = proto_perl->Ichopset; /* XXX never deallocated */
12073     PL_toptarget        = sv_dup_inc(proto_perl->Itoptarget, param);
12074     PL_bodytarget       = sv_dup_inc(proto_perl->Ibodytarget, param);
12075     PL_formtarget       = sv_dup(proto_perl->Iformtarget, param);
12076
12077     PL_restartop        = proto_perl->Irestartop;
12078     PL_in_eval          = proto_perl->Iin_eval;
12079     PL_delaymagic       = proto_perl->Idelaymagic;
12080     PL_dirty            = proto_perl->Idirty;
12081     PL_localizing       = proto_perl->Ilocalizing;
12082
12083     PL_errors           = sv_dup_inc(proto_perl->Ierrors, param);
12084     PL_hv_fetch_ent_mh  = NULL;
12085     PL_modcount         = proto_perl->Imodcount;
12086     PL_lastgotoprobe    = NULL;
12087     PL_dumpindent       = proto_perl->Idumpindent;
12088
12089     PL_sortcop          = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12090     PL_sortstash        = hv_dup(proto_perl->Isortstash, param);
12091     PL_firstgv          = gv_dup(proto_perl->Ifirstgv, param);
12092     PL_secondgv         = gv_dup(proto_perl->Isecondgv, param);
12093     PL_efloatbuf        = NULL;         /* reinits on demand */
12094     PL_efloatsize       = 0;                    /* reinits on demand */
12095
12096     /* regex stuff */
12097
12098     PL_screamfirst      = NULL;
12099     PL_screamnext       = NULL;
12100     PL_maxscream        = -1;                   /* reinits on demand */
12101     PL_lastscream       = NULL;
12102
12103
12104     PL_regdummy         = proto_perl->Iregdummy;
12105     PL_colorset         = 0;            /* reinits PL_colors[] */
12106     /*PL_colors[6]      = {0,0,0,0,0,0};*/
12107
12108
12109
12110     /* Pluggable optimizer */
12111     PL_peepp            = proto_perl->Ipeepp;
12112
12113     PL_stashcache       = newHV();
12114
12115     PL_watchaddr        = (char **) ptr_table_fetch(PL_ptr_table,
12116                                             proto_perl->Iwatchaddr);
12117     PL_watchok          = PL_watchaddr ? * PL_watchaddr : NULL;
12118     if (PL_debug && PL_watchaddr) {
12119         PerlIO_printf(Perl_debug_log,
12120           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12121           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12122           PTR2UV(PL_watchok));
12123     }
12124
12125     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12126         ptr_table_free(PL_ptr_table);
12127         PL_ptr_table = NULL;
12128     }
12129
12130     /* Call the ->CLONE method, if it exists, for each of the stashes
12131        identified by sv_dup() above.
12132     */
12133     while(av_len(param->stashes) != -1) {
12134         HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12135         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12136         if (cloner && GvCV(cloner)) {
12137             dSP;
12138             ENTER;
12139             SAVETMPS;
12140             PUSHMARK(SP);
12141             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12142             PUTBACK;
12143             call_sv((SV*)GvCV(cloner), G_DISCARD);
12144             FREETMPS;
12145             LEAVE;
12146         }
12147     }
12148
12149     SvREFCNT_dec(param->stashes);
12150
12151     /* orphaned? eg threads->new inside BEGIN or use */
12152     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12153         SvREFCNT_inc_simple_void(PL_compcv);
12154         SAVEFREESV(PL_compcv);
12155     }
12156
12157     return my_perl;
12158 }
12159
12160 #endif /* USE_ITHREADS */
12161
12162 /*
12163 =head1 Unicode Support
12164
12165 =for apidoc sv_recode_to_utf8
12166
12167 The encoding is assumed to be an Encode object, on entry the PV
12168 of the sv is assumed to be octets in that encoding, and the sv
12169 will be converted into Unicode (and UTF-8).
12170
12171 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12172 is not a reference, nothing is done to the sv.  If the encoding is not
12173 an C<Encode::XS> Encoding object, bad things will happen.
12174 (See F<lib/encoding.pm> and L<Encode>).
12175
12176 The PV of the sv is returned.
12177
12178 =cut */
12179
12180 char *
12181 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12182 {
12183     dVAR;
12184
12185     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12186
12187     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12188         SV *uni;
12189         STRLEN len;
12190         const char *s;
12191         dSP;
12192         ENTER;
12193         SAVETMPS;
12194         save_re_context();
12195         PUSHMARK(sp);
12196         EXTEND(SP, 3);
12197         XPUSHs(encoding);
12198         XPUSHs(sv);
12199 /*
12200   NI-S 2002/07/09
12201   Passing sv_yes is wrong - it needs to be or'ed set of constants
12202   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12203   remove converted chars from source.
12204
12205   Both will default the value - let them.
12206
12207         XPUSHs(&PL_sv_yes);
12208 */
12209         PUTBACK;
12210         call_method("decode", G_SCALAR);
12211         SPAGAIN;
12212         uni = POPs;
12213         PUTBACK;
12214         s = SvPV_const(uni, len);
12215         if (s != SvPVX_const(sv)) {
12216             SvGROW(sv, len + 1);
12217             Move(s, SvPVX(sv), len + 1, char);
12218             SvCUR_set(sv, len);
12219         }
12220         FREETMPS;
12221         LEAVE;
12222         SvUTF8_on(sv);
12223         return SvPVX(sv);
12224     }
12225     return SvPOKp(sv) ? SvPVX(sv) : NULL;
12226 }
12227
12228 /*
12229 =for apidoc sv_cat_decode
12230
12231 The encoding is assumed to be an Encode object, the PV of the ssv is
12232 assumed to be octets in that encoding and decoding the input starts
12233 from the position which (PV + *offset) pointed to.  The dsv will be
12234 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
12235 when the string tstr appears in decoding output or the input ends on
12236 the PV of the ssv. The value which the offset points will be modified
12237 to the last input position on the ssv.
12238
12239 Returns TRUE if the terminator was found, else returns FALSE.
12240
12241 =cut */
12242
12243 bool
12244 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12245                    SV *ssv, int *offset, char *tstr, int tlen)
12246 {
12247     dVAR;
12248     bool ret = FALSE;
12249
12250     PERL_ARGS_ASSERT_SV_CAT_DECODE;
12251
12252     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12253         SV *offsv;
12254         dSP;
12255         ENTER;
12256         SAVETMPS;
12257         save_re_context();
12258         PUSHMARK(sp);
12259         EXTEND(SP, 6);
12260         XPUSHs(encoding);
12261         XPUSHs(dsv);
12262         XPUSHs(ssv);
12263         offsv = newSViv(*offset);
12264         mXPUSHs(offsv);
12265         mXPUSHp(tstr, tlen);
12266         PUTBACK;
12267         call_method("cat_decode", G_SCALAR);
12268         SPAGAIN;
12269         ret = SvTRUE(TOPs);
12270         *offset = SvIV(offsv);
12271         PUTBACK;
12272         FREETMPS;
12273         LEAVE;
12274     }
12275     else
12276         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12277     return ret;
12278
12279 }
12280
12281 /* ---------------------------------------------------------------------
12282  *
12283  * support functions for report_uninit()
12284  */
12285
12286 /* the maxiumum size of array or hash where we will scan looking
12287  * for the undefined element that triggered the warning */
12288
12289 #define FUV_MAX_SEARCH_SIZE 1000
12290
12291 /* Look for an entry in the hash whose value has the same SV as val;
12292  * If so, return a mortal copy of the key. */
12293
12294 STATIC SV*
12295 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
12296 {
12297     dVAR;
12298     register HE **array;
12299     I32 i;
12300
12301     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12302
12303     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12304                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12305         return NULL;
12306
12307     array = HvARRAY(hv);
12308
12309     for (i=HvMAX(hv); i>0; i--) {
12310         register HE *entry;
12311         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12312             if (HeVAL(entry) != val)
12313                 continue;
12314             if (    HeVAL(entry) == &PL_sv_undef ||
12315                     HeVAL(entry) == &PL_sv_placeholder)
12316                 continue;
12317             if (!HeKEY(entry))
12318                 return NULL;
12319             if (HeKLEN(entry) == HEf_SVKEY)
12320                 return sv_mortalcopy(HeKEY_sv(entry));
12321             return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12322         }
12323     }
12324     return NULL;
12325 }
12326
12327 /* Look for an entry in the array whose value has the same SV as val;
12328  * If so, return the index, otherwise return -1. */
12329
12330 STATIC I32
12331 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
12332 {
12333     dVAR;
12334
12335     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12336
12337     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12338                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12339         return -1;
12340
12341     if (val != &PL_sv_undef) {
12342         SV ** const svp = AvARRAY(av);
12343         I32 i;
12344
12345         for (i=AvFILLp(av); i>=0; i--)
12346             if (svp[i] == val)
12347                 return i;
12348     }
12349     return -1;
12350 }
12351
12352 /* S_varname(): return the name of a variable, optionally with a subscript.
12353  * If gv is non-zero, use the name of that global, along with gvtype (one
12354  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12355  * targ.  Depending on the value of the subscript_type flag, return:
12356  */
12357
12358 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
12359 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
12360 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
12361 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
12362
12363 STATIC SV*
12364 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
12365         const SV *const keyname, I32 aindex, int subscript_type)
12366 {
12367
12368     SV * const name = sv_newmortal();
12369     if (gv) {
12370         char buffer[2];
12371         buffer[0] = gvtype;
12372         buffer[1] = 0;
12373
12374         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
12375
12376         gv_fullname4(name, gv, buffer, 0);
12377
12378         if ((unsigned int)SvPVX(name)[1] <= 26) {
12379             buffer[0] = '^';
12380             buffer[1] = SvPVX(name)[1] + 'A' - 1;
12381
12382             /* Swap the 1 unprintable control character for the 2 byte pretty
12383                version - ie substr($name, 1, 1) = $buffer; */
12384             sv_insert(name, 1, 1, buffer, 2);
12385         }
12386     }
12387     else {
12388         CV * const cv = find_runcv(NULL);
12389         SV *sv;
12390         AV *av;
12391
12392         if (!cv || !CvPADLIST(cv))
12393             return NULL;
12394         av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
12395         sv = *av_fetch(av, targ, FALSE);
12396         sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12397     }
12398
12399     if (subscript_type == FUV_SUBSCRIPT_HASH) {
12400         SV * const sv = newSV(0);
12401         *SvPVX(name) = '$';
12402         Perl_sv_catpvf(aTHX_ name, "{%s}",
12403             pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12404         SvREFCNT_dec(sv);
12405     }
12406     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12407         *SvPVX(name) = '$';
12408         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12409     }
12410     else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12411         /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12412         Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
12413     }
12414
12415     return name;
12416 }
12417
12418
12419 /*
12420 =for apidoc find_uninit_var
12421
12422 Find the name of the undefined variable (if any) that caused the operator o
12423 to issue a "Use of uninitialized value" warning.
12424 If match is true, only return a name if it's value matches uninit_sv.
12425 So roughly speaking, if a unary operator (such as OP_COS) generates a
12426 warning, then following the direct child of the op may yield an
12427 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12428 other hand, with OP_ADD there are two branches to follow, so we only print
12429 the variable name if we get an exact match.
12430
12431 The name is returned as a mortal SV.
12432
12433 Assumes that PL_op is the op that originally triggered the error, and that
12434 PL_comppad/PL_curpad points to the currently executing pad.
12435
12436 =cut
12437 */
12438
12439 STATIC SV *
12440 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
12441                   bool match)
12442 {
12443     dVAR;
12444     SV *sv;
12445     const GV *gv;
12446     const OP *o, *o2, *kid;
12447
12448     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12449                             uninit_sv == &PL_sv_placeholder)))
12450         return NULL;
12451
12452     switch (obase->op_type) {
12453
12454     case OP_RV2AV:
12455     case OP_RV2HV:
12456     case OP_PADAV:
12457     case OP_PADHV:
12458       {
12459         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12460         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12461         I32 index = 0;
12462         SV *keysv = NULL;
12463         int subscript_type = FUV_SUBSCRIPT_WITHIN;
12464
12465         if (pad) { /* @lex, %lex */
12466             sv = PAD_SVl(obase->op_targ);
12467             gv = NULL;
12468         }
12469         else {
12470             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12471             /* @global, %global */
12472                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12473                 if (!gv)
12474                     break;
12475                 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
12476             }
12477             else /* @{expr}, %{expr} */
12478                 return find_uninit_var(cUNOPx(obase)->op_first,
12479                                                     uninit_sv, match);
12480         }
12481
12482         /* attempt to find a match within the aggregate */
12483         if (hash) {
12484             keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12485             if (keysv)
12486                 subscript_type = FUV_SUBSCRIPT_HASH;
12487         }
12488         else {
12489             index = find_array_subscript((const AV *)sv, uninit_sv);
12490             if (index >= 0)
12491                 subscript_type = FUV_SUBSCRIPT_ARRAY;
12492         }
12493
12494         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12495             break;
12496
12497         return varname(gv, hash ? '%' : '@', obase->op_targ,
12498                                     keysv, index, subscript_type);
12499       }
12500
12501     case OP_PADSV:
12502         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12503             break;
12504         return varname(NULL, '$', obase->op_targ,
12505                                     NULL, 0, FUV_SUBSCRIPT_NONE);
12506
12507     case OP_GVSV:
12508         gv = cGVOPx_gv(obase);
12509         if (!gv || (match && GvSV(gv) != uninit_sv))
12510             break;
12511         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12512
12513     case OP_AELEMFAST:
12514         if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12515             if (match) {
12516                 SV **svp;
12517                 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
12518                 if (!av || SvRMAGICAL(av))
12519                     break;
12520                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12521                 if (!svp || *svp != uninit_sv)
12522                     break;
12523             }
12524             return varname(NULL, '$', obase->op_targ,
12525                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12526         }
12527         else {
12528             gv = cGVOPx_gv(obase);
12529             if (!gv)
12530                 break;
12531             if (match) {
12532                 SV **svp;
12533                 AV *const av = GvAV(gv);
12534                 if (!av || SvRMAGICAL(av))
12535                     break;
12536                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12537                 if (!svp || *svp != uninit_sv)
12538                     break;
12539             }
12540             return varname(gv, '$', 0,
12541                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12542         }
12543         break;
12544
12545     case OP_EXISTS:
12546         o = cUNOPx(obase)->op_first;
12547         if (!o || o->op_type != OP_NULL ||
12548                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12549             break;
12550         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12551
12552     case OP_AELEM:
12553     case OP_HELEM:
12554         if (PL_op == obase)
12555             /* $a[uninit_expr] or $h{uninit_expr} */
12556             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12557
12558         gv = NULL;
12559         o = cBINOPx(obase)->op_first;
12560         kid = cBINOPx(obase)->op_last;
12561
12562         /* get the av or hv, and optionally the gv */
12563         sv = NULL;
12564         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12565             sv = PAD_SV(o->op_targ);
12566         }
12567         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12568                 && cUNOPo->op_first->op_type == OP_GV)
12569         {
12570             gv = cGVOPx_gv(cUNOPo->op_first);
12571             if (!gv)
12572                 break;
12573             sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
12574         }
12575         if (!sv)
12576             break;
12577
12578         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
12579             /* index is constant */
12580             if (match) {
12581                 if (SvMAGICAL(sv))
12582                     break;
12583                 if (obase->op_type == OP_HELEM) {
12584                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
12585                     if (!he || HeVAL(he) != uninit_sv)
12586                         break;
12587                 }
12588                 else {
12589                     SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
12590                     if (!svp || *svp != uninit_sv)
12591                         break;
12592                 }
12593             }
12594             if (obase->op_type == OP_HELEM)
12595                 return varname(gv, '%', o->op_targ,
12596                             cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
12597             else
12598                 return varname(gv, '@', o->op_targ, NULL,
12599                             SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
12600         }
12601         else  {
12602             /* index is an expression;
12603              * attempt to find a match within the aggregate */
12604             if (obase->op_type == OP_HELEM) {
12605                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12606                 if (keysv)
12607                     return varname(gv, '%', o->op_targ,
12608                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
12609             }
12610             else {
12611                 const I32 index
12612                     = find_array_subscript((const AV *)sv, uninit_sv);
12613                 if (index >= 0)
12614                     return varname(gv, '@', o->op_targ,
12615                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
12616             }
12617             if (match)
12618                 break;
12619             return varname(gv,
12620                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
12621                 ? '@' : '%',
12622                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
12623         }
12624         break;
12625
12626     case OP_AASSIGN:
12627         /* only examine RHS */
12628         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
12629
12630     case OP_OPEN:
12631         o = cUNOPx(obase)->op_first;
12632         if (o->op_type == OP_PUSHMARK)
12633             o = o->op_sibling;
12634
12635         if (!o->op_sibling) {
12636             /* one-arg version of open is highly magical */
12637
12638             if (o->op_type == OP_GV) { /* open FOO; */
12639                 gv = cGVOPx_gv(o);
12640                 if (match && GvSV(gv) != uninit_sv)
12641                     break;
12642                 return varname(gv, '$', 0,
12643                             NULL, 0, FUV_SUBSCRIPT_NONE);
12644             }
12645             /* other possibilities not handled are:
12646              * open $x; or open my $x;  should return '${*$x}'
12647              * open expr;               should return '$'.expr ideally
12648              */
12649              break;
12650         }
12651         goto do_op;
12652
12653     /* ops where $_ may be an implicit arg */
12654     case OP_TRANS:
12655     case OP_SUBST:
12656     case OP_MATCH:
12657         if ( !(obase->op_flags & OPf_STACKED)) {
12658             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
12659                                  ? PAD_SVl(obase->op_targ)
12660                                  : DEFSV))
12661             {
12662                 sv = sv_newmortal();
12663                 sv_setpvn(sv, "$_", 2);
12664                 return sv;
12665             }
12666         }
12667         goto do_op;
12668
12669     case OP_PRTF:
12670     case OP_PRINT:
12671     case OP_SAY:
12672         match = 1; /* print etc can return undef on defined args */
12673         /* skip filehandle as it can't produce 'undef' warning  */
12674         o = cUNOPx(obase)->op_first;
12675         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
12676             o = o->op_sibling->op_sibling;
12677         goto do_op2;
12678
12679
12680     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
12681     case OP_RV2SV:
12682     case OP_CUSTOM: /* XS or custom code could trigger random warnings */
12683
12684         /* the following ops are capable of returning PL_sv_undef even for
12685          * defined arg(s) */
12686
12687     case OP_BACKTICK:
12688     case OP_PIPE_OP:
12689     case OP_FILENO:
12690     case OP_BINMODE:
12691     case OP_TIED:
12692     case OP_GETC:
12693     case OP_SYSREAD:
12694     case OP_SEND:
12695     case OP_IOCTL:
12696     case OP_SOCKET:
12697     case OP_SOCKPAIR:
12698     case OP_BIND:
12699     case OP_CONNECT:
12700     case OP_LISTEN:
12701     case OP_ACCEPT:
12702     case OP_SHUTDOWN:
12703     case OP_SSOCKOPT:
12704     case OP_GETPEERNAME:
12705     case OP_FTRREAD:
12706     case OP_FTRWRITE:
12707     case OP_FTREXEC:
12708     case OP_FTROWNED:
12709     case OP_FTEREAD:
12710     case OP_FTEWRITE:
12711     case OP_FTEEXEC:
12712     case OP_FTEOWNED:
12713     case OP_FTIS:
12714     case OP_FTZERO:
12715     case OP_FTSIZE:
12716     case OP_FTFILE:
12717     case OP_FTDIR:
12718     case OP_FTLINK:
12719     case OP_FTPIPE:
12720     case OP_FTSOCK:
12721     case OP_FTBLK:
12722     case OP_FTCHR:
12723     case OP_FTTTY:
12724     case OP_FTSUID:
12725     case OP_FTSGID:
12726     case OP_FTSVTX:
12727     case OP_FTTEXT:
12728     case OP_FTBINARY:
12729     case OP_FTMTIME:
12730     case OP_FTATIME:
12731     case OP_FTCTIME:
12732     case OP_READLINK:
12733     case OP_OPEN_DIR:
12734     case OP_READDIR:
12735     case OP_TELLDIR:
12736     case OP_SEEKDIR:
12737     case OP_REWINDDIR:
12738     case OP_CLOSEDIR:
12739     case OP_GMTIME:
12740     case OP_ALARM:
12741     case OP_SEMGET:
12742     case OP_GETLOGIN:
12743     case OP_UNDEF:
12744     case OP_SUBSTR:
12745     case OP_AEACH:
12746     case OP_EACH:
12747     case OP_SORT:
12748     case OP_CALLER:
12749     case OP_DOFILE:
12750     case OP_PROTOTYPE:
12751     case OP_NCMP:
12752     case OP_SMARTMATCH:
12753     case OP_UNPACK:
12754     case OP_SYSOPEN:
12755     case OP_SYSSEEK:
12756         match = 1;
12757         goto do_op;
12758
12759     case OP_ENTERSUB:
12760     case OP_GOTO:
12761         /* XXX tmp hack: these two may call an XS sub, and currently
12762           XS subs don't have a SUB entry on the context stack, so CV and
12763           pad determination goes wrong, and BAD things happen. So, just
12764           don't try to determine the value under those circumstances.
12765           Need a better fix at dome point. DAPM 11/2007 */
12766         break;
12767
12768
12769     case OP_POS:
12770         /* def-ness of rval pos() is independent of the def-ness of its arg */
12771         if ( !(obase->op_flags & OPf_MOD))
12772             break;
12773
12774     case OP_SCHOMP:
12775     case OP_CHOMP:
12776         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
12777             return newSVpvs_flags("${$/}", SVs_TEMP);
12778         /*FALLTHROUGH*/
12779
12780     default:
12781     do_op:
12782         if (!(obase->op_flags & OPf_KIDS))
12783             break;
12784         o = cUNOPx(obase)->op_first;
12785
12786     do_op2:
12787         if (!o)
12788             break;
12789
12790         /* if all except one arg are constant, or have no side-effects,
12791          * or are optimized away, then it's unambiguous */
12792         o2 = NULL;
12793         for (kid=o; kid; kid = kid->op_sibling) {
12794             if (kid) {
12795                 const OPCODE type = kid->op_type;
12796                 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
12797                   || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
12798                   || (type == OP_PUSHMARK)
12799                 )
12800                 continue;
12801             }
12802             if (o2) { /* more than one found */
12803                 o2 = NULL;
12804                 break;
12805             }
12806             o2 = kid;
12807         }
12808         if (o2)
12809             return find_uninit_var(o2, uninit_sv, match);
12810
12811         /* scan all args */
12812         while (o) {
12813             sv = find_uninit_var(o, uninit_sv, 1);
12814             if (sv)
12815                 return sv;
12816             o = o->op_sibling;
12817         }
12818         break;
12819     }
12820     return NULL;
12821 }
12822
12823
12824 /*
12825 =for apidoc report_uninit
12826
12827 Print appropriate "Use of uninitialized variable" warning
12828
12829 =cut
12830 */
12831
12832 void
12833 Perl_report_uninit(pTHX_ SV* uninit_sv)
12834 {
12835     dVAR;
12836     if (PL_op) {
12837         SV* varname = NULL;
12838         if (uninit_sv) {
12839             varname = find_uninit_var(PL_op, uninit_sv,0);
12840             if (varname)
12841                 sv_insert(varname, 0, 0, " ", 1);
12842         }
12843         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
12844                 varname ? SvPV_nolen_const(varname) : "",
12845                 " in ", OP_DESC(PL_op));
12846     }
12847     else
12848         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
12849                     "", "", "");
12850 }
12851
12852 /*
12853  * Local variables:
12854  * c-indentation-style: bsd
12855  * c-basic-offset: 4
12856  * indent-tabs-mode: t
12857  * End:
12858  *
12859  * ex: set ts=8 sts=4 sw=4 noet:
12860  */