sv.c

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