sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
   5  *    and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'I wonder what the Entish is for "yes" and "no",' he thought.
  14  *                                                      --Pippin
  15  *
  16  *     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
  17  */
  18
  19 /*
  20  *
  21  *
  22  * This file contains the code that creates, manipulates and destroys
  23  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
  24  * structure of an SV, so their creation and destruction is handled
  25  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
  26  * level functions (eg. substr, split, join) for each of the types are
  27  * in the pp*.c files.
  28  */
  29
  30 #include "EXTERN.h"
  31 #define PERL_IN_SV_C
  32 #include "perl.h"
  33 #include "regcomp.h"
  34
  35 #define FCALL *f
  36
  37 #ifdef __Lynx__
  38 /* Missing proto on LynxOS */
  39   char *gconvert(double, int, int,  char *);
  40 #endif
  41
  42 #ifdef PERL_UTF8_CACHE_ASSERT
  43 /* if adding more checks watch out for the following tests:
  44  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
  45  *   lib/utf8.t lib/Unicode/Collate/t/index.t
  46  * --jhi
  47  */
  48 #   define ASSERT_UTF8_CACHE(cache) \
  49     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
  50                               assert((cache)[2] <= (cache)[3]); \
  51                               assert((cache)[3] <= (cache)[1]);} \
  52                               } STMT_END
  53 #else
  54 #   define ASSERT_UTF8_CACHE(cache) NOOP
  55 #endif
  56
  57 #ifdef PERL_OLD_COPY_ON_WRITE
  58 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
  59 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
  60 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
  61    on-write.  */
  62 #endif
  63
  64 /* ============================================================================
  65
  66 =head1 Allocation and deallocation of SVs.
  67
  68 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
  69 sv, av, hv...) contains type and reference count information, and for
  70 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
  71 contains fields specific to each type.  Some types store all they need
  72 in the head, so don't have a body.
  73
  74 In all but the most memory-paranoid configuations (ex: PURIFY), heads
  75 and bodies are allocated out of arenas, which by default are
  76 approximately 4K chunks of memory parcelled up into N heads or bodies.
  77 Sv-bodies are allocated by their sv-type, guaranteeing size
  78 consistency needed to allocate safely from arrays.
  79
  80 For SV-heads, the first slot in each arena is reserved, and holds a
  81 link to the next arena, some flags, and a note of the number of slots.
  82 Snaked through each arena chain is a linked list of free items; when
  83 this becomes empty, an extra arena is allocated and divided up into N
  84 items which are threaded into the free list.
  85
  86 SV-bodies are similar, but they use arena-sets by default, which
  87 separate the link and info from the arena itself, and reclaim the 1st
  88 slot in the arena.  SV-bodies are further described later.
  89
  90 The following global variables are associated with arenas:
  91
  92     PL_sv_arenaroot     pointer to list of SV arenas
  93     PL_sv_root          pointer to list of free SV structures
  94
  95     PL_body_arenas      head of linked-list of body arenas
  96     PL_body_roots[]     array of pointers to list of free bodies of svtype
  97                         arrays are indexed by the svtype needed
  98
  99 A few special SV heads are not allocated from an arena, but are
 100 instead directly created in the interpreter structure, eg PL_sv_undef.
 101 The size of arenas can be changed from the default by setting
 102 PERL_ARENA_SIZE appropriately at compile time.
 103
 104 The SV arena serves the secondary purpose of allowing still-live SVs
 105 to be located and destroyed during final cleanup.
 106
 107 At the lowest level, the macros new_SV() and del_SV() grab and free
 108 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
 109 to return the SV to the free list with error checking.) new_SV() calls
 110 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
 111 SVs in the free list have their SvTYPE field set to all ones.
 112
 113 At the time of very final cleanup, sv_free_arenas() is called from
 114 perl_destruct() to physically free all the arenas allocated since the
 115 start of the interpreter.
 116
 117 The function visit() scans the SV arenas list, and calls a specified
 118 function for each SV it finds which is still live - ie which has an SvTYPE
 119 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
 120 following functions (specified as [function that calls visit()] / [function
 121 called by visit() for each SV]):
 122
 123     sv_report_used() / do_report_used()
 124                         dump all remaining SVs (debugging aid)
 125
 126     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
 127                         Attempt to free all objects pointed to by RVs,
 128                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
 129                         try to do the same for all objects indirectly
 130                         referenced by typeglobs too.  Called once from
 131                         perl_destruct(), prior to calling sv_clean_all()
 132                         below.
 133
 134     sv_clean_all() / do_clean_all()
 135                         SvREFCNT_dec(sv) each remaining SV, possibly
 136                         triggering an sv_free(). It also sets the
 137                         SVf_BREAK flag on the SV to indicate that the
 138                         refcnt has been artificially lowered, and thus
 139                         stopping sv_free() from giving spurious warnings
 140                         about SVs which unexpectedly have a refcnt
 141                         of zero.  called repeatedly from perl_destruct()
 142                         until there are no SVs left.
 143
 144 =head2 Arena allocator API Summary
 145
 146 Private API to rest of sv.c
 147
 148     new_SV(),  del_SV(),
 149
 150     new_XIV(), del_XIV(),
 151     new_XNV(), del_XNV(),
 152     etc
 153
 154 Public API:
 155
 156     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
 157
 158 =cut
 159
 160  * ========================================================================= */
 161
 162 /*
 163  * "A time to plant, and a time to uproot what was planted..."
 164  */
 165
 166 void
 167 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
 168 {
 169     dVAR;
 170     void *new_chunk;
 171     U32 new_chunk_size;
 172
 173     PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
 174
 175     new_chunk = (void *)(chunk);
 176     new_chunk_size = (chunk_size);
 177     if (new_chunk_size > PL_nice_chunk_size) {
 178         Safefree(PL_nice_chunk);
 179         PL_nice_chunk = (char *) new_chunk;
 180         PL_nice_chunk_size = new_chunk_size;
 181     } else {
 182         Safefree(chunk);
 183     }
 184 }
 185
 186 #ifdef PERL_MEM_LOG
 187 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
 188             Perl_mem_log_new_sv(sv, file, line, func)
 189 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
 190             Perl_mem_log_del_sv(sv, file, line, func)
 191 #else
 192 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
 193 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
 194 #endif
 195
 196 #ifdef DEBUG_LEAKING_SCALARS
 197 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
 198 #  define DEBUG_SV_SERIAL(sv)                                               \
 199     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
 200             PTR2UV(sv), (long)(sv)->sv_debug_serial))
 201 #else
 202 #  define FREE_SV_DEBUG_FILE(sv)
 203 #  define DEBUG_SV_SERIAL(sv)   NOOP
 204 #endif
 205
 206 #ifdef PERL_POISON
 207 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
 208 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = MUTABLE_SV((val))
 209 /* Whilst I'd love to do this, it seems that things like to check on
 210    unreferenced scalars
 211 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
 212 */
 213 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
 214                                 PoisonNew(&SvREFCNT(sv), 1, U32)
 215 #else
 216 #  define SvARENA_CHAIN(sv)     SvANY(sv)
 217 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
 218 #  define POSION_SV_HEAD(sv)
 219 #endif
 220
 221 /* Mark an SV head as unused, and add to free list.
 222  *
 223  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
 224  * its refcount artificially decremented during global destruction, so
 225  * there may be dangling pointers to it. The last thing we want in that
 226  * case is for it to be reused. */
 227
 228 #define plant_SV(p) \
 229     STMT_START {                                        \
 230         const U32 old_flags = SvFLAGS(p);                       \
 231         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 232         DEBUG_SV_SERIAL(p);                             \
 233         FREE_SV_DEBUG_FILE(p);                          \
 234         POSION_SV_HEAD(p);                              \
 235         SvFLAGS(p) = SVTYPEMASK;                        \
 236         if (!(old_flags & SVf_BREAK)) {         \
 237             SvARENA_CHAIN_SET(p, PL_sv_root);   \
 238             PL_sv_root = (p);                           \
 239         }                                               \
 240         --PL_sv_count;                                  \
 241     } STMT_END
 242
 243 #define uproot_SV(p) \
 244     STMT_START {                                        \
 245         (p) = PL_sv_root;                               \
 246         PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p));              \
 247         ++PL_sv_count;                                  \
 248     } STMT_END
 249
 250
 251 /* make some more SVs by adding another arena */
 252
 253 STATIC SV*
 254 S_more_sv(pTHX)
 255 {
 256     dVAR;
 257     SV* sv;
 258
 259     if (PL_nice_chunk) {
 260         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 261         PL_nice_chunk = NULL;
 262         PL_nice_chunk_size = 0;
 263     }
 264     else {
 265         char *chunk;                /* must use New here to match call to */
 266         Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
 267         sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
 268     }
 269     uproot_SV(sv);
 270     return sv;
 271 }
 272
 273 /* new_SV(): return a new, empty SV head */
 274
 275 #ifdef DEBUG_LEAKING_SCALARS
 276 /* provide a real function for a debugger to play with */
 277 STATIC SV*
 278 S_new_SV(pTHX_ const char *file, int line, const char *func)
 279 {
 280     SV* sv;
 281
 282     if (PL_sv_root)
 283         uproot_SV(sv);
 284     else
 285         sv = S_more_sv(aTHX);
 286     SvANY(sv) = 0;
 287     SvREFCNT(sv) = 1;
 288     SvFLAGS(sv) = 0;
 289     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
 290     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
 291                 ? PL_parser->copline
 292                 :  PL_curcop
 293                     ? CopLINE(PL_curcop)
 294                     : 0
 295             );
 296     sv->sv_debug_inpad = 0;
 297     sv->sv_debug_cloned = 0;
 298     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 299
 300     sv->sv_debug_serial = PL_sv_serial++;
 301
 302     MEM_LOG_NEW_SV(sv, file, line, func);
 303     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
 304             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
 305
 306     return sv;
 307 }
 308 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
 309
 310 #else
 311 #  define new_SV(p) \
 312     STMT_START {                                        \
 313         if (PL_sv_root)                                 \
 314             uproot_SV(p);                               \
 315         else                                            \
 316             (p) = S_more_sv(aTHX);                      \
 317         SvANY(p) = 0;                                   \
 318         SvREFCNT(p) = 1;                                \
 319         SvFLAGS(p) = 0;                                 \
 320         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 321     } STMT_END
 322 #endif
 323
 324
 325 /* del_SV(): return an empty SV head to the free list */
 326
 327 #ifdef DEBUGGING
 328
 329 #define del_SV(p) \
 330     STMT_START {                                        \
 331         if (DEBUG_D_TEST)                               \
 332             del_sv(p);                                  \
 333         else                                            \
 334             plant_SV(p);                                \
 335     } STMT_END
 336
 337 STATIC void
 338 S_del_sv(pTHX_ SV *p)
 339 {
 340     dVAR;
 341
 342     PERL_ARGS_ASSERT_DEL_SV;
 343
 344     if (DEBUG_D_TEST) {
 345         SV* sva;
 346         bool ok = 0;
 347         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 348             const SV * const sv = sva + 1;
 349             const SV * const svend = &sva[SvREFCNT(sva)];
 350             if (p >= sv && p < svend) {
 351                 ok = 1;
 352                 break;
 353             }
 354         }
 355         if (!ok) {
 356             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
 357                              "Attempt to free non-arena SV: 0x%"UVxf
 358                              pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
 359             return;
 360         }
 361     }
 362     plant_SV(p);
 363 }
 364
 365 #else /* ! DEBUGGING */
 366
 367 #define del_SV(p)   plant_SV(p)
 368
 369 #endif /* DEBUGGING */
 370
 371
 372 /*
 373 =head1 SV Manipulation Functions
 374
 375 =for apidoc sv_add_arena
 376
 377 Given a chunk of memory, link it to the head of the list of arenas,
 378 and split it into a list of free SVs.
 379
 380 =cut
 381 */
 382
 383 static void
 384 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
 385 {
 386     dVAR;
 387     SV *const sva = MUTABLE_SV(ptr);
 388     register SV* sv;
 389     register SV* svend;
 390
 391     PERL_ARGS_ASSERT_SV_ADD_ARENA;
 392
 393     /* The first SV in an arena isn't an SV. */
 394     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 395     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 396     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 397
 398     PL_sv_arenaroot = sva;
 399     PL_sv_root = sva + 1;
 400
 401     svend = &sva[SvREFCNT(sva) - 1];
 402     sv = sva + 1;
 403     while (sv < svend) {
 404         SvARENA_CHAIN_SET(sv, (sv + 1));
 405 #ifdef DEBUGGING
 406         SvREFCNT(sv) = 0;
 407 #endif
 408         /* Must always set typemask because it's always checked in on cleanup
 409            when the arenas are walked looking for objects.  */
 410         SvFLAGS(sv) = SVTYPEMASK;
 411         sv++;
 412     }
 413     SvARENA_CHAIN_SET(sv, 0);
 414 #ifdef DEBUGGING
 415     SvREFCNT(sv) = 0;
 416 #endif
 417     SvFLAGS(sv) = SVTYPEMASK;
 418 }
 419
 420 /* visit(): call the named function for each non-free SV in the arenas
 421  * whose flags field matches the flags/mask args. */
 422
 423 STATIC I32
 424 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
 425 {
 426     dVAR;
 427     SV* sva;
 428     I32 visited = 0;
 429
 430     PERL_ARGS_ASSERT_VISIT;
 431
 432     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 433         register const SV * const svend = &sva[SvREFCNT(sva)];
 434         register SV* sv;
 435         for (sv = sva + 1; sv < svend; ++sv) {
 436             if (SvTYPE(sv) != SVTYPEMASK
 437                     && (sv->sv_flags & mask) == flags
 438                     && SvREFCNT(sv))
 439             {
 440                 (FCALL)(aTHX_ sv);
 441                 ++visited;
 442             }
 443         }
 444     }
 445     return visited;
 446 }
 447
 448 #ifdef DEBUGGING
 449
 450 /* called by sv_report_used() for each live SV */
 451
 452 static void
 453 do_report_used(pTHX_ SV *const sv)
 454 {
 455     if (SvTYPE(sv) != SVTYPEMASK) {
 456         PerlIO_printf(Perl_debug_log, "****\n");
 457         sv_dump(sv);
 458     }
 459 }
 460 #endif
 461
 462 /*
 463 =for apidoc sv_report_used
 464
 465 Dump the contents of all SVs not yet freed. (Debugging aid).
 466
 467 =cut
 468 */
 469
 470 void
 471 Perl_sv_report_used(pTHX)
 472 {
 473 #ifdef DEBUGGING
 474     visit(do_report_used, 0, 0);
 475 #else
 476     PERL_UNUSED_CONTEXT;
 477 #endif
 478 }
 479
 480 /* called by sv_clean_objs() for each live SV */
 481
 482 static void
 483 do_clean_objs(pTHX_ SV *const ref)
 484 {
 485     dVAR;
 486     assert (SvROK(ref));
 487     {
 488         SV * const target = SvRV(ref);
 489         if (SvOBJECT(target)) {
 490             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
 491             if (SvWEAKREF(ref)) {
 492                 sv_del_backref(target, ref);
 493                 SvWEAKREF_off(ref);
 494                 SvRV_set(ref, NULL);
 495             } else {
 496                 SvROK_off(ref);
 497                 SvRV_set(ref, NULL);
 498                 SvREFCNT_dec(target);
 499             }
 500         }
 501     }
 502
 503     /* XXX Might want to check arrays, etc. */
 504 }
 505
 506 /* called by sv_clean_objs() for each live SV */
 507
 508 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 509 static void
 510 do_clean_named_objs(pTHX_ SV *const sv)
 511 {
 512     dVAR;
 513     assert(SvTYPE(sv) == SVt_PVGV);
 514     assert(isGV_with_GP(sv));
 515     if (GvGP(sv)) {
 516         if ((
 517 #ifdef PERL_DONT_CREATE_GVSV
 518              GvSV(sv) &&
 519 #endif
 520              SvOBJECT(GvSV(sv))) ||
 521              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
 522              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
 523              /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
 524              (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
 525              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
 526         {
 527             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
 528             SvFLAGS(sv) |= SVf_BREAK;
 529             SvREFCNT_dec(sv);
 530         }
 531     }
 532 }
 533 #endif
 534
 535 /*
 536 =for apidoc sv_clean_objs
 537
 538 Attempt to destroy all objects not yet freed
 539
 540 =cut
 541 */
 542
 543 void
 544 Perl_sv_clean_objs(pTHX)
 545 {
 546     dVAR;
 547     PL_in_clean_objs = TRUE;
 548     visit(do_clean_objs, SVf_ROK, SVf_ROK);
 549 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 550     /* some barnacles may yet remain, clinging to typeglobs */
 551     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
 552 #endif
 553     PL_in_clean_objs = FALSE;
 554 }
 555
 556 /* called by sv_clean_all() for each live SV */
 557
 558 static void
 559 do_clean_all(pTHX_ SV *const sv)
 560 {
 561     dVAR;
 562     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
 563         /* don't clean pid table and strtab */
 564         return;
 565     }
 566     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
 567     SvFLAGS(sv) |= SVf_BREAK;
 568     SvREFCNT_dec(sv);
 569 }
 570
 571 /*
 572 =for apidoc sv_clean_all
 573
 574 Decrement the refcnt of each remaining SV, possibly triggering a
 575 cleanup. This function may have to be called multiple times to free
 576 SVs which are in complex self-referential hierarchies.
 577
 578 =cut
 579 */
 580
 581 I32
 582 Perl_sv_clean_all(pTHX)
 583 {
 584     dVAR;
 585     I32 cleaned;
 586     PL_in_clean_all = TRUE;
 587     cleaned = visit(do_clean_all, 0,0);
 588     PL_in_clean_all = FALSE;
 589     return cleaned;
 590 }
 591
 592 /*
 593   ARENASETS: a meta-arena implementation which separates arena-info
 594   into struct arena_set, which contains an array of struct
 595   arena_descs, each holding info for a single arena.  By separating
 596   the meta-info from the arena, we recover the 1st slot, formerly
 597   borrowed for list management.  The arena_set is about the size of an
 598   arena, avoiding the needless malloc overhead of a naive linked-list.
 599
 600   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
 601   memory in the last arena-set (1/2 on average).  In trade, we get
 602   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
 603   smaller types).  The recovery of the wasted space allows use of
 604   small arenas for large, rare body types, by changing array* fields
 605   in body_details_by_type[] below.
 606 */
 607 struct arena_desc {
 608     char       *arena;          /* the raw storage, allocated aligned */
 609     size_t      size;           /* its size ~4k typ */
 610     svtype      utype;          /* bodytype stored in arena */
 611 };
 612
 613 struct arena_set;
 614
 615 /* Get the maximum number of elements in set[] such that struct arena_set
 616    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
 617    therefore likely to be 1 aligned memory page.  */
 618
 619 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
 620                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
 621
 622 struct arena_set {
 623     struct arena_set* next;
 624     unsigned int   set_size;    /* ie ARENAS_PER_SET */
 625     unsigned int   curr;        /* index of next available arena-desc */
 626     struct arena_desc set[ARENAS_PER_SET];
 627 };
 628
 629 /*
 630 =for apidoc sv_free_arenas
 631
 632 Deallocate the memory used by all arenas. Note that all the individual SV
 633 heads and bodies within the arenas must already have been freed.
 634
 635 =cut
 636 */
 637 void
 638 Perl_sv_free_arenas(pTHX)
 639 {
 640     dVAR;
 641     SV* sva;
 642     SV* svanext;
 643     unsigned int i;
 644
 645     /* Free arenas here, but be careful about fake ones.  (We assume
 646        contiguity of the fake ones with the corresponding real ones.) */
 647
 648     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 649         svanext = MUTABLE_SV(SvANY(sva));
 650         while (svanext && SvFAKE(svanext))
 651             svanext = MUTABLE_SV(SvANY(svanext));
 652
 653         if (!SvFAKE(sva))
 654             Safefree(sva);
 655     }
 656
 657     {
 658         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 659
 660         while (aroot) {
 661             struct arena_set *current = aroot;
 662             i = aroot->curr;
 663             while (i--) {
 664                 assert(aroot->set[i].arena);
 665                 Safefree(aroot->set[i].arena);
 666             }
 667             aroot = aroot->next;
 668             Safefree(current);
 669         }
 670     }
 671     PL_body_arenas = 0;
 672
 673     i = PERL_ARENA_ROOTS_SIZE;
 674     while (i--)
 675         PL_body_roots[i] = 0;
 676
 677     Safefree(PL_nice_chunk);
 678     PL_nice_chunk = NULL;
 679     PL_nice_chunk_size = 0;
 680     PL_sv_arenaroot = 0;
 681     PL_sv_root = 0;
 682 }
 683
 684 /*
 685   Here are mid-level routines that manage the allocation of bodies out
 686   of the various arenas.  There are 5 kinds of arenas:
 687
 688   1. SV-head arenas, which are discussed and handled above
 689   2. regular body arenas
 690   3. arenas for reduced-size bodies
 691   4. Hash-Entry arenas
 692
 693   Arena types 2 & 3 are chained by body-type off an array of
 694   arena-root pointers, which is indexed by svtype.  Some of the
 695   larger/less used body types are malloced singly, since a large
 696   unused block of them is wasteful.  Also, several svtypes dont have
 697   bodies; the data fits into the sv-head itself.  The arena-root
 698   pointer thus has a few unused root-pointers (which may be hijacked
 699   later for arena types 4,5)
 700
 701   3 differs from 2 as an optimization; some body types have several
 702   unused fields in the front of the structure (which are kept in-place
 703   for consistency).  These bodies can be allocated in smaller chunks,
 704   because the leading fields arent accessed.  Pointers to such bodies
 705   are decremented to point at the unused 'ghost' memory, knowing that
 706   the pointers are used with offsets to the real memory.
 707
 708   HE, HEK arenas are managed separately, with separate code, but may
 709   be merge-able later..
 710 */
 711
 712 /* get_arena(size): this creates custom-sized arenas
 713    TBD: export properly for hv.c: S_more_he().
 714 */
 715 void*
 716 Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype)
 717 {
 718     dVAR;
 719     struct arena_desc* adesc;
 720     struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 721     unsigned int curr;
 722
 723     /* shouldnt need this
 724     if (!arena_size)    arena_size = PERL_ARENA_SIZE;
 725     */
 726
 727     /* may need new arena-set to hold new arena */
 728     if (!aroot || aroot->curr >= aroot->set_size) {
 729         struct arena_set *newroot;
 730         Newxz(newroot, 1, struct arena_set);
 731         newroot->set_size = ARENAS_PER_SET;
 732         newroot->next = aroot;
 733         aroot = newroot;
 734         PL_body_arenas = (void *) newroot;
 735         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
 736     }
 737
 738     /* ok, now have arena-set with at least 1 empty/available arena-desc */
 739     curr = aroot->curr++;
 740     adesc = &(aroot->set[curr]);
 741     assert(!adesc->arena);
 742
 743     Newx(adesc->arena, arena_size, char);
 744     adesc->size = arena_size;
 745     adesc->utype = bodytype;
 746     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
 747                           curr, (void*)adesc->arena, (UV)arena_size));
 748
 749     return adesc->arena;
 750 }
 751
 752
 753 /* return a thing to the free list */
 754
 755 #define del_body(thing, root)                   \
 756     STMT_START {                                \
 757         void ** const thing_copy = (void **)thing;\
 758         *thing_copy = *root;                    \
 759         *root = (void*)thing_copy;              \
 760     } STMT_END
 761
 762 /*
 763
 764 =head1 SV-Body Allocation
 765
 766 Allocation of SV-bodies is similar to SV-heads, differing as follows;
 767 the allocation mechanism is used for many body types, so is somewhat
 768 more complicated, it uses arena-sets, and has no need for still-live
 769 SV detection.
 770
 771 At the outermost level, (new|del)_X*V macros return bodies of the
 772 appropriate type.  These macros call either (new|del)_body_type or
 773 (new|del)_body_allocated macro pairs, depending on specifics of the
 774 type.  Most body types use the former pair, the latter pair is used to
 775 allocate body types with "ghost fields".
 776
 777 "ghost fields" are fields that are unused in certain types, and
 778 consequently don't need to actually exist.  They are declared because
 779 they're part of a "base type", which allows use of functions as
 780 methods.  The simplest examples are AVs and HVs, 2 aggregate types
 781 which don't use the fields which support SCALAR semantics.
 782
 783 For these types, the arenas are carved up into appropriately sized
 784 chunks, we thus avoid wasted memory for those unaccessed members.
 785 When bodies are allocated, we adjust the pointer back in memory by the
 786 size of the part not allocated, so it's as if we allocated the full
 787 structure.  (But things will all go boom if you write to the part that
 788 is "not there", because you'll be overwriting the last members of the
 789 preceding structure in memory.)
 790
 791 We calculate the correction using the STRUCT_OFFSET macro on the first
 792 member present. If the allocated structure is smaller (no initial NV
 793 actually allocated) then the net effect is to subtract the size of the NV
 794 from the pointer, to return a new pointer as if an initial NV were actually
 795 allocated. (We were using structures named *_allocated for this, but
 796 this turned out to be a subtle bug, because a structure without an NV
 797 could have a lower alignment constraint, but the compiler is allowed to
 798 optimised accesses based on the alignment constraint of the actual pointer
 799 to the full structure, for example, using a single 64 bit load instruction
 800 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
 801
 802 This is the same trick as was used for NV and IV bodies. Ironically it
 803 doesn't need to be used for NV bodies any more, because NV is now at
 804 the start of the structure. IV bodies don't need it either, because
 805 they are no longer allocated.
 806
 807 In turn, the new_body_* allocators call S_new_body(), which invokes
 808 new_body_inline macro, which takes a lock, and takes a body off the
 809 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
 810 necessary to refresh an empty list.  Then the lock is released, and
 811 the body is returned.
 812
 813 S_more_bodies calls get_arena(), and carves it up into an array of N
 814 bodies, which it strings into a linked list.  It looks up arena-size
 815 and body-size from the body_details table described below, thus
 816 supporting the multiple body-types.
 817
 818 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
 819 the (new|del)_X*V macros are mapped directly to malloc/free.
 820
 821 */
 822
 823 /*
 824
 825 For each sv-type, struct body_details bodies_by_type[] carries
 826 parameters which control these aspects of SV handling:
 827
 828 Arena_size determines whether arenas are used for this body type, and if
 829 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
 830 zero, forcing individual mallocs and frees.
 831
 832 Body_size determines how big a body is, and therefore how many fit into
 833 each arena.  Offset carries the body-pointer adjustment needed for
 834 "ghost fields", and is used in *_allocated macros.
 835
 836 But its main purpose is to parameterize info needed in
 837 Perl_sv_upgrade().  The info here dramatically simplifies the function
 838 vs the implementation in 5.8.8, making it table-driven.  All fields
 839 are used for this, except for arena_size.
 840
 841 For the sv-types that have no bodies, arenas are not used, so those
 842 PL_body_roots[sv_type] are unused, and can be overloaded.  In
 843 something of a special case, SVt_NULL is borrowed for HE arenas;
 844 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
 845 bodies_by_type[SVt_NULL] slot is not used, as the table is not
 846 available in hv.c.
 847
 848 */
 849
 850 struct body_details {
 851     U8 body_size;       /* Size to allocate  */
 852     U8 copy;            /* Size of structure to copy (may be shorter)  */
 853     U8 offset;
 854     unsigned int type : 4;          /* We have space for a sanity check.  */
 855     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
 856     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
 857     unsigned int arena : 1;         /* Allocated from an arena */
 858     size_t arena_size;              /* Size of arena to allocate */
 859 };
 860
 861 #define HADNV FALSE
 862 #define NONV TRUE
 863
 864
 865 #ifdef PURIFY
 866 /* With -DPURFIY we allocate everything directly, and don't use arenas.
 867    This seems a rather elegant way to simplify some of the code below.  */
 868 #define HASARENA FALSE
 869 #else
 870 #define HASARENA TRUE
 871 #endif
 872 #define NOARENA FALSE
 873
 874 /* Size the arenas to exactly fit a given number of bodies.  A count
 875    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
 876    simplifying the default.  If count > 0, the arena is sized to fit
 877    only that many bodies, allowing arenas to be used for large, rare
 878    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
 879    limited by PERL_ARENA_SIZE, so we can safely oversize the
 880    declarations.
 881  */
 882 #define FIT_ARENA0(body_size)                           \
 883     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
 884 #define FIT_ARENAn(count,body_size)                     \
 885     ( count * body_size <= PERL_ARENA_SIZE)             \
 886     ? count * body_size                                 \
 887     : FIT_ARENA0 (body_size)
 888 #define FIT_ARENA(count,body_size)                      \
 889     count                                               \
 890     ? FIT_ARENAn (count, body_size)                     \
 891     : FIT_ARENA0 (body_size)
 892
 893 /* Calculate the length to copy. Specifically work out the length less any
 894    final padding the compiler needed to add.  See the comment in sv_upgrade
 895    for why copying the padding proved to be a bug.  */
 896
 897 #define copy_length(type, last_member) \
 898         STRUCT_OFFSET(type, last_member) \
 899         + sizeof (((type*)SvANY((const SV *)0))->last_member)
 900
 901 static const struct body_details bodies_by_type[] = {
 902     { sizeof(HE), 0, 0, SVt_NULL,
 903       FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
 904
 905     /* The bind placeholder pretends to be an RV for now.
 906        Also it's marked as "can't upgrade" to stop anyone using it before it's
 907        implemented.  */
 908     { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
 909
 910     /* IVs are in the head, so the allocation size is 0.  */
 911     { 0,
 912       sizeof(IV), /* This is used to copy out the IV body.  */
 913       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
 914       NOARENA /* IVS don't need an arena  */, 0
 915     },
 916
 917     /* 8 bytes on most ILP32 with IEEE doubles */
 918     { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
 919       FIT_ARENA(0, sizeof(NV)) },
 920
 921     /* 8 bytes on most ILP32 with IEEE doubles */
 922     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
 923       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
 924       + STRUCT_OFFSET(XPV, xpv_cur),
 925       SVt_PV, FALSE, NONV, HASARENA,
 926       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 927
 928     /* 12 */
 929     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
 930       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 931       + STRUCT_OFFSET(XPVIV, xpv_cur),
 932       SVt_PVIV, FALSE, NONV, HASARENA,
 933       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 934
 935     /* 20 */
 936     { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
 937       HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
 938
 939     /* 28 */
 940     { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
 941       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 942
 943     /* something big */
 944     { sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur),
 945       sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur),
 946       + STRUCT_OFFSET(regexp, xpv_cur),
 947       SVt_REGEXP, FALSE, NONV, HASARENA,
 948       FIT_ARENA(0, sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur))
 949     },
 950
 951     /* 48 */
 952     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
 953       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
 954
 955     /* 64 */
 956     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
 957       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
 958
 959     { sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill),
 960       copy_length(XPVAV, xmg_stash) - STRUCT_OFFSET(XPVAV, xav_fill),
 961       + STRUCT_OFFSET(XPVAV, xav_fill),
 962       SVt_PVAV, TRUE, NONV, HASARENA,
 963       FIT_ARENA(0, sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill)) },
 964
 965     { sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill),
 966       copy_length(XPVHV, xmg_stash) - STRUCT_OFFSET(XPVHV, xhv_fill),
 967       + STRUCT_OFFSET(XPVHV, xhv_fill),
 968       SVt_PVHV, TRUE, NONV, HASARENA,
 969       FIT_ARENA(0, sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill)) },
 970
 971     /* 56 */
 972     { sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur),
 973       sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur),
 974       + STRUCT_OFFSET(XPVCV, xpv_cur),
 975       SVt_PVCV, TRUE, NONV, HASARENA,
 976       FIT_ARENA(0, sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur)) },
 977
 978     { sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur),
 979       sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur),
 980       + STRUCT_OFFSET(XPVFM, xpv_cur),
 981       SVt_PVFM, TRUE, NONV, NOARENA,
 982       FIT_ARENA(20, sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur)) },
 983
 984     /* XPVIO is 84 bytes, fits 48x */
 985     { sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur),
 986       sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur),
 987       + STRUCT_OFFSET(XPVIO, xpv_cur),
 988       SVt_PVIO, TRUE, NONV, HASARENA,
 989       FIT_ARENA(24, sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur)) },
 990 };
 991
 992 #define new_body_type(sv_type)          \
 993     (void *)((char *)S_new_body(aTHX_ sv_type))
 994
 995 #define del_body_type(p, sv_type)       \
 996     del_body(p, &PL_body_roots[sv_type])
 997
 998
 999 #define new_body_allocated(sv_type)             \
1000     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1001              - bodies_by_type[sv_type].offset)
1002
1003 #define del_body_allocated(p, sv_type)          \
1004     del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1005
1006
1007 #define my_safemalloc(s)        (void*)safemalloc(s)
1008 #define my_safecalloc(s)        (void*)safecalloc(s, 1)
1009 #define my_safefree(p)  safefree((char*)p)
1010
1011 #ifdef PURIFY
1012
1013 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
1014 #define del_XNV(p)      my_safefree(p)
1015
1016 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
1017 #define del_XPVNV(p)    my_safefree(p)
1018
1019 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
1020 #define del_XPVAV(p)    my_safefree(p)
1021
1022 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
1023 #define del_XPVHV(p)    my_safefree(p)
1024
1025 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
1026 #define del_XPVMG(p)    my_safefree(p)
1027
1028 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
1029 #define del_XPVGV(p)    my_safefree(p)
1030
1031 #else /* !PURIFY */
1032
1033 #define new_XNV()       new_body_type(SVt_NV)
1034 #define del_XNV(p)      del_body_type(p, SVt_NV)
1035
1036 #define new_XPVNV()     new_body_type(SVt_PVNV)
1037 #define del_XPVNV(p)    del_body_type(p, SVt_PVNV)
1038
1039 #define new_XPVAV()     new_body_allocated(SVt_PVAV)
1040 #define del_XPVAV(p)    del_body_allocated(p, SVt_PVAV)
1041
1042 #define new_XPVHV()     new_body_allocated(SVt_PVHV)
1043 #define del_XPVHV(p)    del_body_allocated(p, SVt_PVHV)
1044
1045 #define new_XPVMG()     new_body_type(SVt_PVMG)
1046 #define del_XPVMG(p)    del_body_type(p, SVt_PVMG)
1047
1048 #define new_XPVGV()     new_body_type(SVt_PVGV)
1049 #define del_XPVGV(p)    del_body_type(p, SVt_PVGV)
1050
1051 #endif /* PURIFY */
1052
1053 /* no arena for you! */
1054
1055 #define new_NOARENA(details) \
1056         my_safemalloc((details)->body_size + (details)->offset)
1057 #define new_NOARENAZ(details) \
1058         my_safecalloc((details)->body_size + (details)->offset)
1059
1060 STATIC void *
1061 S_more_bodies (pTHX_ const svtype sv_type)
1062 {
1063     dVAR;
1064     void ** const root = &PL_body_roots[sv_type];
1065     const struct body_details * const bdp = &bodies_by_type[sv_type];
1066     const size_t body_size = bdp->body_size;
1067     char *start;
1068     const char *end;
1069     const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1070 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1071     static bool done_sanity_check;
1072
1073     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1074      * variables like done_sanity_check. */
1075     if (!done_sanity_check) {
1076         unsigned int i = SVt_LAST;
1077
1078         done_sanity_check = TRUE;
1079
1080         while (i--)
1081             assert (bodies_by_type[i].type == i);
1082     }
1083 #endif
1084
1085     assert(bdp->arena_size);
1086
1087     start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1088
1089     end = start + arena_size - 2 * body_size;
1090
1091     /* computed count doesnt reflect the 1st slot reservation */
1092 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1093     DEBUG_m(PerlIO_printf(Perl_debug_log,
1094                           "arena %p end %p arena-size %d (from %d) type %d "
1095                           "size %d ct %d\n",
1096                           (void*)start, (void*)end, (int)arena_size,
1097                           (int)bdp->arena_size, sv_type, (int)body_size,
1098                           (int)arena_size / (int)body_size));
1099 #else
1100     DEBUG_m(PerlIO_printf(Perl_debug_log,
1101                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1102                           (void*)start, (void*)end,
1103                           (int)bdp->arena_size, sv_type, (int)body_size,
1104                           (int)bdp->arena_size / (int)body_size));
1105 #endif
1106     *root = (void *)start;
1107
1108     while (start <= end) {
1109         char * const next = start + body_size;
1110         *(void**) start = (void *)next;
1111         start = next;
1112     }
1113     *(void **)start = 0;
1114
1115     return *root;
1116 }
1117
1118 /* grab a new thing from the free list, allocating more if necessary.
1119    The inline version is used for speed in hot routines, and the
1120    function using it serves the rest (unless PURIFY).
1121 */
1122 #define new_body_inline(xpv, sv_type) \
1123     STMT_START { \
1124         void ** const r3wt = &PL_body_roots[sv_type]; \
1125         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1126           ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1127         *(r3wt) = *(void**)(xpv); \
1128     } STMT_END
1129
1130 #ifndef PURIFY
1131
1132 STATIC void *
1133 S_new_body(pTHX_ const svtype sv_type)
1134 {
1135     dVAR;
1136     void *xpv;
1137     new_body_inline(xpv, sv_type);
1138     return xpv;
1139 }
1140
1141 #endif
1142
1143 static const struct body_details fake_rv =
1144     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1145
1146 /*
1147 =for apidoc sv_upgrade
1148
1149 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1150 SV, then copies across as much information as possible from the old body.
1151 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1152
1153 =cut
1154 */
1155
1156 void
1157 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1158 {
1159     dVAR;
1160     void*       old_body;
1161     void*       new_body;
1162     const svtype old_type = SvTYPE(sv);
1163     const struct body_details *new_type_details;
1164     const struct body_details *old_type_details
1165         = bodies_by_type + old_type;
1166     SV *referant = NULL;
1167
1168     PERL_ARGS_ASSERT_SV_UPGRADE;
1169
1170     if (old_type == new_type)
1171         return;
1172
1173     /* This clause was purposefully added ahead of the early return above to
1174        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1175        inference by Nick I-S that it would fix other troublesome cases. See
1176        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1177
1178        Given that shared hash key scalars are no longer PVIV, but PV, there is
1179        no longer need to unshare so as to free up the IVX slot for its proper
1180        purpose. So it's safe to move the early return earlier.  */
1181
1182     if (new_type != SVt_PV && SvIsCOW(sv)) {
1183         sv_force_normal_flags(sv, 0);
1184     }
1185
1186     old_body = SvANY(sv);
1187
1188     /* Copying structures onto other structures that have been neatly zeroed
1189        has a subtle gotcha. Consider XPVMG
1190
1191        +------+------+------+------+------+-------+-------+
1192        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1193        +------+------+------+------+------+-------+-------+
1194        0      4      8     12     16     20      24      28
1195
1196        where NVs are aligned to 8 bytes, so that sizeof that structure is
1197        actually 32 bytes long, with 4 bytes of padding at the end:
1198
1199        +------+------+------+------+------+-------+-------+------+
1200        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1201        +------+------+------+------+------+-------+-------+------+
1202        0      4      8     12     16     20      24      28     32
1203
1204        so what happens if you allocate memory for this structure:
1205
1206        +------+------+------+------+------+-------+-------+------+------+...
1207        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1208        +------+------+------+------+------+-------+-------+------+------+...
1209        0      4      8     12     16     20      24      28     32     36
1210
1211        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1212        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1213        started out as zero once, but it's quite possible that it isn't. So now,
1214        rather than a nicely zeroed GP, you have it pointing somewhere random.
1215        Bugs ensue.
1216
1217        (In fact, GP ends up pointing at a previous GP structure, because the
1218        principle cause of the padding in XPVMG getting garbage is a copy of
1219        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1220        this happens to be moot because XPVGV has been re-ordered, with GP
1221        no longer after STASH)
1222
1223        So we are careful and work out the size of used parts of all the
1224        structures.  */
1225
1226     switch (old_type) {
1227     case SVt_NULL:
1228         break;
1229     case SVt_IV:
1230         if (SvROK(sv)) {
1231             referant = SvRV(sv);
1232             old_type_details = &fake_rv;
1233             if (new_type == SVt_NV)
1234                 new_type = SVt_PVNV;
1235         } else {
1236             if (new_type < SVt_PVIV) {
1237                 new_type = (new_type == SVt_NV)
1238                     ? SVt_PVNV : SVt_PVIV;
1239             }
1240         }
1241         break;
1242     case SVt_NV:
1243         if (new_type < SVt_PVNV) {
1244             new_type = SVt_PVNV;
1245         }
1246         break;
1247     case SVt_PV:
1248         assert(new_type > SVt_PV);
1249         assert(SVt_IV < SVt_PV);
1250         assert(SVt_NV < SVt_PV);
1251         break;
1252     case SVt_PVIV:
1253         break;
1254     case SVt_PVNV:
1255         break;
1256     case SVt_PVMG:
1257         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1258            there's no way that it can be safely upgraded, because perl.c
1259            expects to Safefree(SvANY(PL_mess_sv))  */
1260         assert(sv != PL_mess_sv);
1261         /* This flag bit is used to mean other things in other scalar types.
1262            Given that it only has meaning inside the pad, it shouldn't be set
1263            on anything that can get upgraded.  */
1264         assert(!SvPAD_TYPED(sv));
1265         break;
1266     default:
1267         if (old_type_details->cant_upgrade)
1268             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1269                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1270     }
1271
1272     if (old_type > new_type)
1273         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1274                 (int)old_type, (int)new_type);
1275
1276     new_type_details = bodies_by_type + new_type;
1277
1278     SvFLAGS(sv) &= ~SVTYPEMASK;
1279     SvFLAGS(sv) |= new_type;
1280
1281     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1282        the return statements above will have triggered.  */
1283     assert (new_type != SVt_NULL);
1284     switch (new_type) {
1285     case SVt_IV:
1286         assert(old_type == SVt_NULL);
1287         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1288         SvIV_set(sv, 0);
1289         return;
1290     case SVt_NV:
1291         assert(old_type == SVt_NULL);
1292         SvANY(sv) = new_XNV();
1293         SvNV_set(sv, 0);
1294         return;
1295     case SVt_PVHV:
1296     case SVt_PVAV:
1297         assert(new_type_details->body_size);
1298
1299 #ifndef PURIFY
1300         assert(new_type_details->arena);
1301         assert(new_type_details->arena_size);
1302         /* This points to the start of the allocated area.  */
1303         new_body_inline(new_body, new_type);
1304         Zero(new_body, new_type_details->body_size, char);
1305         new_body = ((char *)new_body) - new_type_details->offset;
1306 #else
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         new_body = new_NOARENAZ(new_type_details);
1310 #endif
1311         SvANY(sv) = new_body;
1312         if (new_type == SVt_PVAV) {
1313             AvMAX(sv)   = -1;
1314             AvFILLp(sv) = -1;
1315             AvREAL_only(sv);
1316             if (old_type_details->body_size) {
1317                 AvALLOC(sv) = 0;
1318             } else {
1319                 /* It will have been zeroed when the new body was allocated.
1320                    Lets not write to it, in case it confuses a write-back
1321                    cache.  */
1322             }
1323         } else {
1324             assert(!SvOK(sv));
1325             SvOK_off(sv);
1326 #ifndef NODEFAULT_SHAREKEYS
1327             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1328 #endif
1329             HvMAX(sv) = 7; /* (start with 8 buckets) */
1330             if (old_type_details->body_size) {
1331                 HvFILL(sv) = 0;
1332             } else {
1333                 /* It will have been zeroed when the new body was allocated.
1334                    Lets not write to it, in case it confuses a write-back
1335                    cache.  */
1336             }
1337         }
1338
1339         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1340            The target created by newSVrv also is, and it can have magic.
1341            However, it never has SvPVX set.
1342         */
1343         if (old_type == SVt_IV) {
1344             assert(!SvROK(sv));
1345         } else if (old_type >= SVt_PV) {
1346             assert(SvPVX_const(sv) == 0);
1347         }
1348
1349         if (old_type >= SVt_PVMG) {
1350             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1351             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1352         } else {
1353             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1354         }
1355         break;
1356
1357
1358     case SVt_REGEXP:
1359         /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1360            sv_force_normal_flags(sv) is called.  */
1361         SvFAKE_on(sv);
1362     case SVt_PVIV:
1363         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1364            no route from NV to PVIV, NOK can never be true  */
1365         assert(!SvNOKp(sv));
1366         assert(!SvNOK(sv));
1367     case SVt_PVIO:
1368     case SVt_PVFM:
1369     case SVt_PVGV:
1370     case SVt_PVCV:
1371     case SVt_PVLV:
1372     case SVt_PVMG:
1373     case SVt_PVNV:
1374     case SVt_PV:
1375
1376         assert(new_type_details->body_size);
1377         /* We always allocated the full length item with PURIFY. To do this
1378            we fake things so that arena is false for all 16 types..  */
1379         if(new_type_details->arena) {
1380             /* This points to the start of the allocated area.  */
1381             new_body_inline(new_body, new_type);
1382             Zero(new_body, new_type_details->body_size, char);
1383             new_body = ((char *)new_body) - new_type_details->offset;
1384         } else {
1385             new_body = new_NOARENAZ(new_type_details);
1386         }
1387         SvANY(sv) = new_body;
1388
1389         if (old_type_details->copy) {
1390             /* There is now the potential for an upgrade from something without
1391                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1392             int offset = old_type_details->offset;
1393             int length = old_type_details->copy;
1394
1395             if (new_type_details->offset > old_type_details->offset) {
1396                 const int difference
1397                     = new_type_details->offset - old_type_details->offset;
1398                 offset += difference;
1399                 length -= difference;
1400             }
1401             assert (length >= 0);
1402
1403             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1404                  char);
1405         }
1406
1407 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1408         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1409          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1410          * NV slot, but the new one does, then we need to initialise the
1411          * freshly created NV slot with whatever the correct bit pattern is
1412          * for 0.0  */
1413         if (old_type_details->zero_nv && !new_type_details->zero_nv
1414             && !isGV_with_GP(sv))
1415             SvNV_set(sv, 0);
1416 #endif
1417
1418         if (new_type == SVt_PVIO) {
1419             IO * const io = MUTABLE_IO(sv);
1420             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1421
1422             SvOBJECT_on(io);
1423             /* Clear the stashcache because a new IO could overrule a package
1424                name */
1425             hv_clear(PL_stashcache);
1426
1427             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1428             IoPAGE_LEN(sv) = 60;
1429         }
1430         if (old_type < SVt_PV) {
1431             /* referant will be NULL unless the old type was SVt_IV emulating
1432                SVt_RV */
1433             sv->sv_u.svu_rv = referant;
1434         }
1435         break;
1436     default:
1437         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1438                    (unsigned long)new_type);
1439     }
1440
1441     if (old_type > SVt_IV) {
1442 #ifdef PURIFY
1443         my_safefree(old_body);
1444 #else
1445         /* Note that there is an assumption that all bodies of types that
1446            can be upgraded came from arenas. Only the more complex non-
1447            upgradable types are allowed to be directly malloc()ed.  */
1448         assert(old_type_details->arena);
1449         del_body((void*)((char*)old_body + old_type_details->offset),
1450                  &PL_body_roots[old_type]);
1451 #endif
1452     }
1453 }
1454
1455 /*
1456 =for apidoc sv_backoff
1457
1458 Remove any string offset. You should normally use the C<SvOOK_off> macro
1459 wrapper instead.
1460
1461 =cut
1462 */
1463
1464 int
1465 Perl_sv_backoff(pTHX_ register SV *const sv)
1466 {
1467     STRLEN delta;
1468     const char * const s = SvPVX_const(sv);
1469
1470     PERL_ARGS_ASSERT_SV_BACKOFF;
1471     PERL_UNUSED_CONTEXT;
1472
1473     assert(SvOOK(sv));
1474     assert(SvTYPE(sv) != SVt_PVHV);
1475     assert(SvTYPE(sv) != SVt_PVAV);
1476
1477     SvOOK_offset(sv, delta);
1478
1479     SvLEN_set(sv, SvLEN(sv) + delta);
1480     SvPV_set(sv, SvPVX(sv) - delta);
1481     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1482     SvFLAGS(sv) &= ~SVf_OOK;
1483     return 0;
1484 }
1485
1486 /*
1487 =for apidoc sv_grow
1488
1489 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1490 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1491 Use the C<SvGROW> wrapper instead.
1492
1493 =cut
1494 */
1495
1496 char *
1497 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1498 {
1499     register char *s;
1500
1501     PERL_ARGS_ASSERT_SV_GROW;
1502
1503     if (PL_madskills && newlen >= 0x100000) {
1504         PerlIO_printf(Perl_debug_log,
1505                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1506     }
1507 #ifdef HAS_64K_LIMIT
1508     if (newlen >= 0x10000) {
1509         PerlIO_printf(Perl_debug_log,
1510                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1511         my_exit(1);
1512     }
1513 #endif /* HAS_64K_LIMIT */
1514     if (SvROK(sv))
1515         sv_unref(sv);
1516     if (SvTYPE(sv) < SVt_PV) {
1517         sv_upgrade(sv, SVt_PV);
1518         s = SvPVX_mutable(sv);
1519     }
1520     else if (SvOOK(sv)) {       /* pv is offset? */
1521         sv_backoff(sv);
1522         s = SvPVX_mutable(sv);
1523         if (newlen > SvLEN(sv))
1524             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1525 #ifdef HAS_64K_LIMIT
1526         if (newlen >= 0x10000)
1527             newlen = 0xFFFF;
1528 #endif
1529     }
1530     else
1531         s = SvPVX_mutable(sv);
1532
1533     if (newlen > SvLEN(sv)) {           /* need more room? */
1534 #ifndef Perl_safesysmalloc_size
1535         newlen = PERL_STRLEN_ROUNDUP(newlen);
1536 #endif
1537         if (SvLEN(sv) && s) {
1538             s = (char*)saferealloc(s, newlen);
1539         }
1540         else {
1541             s = (char*)safemalloc(newlen);
1542             if (SvPVX_const(sv) && SvCUR(sv)) {
1543                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1544             }
1545         }
1546         SvPV_set(sv, s);
1547 #ifdef Perl_safesysmalloc_size
1548         /* Do this here, do it once, do it right, and then we will never get
1549            called back into sv_grow() unless there really is some growing
1550            needed.  */
1551         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1552 #else
1553         SvLEN_set(sv, newlen);
1554 #endif
1555     }
1556     return s;
1557 }
1558
1559 /*
1560 =for apidoc sv_setiv
1561
1562 Copies an integer into the given SV, upgrading first if necessary.
1563 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1564
1565 =cut
1566 */
1567
1568 void
1569 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1570 {
1571     dVAR;
1572
1573     PERL_ARGS_ASSERT_SV_SETIV;
1574
1575     SV_CHECK_THINKFIRST_COW_DROP(sv);
1576     switch (SvTYPE(sv)) {
1577     case SVt_NULL:
1578     case SVt_NV:
1579         sv_upgrade(sv, SVt_IV);
1580         break;
1581     case SVt_PV:
1582         sv_upgrade(sv, SVt_PVIV);
1583         break;
1584
1585     case SVt_PVGV:
1586         if (!isGV_with_GP(sv))
1587             break;
1588     case SVt_PVAV:
1589     case SVt_PVHV:
1590     case SVt_PVCV:
1591     case SVt_PVFM:
1592     case SVt_PVIO:
1593         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1594                    OP_DESC(PL_op));
1595     default: NOOP;
1596     }
1597     (void)SvIOK_only(sv);                       /* validate number */
1598     SvIV_set(sv, i);
1599     SvTAINT(sv);
1600 }
1601
1602 /*
1603 =for apidoc sv_setiv_mg
1604
1605 Like C<sv_setiv>, but also handles 'set' magic.
1606
1607 =cut
1608 */
1609
1610 void
1611 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1612 {
1613     PERL_ARGS_ASSERT_SV_SETIV_MG;
1614
1615     sv_setiv(sv,i);
1616     SvSETMAGIC(sv);
1617 }
1618
1619 /*
1620 =for apidoc sv_setuv
1621
1622 Copies an unsigned integer into the given SV, upgrading first if necessary.
1623 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1624
1625 =cut
1626 */
1627
1628 void
1629 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1630 {
1631     PERL_ARGS_ASSERT_SV_SETUV;
1632
1633     /* With these two if statements:
1634        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1635
1636        without
1637        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1638
1639        If you wish to remove them, please benchmark to see what the effect is
1640     */
1641     if (u <= (UV)IV_MAX) {
1642        sv_setiv(sv, (IV)u);
1643        return;
1644     }
1645     sv_setiv(sv, 0);
1646     SvIsUV_on(sv);
1647     SvUV_set(sv, u);
1648 }
1649
1650 /*
1651 =for apidoc sv_setuv_mg
1652
1653 Like C<sv_setuv>, but also handles 'set' magic.
1654
1655 =cut
1656 */
1657
1658 void
1659 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1660 {
1661     PERL_ARGS_ASSERT_SV_SETUV_MG;
1662
1663     sv_setuv(sv,u);
1664     SvSETMAGIC(sv);
1665 }
1666
1667 /*
1668 =for apidoc sv_setnv
1669
1670 Copies a double into the given SV, upgrading first if necessary.
1671 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1672
1673 =cut
1674 */
1675
1676 void
1677 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1678 {
1679     dVAR;
1680
1681     PERL_ARGS_ASSERT_SV_SETNV;
1682
1683     SV_CHECK_THINKFIRST_COW_DROP(sv);
1684     switch (SvTYPE(sv)) {
1685     case SVt_NULL:
1686     case SVt_IV:
1687         sv_upgrade(sv, SVt_NV);
1688         break;
1689     case SVt_PV:
1690     case SVt_PVIV:
1691         sv_upgrade(sv, SVt_PVNV);
1692         break;
1693
1694     case SVt_PVGV:
1695         if (!isGV_with_GP(sv))
1696             break;
1697     case SVt_PVAV:
1698     case SVt_PVHV:
1699     case SVt_PVCV:
1700     case SVt_PVFM:
1701     case SVt_PVIO:
1702         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1703                    OP_DESC(PL_op));
1704     default: NOOP;
1705     }
1706     SvNV_set(sv, num);
1707     (void)SvNOK_only(sv);                       /* validate number */
1708     SvTAINT(sv);
1709 }
1710
1711 /*
1712 =for apidoc sv_setnv_mg
1713
1714 Like C<sv_setnv>, but also handles 'set' magic.
1715
1716 =cut
1717 */
1718
1719 void
1720 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1721 {
1722     PERL_ARGS_ASSERT_SV_SETNV_MG;
1723
1724     sv_setnv(sv,num);
1725     SvSETMAGIC(sv);
1726 }
1727
1728 /* Print an "isn't numeric" warning, using a cleaned-up,
1729  * printable version of the offending string
1730  */
1731
1732 STATIC void
1733 S_not_a_number(pTHX_ SV *const sv)
1734 {
1735      dVAR;
1736      SV *dsv;
1737      char tmpbuf[64];
1738      const char *pv;
1739
1740      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1741
1742      if (DO_UTF8(sv)) {
1743           dsv = newSVpvs_flags("", SVs_TEMP);
1744           pv = sv_uni_display(dsv, sv, 10, 0);
1745      } else {
1746           char *d = tmpbuf;
1747           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1748           /* each *s can expand to 4 chars + "...\0",
1749              i.e. need room for 8 chars */
1750
1751           const char *s = SvPVX_const(sv);
1752           const char * const end = s + SvCUR(sv);
1753           for ( ; s < end && d < limit; s++ ) {
1754                int ch = *s & 0xFF;
1755                if (ch & 128 && !isPRINT_LC(ch)) {
1756                     *d++ = 'M';
1757                     *d++ = '-';
1758                     ch &= 127;
1759                }
1760                if (ch == '\n') {
1761                     *d++ = '\\';
1762                     *d++ = 'n';
1763                }
1764                else if (ch == '\r') {
1765                     *d++ = '\\';
1766                     *d++ = 'r';
1767                }
1768                else if (ch == '\f') {
1769                     *d++ = '\\';
1770                     *d++ = 'f';
1771                }
1772                else if (ch == '\\') {
1773                     *d++ = '\\';
1774                     *d++ = '\\';
1775                }
1776                else if (ch == '\0') {
1777                     *d++ = '\\';
1778                     *d++ = '0';
1779                }
1780                else if (isPRINT_LC(ch))
1781                     *d++ = ch;
1782                else {
1783                     *d++ = '^';
1784                     *d++ = toCTRL(ch);
1785                }
1786           }
1787           if (s < end) {
1788                *d++ = '.';
1789                *d++ = '.';
1790                *d++ = '.';
1791           }
1792           *d = '\0';
1793           pv = tmpbuf;
1794     }
1795
1796     if (PL_op)
1797         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1798                     "Argument \"%s\" isn't numeric in %s", pv,
1799                     OP_DESC(PL_op));
1800     else
1801         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1802                     "Argument \"%s\" isn't numeric", pv);
1803 }
1804
1805 /*
1806 =for apidoc looks_like_number
1807
1808 Test if the content of an SV looks like a number (or is a number).
1809 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1810 non-numeric warning), even if your atof() doesn't grok them.
1811
1812 =cut
1813 */
1814
1815 I32
1816 Perl_looks_like_number(pTHX_ SV *const sv)
1817 {
1818     register const char *sbegin;
1819     STRLEN len;
1820
1821     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1822
1823     if (SvPOK(sv)) {
1824         sbegin = SvPVX_const(sv);
1825         len = SvCUR(sv);
1826     }
1827     else if (SvPOKp(sv))
1828         sbegin = SvPV_const(sv, len);
1829     else
1830         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1831     return grok_number(sbegin, len, NULL);
1832 }
1833
1834 STATIC bool
1835 S_glob_2number(pTHX_ GV * const gv)
1836 {
1837     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1838     SV *const buffer = sv_newmortal();
1839
1840     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1841
1842     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1843        is on.  */
1844     SvFAKE_off(gv);
1845     gv_efullname3(buffer, gv, "*");
1846     SvFLAGS(gv) |= wasfake;
1847
1848     /* We know that all GVs stringify to something that is not-a-number,
1849         so no need to test that.  */
1850     if (ckWARN(WARN_NUMERIC))
1851         not_a_number(buffer);
1852     /* We just want something true to return, so that S_sv_2iuv_common
1853         can tail call us and return true.  */
1854     return TRUE;
1855 }
1856
1857 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1858    until proven guilty, assume that things are not that bad... */
1859
1860 /*
1861    NV_PRESERVES_UV:
1862
1863    As 64 bit platforms often have an NV that doesn't preserve all bits of
1864    an IV (an assumption perl has been based on to date) it becomes necessary
1865    to remove the assumption that the NV always carries enough precision to
1866    recreate the IV whenever needed, and that the NV is the canonical form.
1867    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1868    precision as a side effect of conversion (which would lead to insanity
1869    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1870    1) to distinguish between IV/UV/NV slots that have cached a valid
1871       conversion where precision was lost and IV/UV/NV slots that have a
1872       valid conversion which has lost no precision
1873    2) to ensure that if a numeric conversion to one form is requested that
1874       would lose precision, the precise conversion (or differently
1875       imprecise conversion) is also performed and cached, to prevent
1876       requests for different numeric formats on the same SV causing
1877       lossy conversion chains. (lossless conversion chains are perfectly
1878       acceptable (still))
1879
1880
1881    flags are used:
1882    SvIOKp is true if the IV slot contains a valid value
1883    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1884    SvNOKp is true if the NV slot contains a valid value
1885    SvNOK  is true only if the NV value is accurate
1886
1887    so
1888    while converting from PV to NV, check to see if converting that NV to an
1889    IV(or UV) would lose accuracy over a direct conversion from PV to
1890    IV(or UV). If it would, cache both conversions, return NV, but mark
1891    SV as IOK NOKp (ie not NOK).
1892
1893    While converting from PV to IV, check to see if converting that IV to an
1894    NV would lose accuracy over a direct conversion from PV to NV. If it
1895    would, cache both conversions, flag similarly.
1896
1897    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1898    correctly because if IV & NV were set NV *always* overruled.
1899    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1900    changes - now IV and NV together means that the two are interchangeable:
1901    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1902
1903    The benefit of this is that operations such as pp_add know that if
1904    SvIOK is true for both left and right operands, then integer addition
1905    can be used instead of floating point (for cases where the result won't
1906    overflow). Before, floating point was always used, which could lead to
1907    loss of precision compared with integer addition.
1908
1909    * making IV and NV equal status should make maths accurate on 64 bit
1910      platforms
1911    * may speed up maths somewhat if pp_add and friends start to use
1912      integers when possible instead of fp. (Hopefully the overhead in
1913      looking for SvIOK and checking for overflow will not outweigh the
1914      fp to integer speedup)
1915    * will slow down integer operations (callers of SvIV) on "inaccurate"
1916      values, as the change from SvIOK to SvIOKp will cause a call into
1917      sv_2iv each time rather than a macro access direct to the IV slot
1918    * should speed up number->string conversion on integers as IV is
1919      favoured when IV and NV are equally accurate
1920
1921    ####################################################################
1922    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1923    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1924    On the other hand, SvUOK is true iff UV.
1925    ####################################################################
1926
1927    Your mileage will vary depending your CPU's relative fp to integer
1928    performance ratio.
1929 */
1930
1931 #ifndef NV_PRESERVES_UV
1932 #  define IS_NUMBER_UNDERFLOW_IV 1
1933 #  define IS_NUMBER_UNDERFLOW_UV 2
1934 #  define IS_NUMBER_IV_AND_UV    2
1935 #  define IS_NUMBER_OVERFLOW_IV  4
1936 #  define IS_NUMBER_OVERFLOW_UV  5
1937
1938 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1939
1940 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1941 STATIC int
1942 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1943 #  ifdef DEBUGGING
1944                        , I32 numtype
1945 #  endif
1946                        )
1947 {
1948     dVAR;
1949
1950     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1951
1952     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));
1953     if (SvNVX(sv) < (NV)IV_MIN) {
1954         (void)SvIOKp_on(sv);
1955         (void)SvNOK_on(sv);
1956         SvIV_set(sv, IV_MIN);
1957         return IS_NUMBER_UNDERFLOW_IV;
1958     }
1959     if (SvNVX(sv) > (NV)UV_MAX) {
1960         (void)SvIOKp_on(sv);
1961         (void)SvNOK_on(sv);
1962         SvIsUV_on(sv);
1963         SvUV_set(sv, UV_MAX);
1964         return IS_NUMBER_OVERFLOW_UV;
1965     }
1966     (void)SvIOKp_on(sv);
1967     (void)SvNOK_on(sv);
1968     /* Can't use strtol etc to convert this string.  (See truth table in
1969        sv_2iv  */
1970     if (SvNVX(sv) <= (UV)IV_MAX) {
1971         SvIV_set(sv, I_V(SvNVX(sv)));
1972         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1973             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1974         } else {
1975             /* Integer is imprecise. NOK, IOKp */
1976         }
1977         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1978     }
1979     SvIsUV_on(sv);
1980     SvUV_set(sv, U_V(SvNVX(sv)));
1981     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1982         if (SvUVX(sv) == UV_MAX) {
1983             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1984                possibly be preserved by NV. Hence, it must be overflow.
1985                NOK, IOKp */
1986             return IS_NUMBER_OVERFLOW_UV;
1987         }
1988         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1989     } else {
1990         /* Integer is imprecise. NOK, IOKp */
1991     }
1992     return IS_NUMBER_OVERFLOW_IV;
1993 }
1994 #endif /* !NV_PRESERVES_UV*/
1995
1996 STATIC bool
1997 S_sv_2iuv_common(pTHX_ SV *const sv)
1998 {
1999     dVAR;
2000
2001     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2002
2003     if (SvNOKp(sv)) {
2004         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2005          * without also getting a cached IV/UV from it at the same time
2006          * (ie PV->NV conversion should detect loss of accuracy and cache
2007          * IV or UV at same time to avoid this. */
2008         /* IV-over-UV optimisation - choose to cache IV if possible */
2009
2010         if (SvTYPE(sv) == SVt_NV)
2011             sv_upgrade(sv, SVt_PVNV);
2012
2013         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2014         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2015            certainly cast into the IV range at IV_MAX, whereas the correct
2016            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2017            cases go to UV */
2018 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2019         if (Perl_isnan(SvNVX(sv))) {
2020             SvUV_set(sv, 0);
2021             SvIsUV_on(sv);
2022             return FALSE;
2023         }
2024 #endif
2025         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2026             SvIV_set(sv, I_V(SvNVX(sv)));
2027             if (SvNVX(sv) == (NV) SvIVX(sv)
2028 #ifndef NV_PRESERVES_UV
2029                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2030                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2031                 /* Don't flag it as "accurately an integer" if the number
2032                    came from a (by definition imprecise) NV operation, and
2033                    we're outside the range of NV integer precision */
2034 #endif
2035                 ) {
2036                 if (SvNOK(sv))
2037                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2038                 else {
2039                     /* scalar has trailing garbage, eg "42a" */
2040                 }
2041                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2042                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2043                                       PTR2UV(sv),
2044                                       SvNVX(sv),
2045                                       SvIVX(sv)));
2046
2047             } else {
2048                 /* IV not precise.  No need to convert from PV, as NV
2049                    conversion would already have cached IV if it detected
2050                    that PV->IV would be better than PV->NV->IV
2051                    flags already correct - don't set public IOK.  */
2052                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2053                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2054                                       PTR2UV(sv),
2055                                       SvNVX(sv),
2056                                       SvIVX(sv)));
2057             }
2058             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2059                but the cast (NV)IV_MIN rounds to a the value less (more
2060                negative) than IV_MIN which happens to be equal to SvNVX ??
2061                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2062                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2063                (NV)UVX == NVX are both true, but the values differ. :-(
2064                Hopefully for 2s complement IV_MIN is something like
2065                0x8000000000000000 which will be exact. NWC */
2066         }
2067         else {
2068             SvUV_set(sv, U_V(SvNVX(sv)));
2069             if (
2070                 (SvNVX(sv) == (NV) SvUVX(sv))
2071 #ifndef  NV_PRESERVES_UV
2072                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2073                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2074                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2075                 /* Don't flag it as "accurately an integer" if the number
2076                    came from a (by definition imprecise) NV operation, and
2077                    we're outside the range of NV integer precision */
2078 #endif
2079                 && SvNOK(sv)
2080                 )
2081                 SvIOK_on(sv);
2082             SvIsUV_on(sv);
2083             DEBUG_c(PerlIO_printf(Perl_debug_log,
2084                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2085                                   PTR2UV(sv),
2086                                   SvUVX(sv),
2087                                   SvUVX(sv)));
2088         }
2089     }
2090     else if (SvPOKp(sv) && SvLEN(sv)) {
2091         UV value;
2092         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2093         /* We want to avoid a possible problem when we cache an IV/ a UV which
2094            may be later translated to an NV, and the resulting NV is not
2095            the same as the direct translation of the initial string
2096            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2097            be careful to ensure that the value with the .456 is around if the
2098            NV value is requested in the future).
2099
2100            This means that if we cache such an IV/a UV, we need to cache the
2101            NV as well.  Moreover, we trade speed for space, and do not
2102            cache the NV if we are sure it's not needed.
2103          */
2104
2105         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2106         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2107              == IS_NUMBER_IN_UV) {
2108             /* It's definitely an integer, only upgrade to PVIV */
2109             if (SvTYPE(sv) < SVt_PVIV)
2110                 sv_upgrade(sv, SVt_PVIV);
2111             (void)SvIOK_on(sv);
2112         } else if (SvTYPE(sv) < SVt_PVNV)
2113             sv_upgrade(sv, SVt_PVNV);
2114
2115         /* If NVs preserve UVs then we only use the UV value if we know that
2116            we aren't going to call atof() below. If NVs don't preserve UVs
2117            then the value returned may have more precision than atof() will
2118            return, even though value isn't perfectly accurate.  */
2119         if ((numtype & (IS_NUMBER_IN_UV
2120 #ifdef NV_PRESERVES_UV
2121                         | IS_NUMBER_NOT_INT
2122 #endif
2123             )) == IS_NUMBER_IN_UV) {
2124             /* This won't turn off the public IOK flag if it was set above  */
2125             (void)SvIOKp_on(sv);
2126
2127             if (!(numtype & IS_NUMBER_NEG)) {
2128                 /* positive */;
2129                 if (value <= (UV)IV_MAX) {
2130                     SvIV_set(sv, (IV)value);
2131                 } else {
2132                     /* it didn't overflow, and it was positive. */
2133                     SvUV_set(sv, value);
2134                     SvIsUV_on(sv);
2135                 }
2136             } else {
2137                 /* 2s complement assumption  */
2138                 if (value <= (UV)IV_MIN) {
2139                     SvIV_set(sv, -(IV)value);
2140                 } else {
2141                     /* Too negative for an IV.  This is a double upgrade, but
2142                        I'm assuming it will be rare.  */
2143                     if (SvTYPE(sv) < SVt_PVNV)
2144                         sv_upgrade(sv, SVt_PVNV);
2145                     SvNOK_on(sv);
2146                     SvIOK_off(sv);
2147                     SvIOKp_on(sv);
2148                     SvNV_set(sv, -(NV)value);
2149                     SvIV_set(sv, IV_MIN);
2150                 }
2151             }
2152         }
2153         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2154            will be in the previous block to set the IV slot, and the next
2155            block to set the NV slot.  So no else here.  */
2156
2157         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2158             != IS_NUMBER_IN_UV) {
2159             /* It wasn't an (integer that doesn't overflow the UV). */
2160             SvNV_set(sv, Atof(SvPVX_const(sv)));
2161
2162             if (! numtype && ckWARN(WARN_NUMERIC))
2163                 not_a_number(sv);
2164
2165 #if defined(USE_LONG_DOUBLE)
2166             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2167                                   PTR2UV(sv), SvNVX(sv)));
2168 #else
2169             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2170                                   PTR2UV(sv), SvNVX(sv)));
2171 #endif
2172
2173 #ifdef NV_PRESERVES_UV
2174             (void)SvIOKp_on(sv);
2175             (void)SvNOK_on(sv);
2176             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2177                 SvIV_set(sv, I_V(SvNVX(sv)));
2178                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2179                     SvIOK_on(sv);
2180                 } else {
2181                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2182                 }
2183                 /* UV will not work better than IV */
2184             } else {
2185                 if (SvNVX(sv) > (NV)UV_MAX) {
2186                     SvIsUV_on(sv);
2187                     /* Integer is inaccurate. NOK, IOKp, is UV */
2188                     SvUV_set(sv, UV_MAX);
2189                 } else {
2190                     SvUV_set(sv, U_V(SvNVX(sv)));
2191                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2192                        NV preservse UV so can do correct comparison.  */
2193                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2194                         SvIOK_on(sv);
2195                     } else {
2196                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2197                     }
2198                 }
2199                 SvIsUV_on(sv);
2200             }
2201 #else /* NV_PRESERVES_UV */
2202             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2203                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2204                 /* The IV/UV slot will have been set from value returned by
2205                    grok_number above.  The NV slot has just been set using
2206                    Atof.  */
2207                 SvNOK_on(sv);
2208                 assert (SvIOKp(sv));
2209             } else {
2210                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2211                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2212                     /* Small enough to preserve all bits. */
2213                     (void)SvIOKp_on(sv);
2214                     SvNOK_on(sv);
2215                     SvIV_set(sv, I_V(SvNVX(sv)));
2216                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2217                         SvIOK_on(sv);
2218                     /* Assumption: first non-preserved integer is < IV_MAX,
2219                        this NV is in the preserved range, therefore: */
2220                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2221                           < (UV)IV_MAX)) {
2222                         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);
2223                     }
2224                 } else {
2225                     /* IN_UV NOT_INT
2226                          0      0       already failed to read UV.
2227                          0      1       already failed to read UV.
2228                          1      0       you won't get here in this case. IV/UV
2229                                         slot set, public IOK, Atof() unneeded.
2230                          1      1       already read UV.
2231                        so there's no point in sv_2iuv_non_preserve() attempting
2232                        to use atol, strtol, strtoul etc.  */
2233 #  ifdef DEBUGGING
2234                     sv_2iuv_non_preserve (sv, numtype);
2235 #  else
2236                     sv_2iuv_non_preserve (sv);
2237 #  endif
2238                 }
2239             }
2240 #endif /* NV_PRESERVES_UV */
2241         /* It might be more code efficient to go through the entire logic above
2242            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2243            gets complex and potentially buggy, so more programmer efficient
2244            to do it this way, by turning off the public flags:  */
2245         if (!numtype)
2246             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2247         }
2248     }
2249     else  {
2250         if (isGV_with_GP(sv))
2251             return glob_2number(MUTABLE_GV(sv));
2252
2253         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2254             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2255                 report_uninit(sv);
2256         }
2257         if (SvTYPE(sv) < SVt_IV)
2258             /* Typically the caller expects that sv_any is not NULL now.  */
2259             sv_upgrade(sv, SVt_IV);
2260         /* Return 0 from the caller.  */
2261         return TRUE;
2262     }
2263     return FALSE;
2264 }
2265
2266 /*
2267 =for apidoc sv_2iv_flags
2268
2269 Return the integer value of an SV, doing any necessary string
2270 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2271 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2272
2273 =cut
2274 */
2275
2276 IV
2277 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2278 {
2279     dVAR;
2280     if (!sv)
2281         return 0;
2282     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2283         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2284            cache IVs just in case. In practice it seems that they never
2285            actually anywhere accessible by user Perl code, let alone get used
2286            in anything other than a string context.  */
2287         if (flags & SV_GMAGIC)
2288             mg_get(sv);
2289         if (SvIOKp(sv))
2290             return SvIVX(sv);
2291         if (SvNOKp(sv)) {
2292             return I_V(SvNVX(sv));
2293         }
2294         if (SvPOKp(sv) && SvLEN(sv)) {
2295             UV value;
2296             const int numtype
2297                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2298
2299             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2300                 == IS_NUMBER_IN_UV) {
2301                 /* It's definitely an integer */
2302                 if (numtype & IS_NUMBER_NEG) {
2303                     if (value < (UV)IV_MIN)
2304                         return -(IV)value;
2305                 } else {
2306                     if (value < (UV)IV_MAX)
2307                         return (IV)value;
2308                 }
2309             }
2310             if (!numtype) {
2311                 if (ckWARN(WARN_NUMERIC))
2312                     not_a_number(sv);
2313             }
2314             return I_V(Atof(SvPVX_const(sv)));
2315         }
2316         if (SvROK(sv)) {
2317             goto return_rok;
2318         }
2319         assert(SvTYPE(sv) >= SVt_PVMG);
2320         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2321     } else if (SvTHINKFIRST(sv)) {
2322         if (SvROK(sv)) {
2323         return_rok:
2324             if (SvAMAGIC(sv)) {
2325                 SV * const tmpstr=AMG_CALLun(sv,numer);
2326                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2327                     return SvIV(tmpstr);
2328                 }
2329             }
2330             return PTR2IV(SvRV(sv));
2331         }
2332         if (SvIsCOW(sv)) {
2333             sv_force_normal_flags(sv, 0);
2334         }
2335         if (SvREADONLY(sv) && !SvOK(sv)) {
2336             if (ckWARN(WARN_UNINITIALIZED))
2337                 report_uninit(sv);
2338             return 0;
2339         }
2340     }
2341     if (!SvIOKp(sv)) {
2342         if (S_sv_2iuv_common(aTHX_ sv))
2343             return 0;
2344     }
2345     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2346         PTR2UV(sv),SvIVX(sv)));
2347     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2348 }
2349
2350 /*
2351 =for apidoc sv_2uv_flags
2352
2353 Return the unsigned integer value of an SV, doing any necessary string
2354 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2355 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2356
2357 =cut
2358 */
2359
2360 UV
2361 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2362 {
2363     dVAR;
2364     if (!sv)
2365         return 0;
2366     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2367         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2368            cache IVs just in case.  */
2369         if (flags & SV_GMAGIC)
2370             mg_get(sv);
2371         if (SvIOKp(sv))
2372             return SvUVX(sv);
2373         if (SvNOKp(sv))
2374             return U_V(SvNVX(sv));
2375         if (SvPOKp(sv) && SvLEN(sv)) {
2376             UV value;
2377             const int numtype
2378                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2379
2380             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2381                 == IS_NUMBER_IN_UV) {
2382                 /* It's definitely an integer */
2383                 if (!(numtype & IS_NUMBER_NEG))
2384                     return value;
2385             }
2386             if (!numtype) {
2387                 if (ckWARN(WARN_NUMERIC))
2388                     not_a_number(sv);
2389             }
2390             return U_V(Atof(SvPVX_const(sv)));
2391         }
2392         if (SvROK(sv)) {
2393             goto return_rok;
2394         }
2395         assert(SvTYPE(sv) >= SVt_PVMG);
2396         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2397     } else if (SvTHINKFIRST(sv)) {
2398         if (SvROK(sv)) {
2399         return_rok:
2400             if (SvAMAGIC(sv)) {
2401                 SV *const tmpstr = AMG_CALLun(sv,numer);
2402                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2403                     return SvUV(tmpstr);
2404                 }
2405             }
2406             return PTR2UV(SvRV(sv));
2407         }
2408         if (SvIsCOW(sv)) {
2409             sv_force_normal_flags(sv, 0);
2410         }
2411         if (SvREADONLY(sv) && !SvOK(sv)) {
2412             if (ckWARN(WARN_UNINITIALIZED))
2413                 report_uninit(sv);
2414             return 0;
2415         }
2416     }
2417     if (!SvIOKp(sv)) {
2418         if (S_sv_2iuv_common(aTHX_ sv))
2419             return 0;
2420     }
2421
2422     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2423                           PTR2UV(sv),SvUVX(sv)));
2424     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2425 }
2426
2427 /*
2428 =for apidoc sv_2nv
2429
2430 Return the num value of an SV, doing any necessary string or integer
2431 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2432 macros.
2433
2434 =cut
2435 */
2436
2437 NV
2438 Perl_sv_2nv(pTHX_ register SV *const sv)
2439 {
2440     dVAR;
2441     if (!sv)
2442         return 0.0;
2443     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2444         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2445            cache IVs just in case.  */
2446         mg_get(sv);
2447         if (SvNOKp(sv))
2448             return SvNVX(sv);
2449         if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2450             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2451                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2452                 not_a_number(sv);
2453             return Atof(SvPVX_const(sv));
2454         }
2455         if (SvIOKp(sv)) {
2456             if (SvIsUV(sv))
2457                 return (NV)SvUVX(sv);
2458             else
2459                 return (NV)SvIVX(sv);
2460         }
2461         if (SvROK(sv)) {
2462             goto return_rok;
2463         }
2464         assert(SvTYPE(sv) >= SVt_PVMG);
2465         /* This falls through to the report_uninit near the end of the
2466            function. */
2467     } else if (SvTHINKFIRST(sv)) {
2468         if (SvROK(sv)) {
2469         return_rok:
2470             if (SvAMAGIC(sv)) {
2471                 SV *const tmpstr = AMG_CALLun(sv,numer);
2472                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2473                     return SvNV(tmpstr);
2474                 }
2475             }
2476             return PTR2NV(SvRV(sv));
2477         }
2478         if (SvIsCOW(sv)) {
2479             sv_force_normal_flags(sv, 0);
2480         }
2481         if (SvREADONLY(sv) && !SvOK(sv)) {
2482             if (ckWARN(WARN_UNINITIALIZED))
2483                 report_uninit(sv);
2484             return 0.0;
2485         }
2486     }
2487     if (SvTYPE(sv) < SVt_NV) {
2488         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2489         sv_upgrade(sv, SVt_NV);
2490 #ifdef USE_LONG_DOUBLE
2491         DEBUG_c({
2492             STORE_NUMERIC_LOCAL_SET_STANDARD();
2493             PerlIO_printf(Perl_debug_log,
2494                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2495                           PTR2UV(sv), SvNVX(sv));
2496             RESTORE_NUMERIC_LOCAL();
2497         });
2498 #else
2499         DEBUG_c({
2500             STORE_NUMERIC_LOCAL_SET_STANDARD();
2501             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2502                           PTR2UV(sv), SvNVX(sv));
2503             RESTORE_NUMERIC_LOCAL();
2504         });
2505 #endif
2506     }
2507     else if (SvTYPE(sv) < SVt_PVNV)
2508         sv_upgrade(sv, SVt_PVNV);
2509     if (SvNOKp(sv)) {
2510         return SvNVX(sv);
2511     }
2512     if (SvIOKp(sv)) {
2513         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2514 #ifdef NV_PRESERVES_UV
2515         if (SvIOK(sv))
2516             SvNOK_on(sv);
2517         else
2518             SvNOKp_on(sv);
2519 #else
2520         /* Only set the public NV OK flag if this NV preserves the IV  */
2521         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2522         if (SvIOK(sv) &&
2523             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2524                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2525             SvNOK_on(sv);
2526         else
2527             SvNOKp_on(sv);
2528 #endif
2529     }
2530     else if (SvPOKp(sv) && SvLEN(sv)) {
2531         UV value;
2532         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2533         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2534             not_a_number(sv);
2535 #ifdef NV_PRESERVES_UV
2536         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2537             == IS_NUMBER_IN_UV) {
2538             /* It's definitely an integer */
2539             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2540         } else
2541             SvNV_set(sv, Atof(SvPVX_const(sv)));
2542         if (numtype)
2543             SvNOK_on(sv);
2544         else
2545             SvNOKp_on(sv);
2546 #else
2547         SvNV_set(sv, Atof(SvPVX_const(sv)));
2548         /* Only set the public NV OK flag if this NV preserves the value in
2549            the PV at least as well as an IV/UV would.
2550            Not sure how to do this 100% reliably. */
2551         /* if that shift count is out of range then Configure's test is
2552            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2553            UV_BITS */
2554         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2555             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2556             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2557         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2558             /* Can't use strtol etc to convert this string, so don't try.
2559                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2560             SvNOK_on(sv);
2561         } else {
2562             /* value has been set.  It may not be precise.  */
2563             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2564                 /* 2s complement assumption for (UV)IV_MIN  */
2565                 SvNOK_on(sv); /* Integer is too negative.  */
2566             } else {
2567                 SvNOKp_on(sv);
2568                 SvIOKp_on(sv);
2569
2570                 if (numtype & IS_NUMBER_NEG) {
2571                     SvIV_set(sv, -(IV)value);
2572                 } else if (value <= (UV)IV_MAX) {
2573                     SvIV_set(sv, (IV)value);
2574                 } else {
2575                     SvUV_set(sv, value);
2576                     SvIsUV_on(sv);
2577                 }
2578
2579                 if (numtype & IS_NUMBER_NOT_INT) {
2580                     /* I believe that even if the original PV had decimals,
2581                        they are lost beyond the limit of the FP precision.
2582                        However, neither is canonical, so both only get p
2583                        flags.  NWC, 2000/11/25 */
2584                     /* Both already have p flags, so do nothing */
2585                 } else {
2586                     const NV nv = SvNVX(sv);
2587                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2588                         if (SvIVX(sv) == I_V(nv)) {
2589                             SvNOK_on(sv);
2590                         } else {
2591                             /* It had no "." so it must be integer.  */
2592                         }
2593                         SvIOK_on(sv);
2594                     } else {
2595                         /* between IV_MAX and NV(UV_MAX).
2596                            Could be slightly > UV_MAX */
2597
2598                         if (numtype & IS_NUMBER_NOT_INT) {
2599                             /* UV and NV both imprecise.  */
2600                         } else {
2601                             const UV nv_as_uv = U_V(nv);
2602
2603                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2604                                 SvNOK_on(sv);
2605                             }
2606                             SvIOK_on(sv);
2607                         }
2608                     }
2609                 }
2610             }
2611         }
2612         /* It might be more code efficient to go through the entire logic above
2613            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2614            gets complex and potentially buggy, so more programmer efficient
2615            to do it this way, by turning off the public flags:  */
2616         if (!numtype)
2617             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2618 #endif /* NV_PRESERVES_UV */
2619     }
2620     else  {
2621         if (isGV_with_GP(sv)) {
2622             glob_2number(MUTABLE_GV(sv));
2623             return 0.0;
2624         }
2625
2626         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2627             report_uninit(sv);
2628         assert (SvTYPE(sv) >= SVt_NV);
2629         /* Typically the caller expects that sv_any is not NULL now.  */
2630         /* XXX Ilya implies that this is a bug in callers that assume this
2631            and ideally should be fixed.  */
2632         return 0.0;
2633     }
2634 #if defined(USE_LONG_DOUBLE)
2635     DEBUG_c({
2636         STORE_NUMERIC_LOCAL_SET_STANDARD();
2637         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2638                       PTR2UV(sv), SvNVX(sv));
2639         RESTORE_NUMERIC_LOCAL();
2640     });
2641 #else
2642     DEBUG_c({
2643         STORE_NUMERIC_LOCAL_SET_STANDARD();
2644         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2645                       PTR2UV(sv), SvNVX(sv));
2646         RESTORE_NUMERIC_LOCAL();
2647     });
2648 #endif
2649     return SvNVX(sv);
2650 }
2651
2652 /*
2653 =for apidoc sv_2num
2654
2655 Return an SV with the numeric value of the source SV, doing any necessary
2656 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2657 access this function.
2658
2659 =cut
2660 */
2661
2662 SV *
2663 Perl_sv_2num(pTHX_ register SV *const sv)
2664 {
2665     PERL_ARGS_ASSERT_SV_2NUM;
2666
2667     if (!SvROK(sv))
2668         return sv;
2669     if (SvAMAGIC(sv)) {
2670         SV * const tmpsv = AMG_CALLun(sv,numer);
2671         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2672             return sv_2num(tmpsv);
2673     }
2674     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2675 }
2676
2677 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2678  * UV as a string towards the end of buf, and return pointers to start and
2679  * end of it.
2680  *
2681  * We assume that buf is at least TYPE_CHARS(UV) long.
2682  */
2683
2684 static char *
2685 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2686 {
2687     char *ptr = buf + TYPE_CHARS(UV);
2688     char * const ebuf = ptr;
2689     int sign;
2690
2691     PERL_ARGS_ASSERT_UIV_2BUF;
2692
2693     if (is_uv)
2694         sign = 0;
2695     else if (iv >= 0) {
2696         uv = iv;
2697         sign = 0;
2698     } else {
2699         uv = -iv;
2700         sign = 1;
2701     }
2702     do {
2703         *--ptr = '0' + (char)(uv % 10);
2704     } while (uv /= 10);
2705     if (sign)
2706         *--ptr = '-';
2707     *peob = ebuf;
2708     return ptr;
2709 }
2710
2711 /*
2712 =for apidoc sv_2pv_flags
2713
2714 Returns a pointer to the string value of an SV, and sets *lp to its length.
2715 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2716 if necessary.
2717 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2718 usually end up here too.
2719
2720 =cut
2721 */
2722
2723 char *
2724 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2725 {
2726     dVAR;
2727     register char *s;
2728
2729     if (!sv) {
2730         if (lp)
2731             *lp = 0;
2732         return (char *)"";
2733     }
2734     if (SvGMAGICAL(sv)) {
2735         if (flags & SV_GMAGIC)
2736             mg_get(sv);
2737         if (SvPOKp(sv)) {
2738             if (lp)
2739                 *lp = SvCUR(sv);
2740             if (flags & SV_MUTABLE_RETURN)
2741                 return SvPVX_mutable(sv);
2742             if (flags & SV_CONST_RETURN)
2743                 return (char *)SvPVX_const(sv);
2744             return SvPVX(sv);
2745         }
2746         if (SvIOKp(sv) || SvNOKp(sv)) {
2747             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2748             STRLEN len;
2749
2750             if (SvIOKp(sv)) {
2751                 len = SvIsUV(sv)
2752                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2753                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2754             } else {
2755                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2756                 len = strlen(tbuf);
2757             }
2758             assert(!SvROK(sv));
2759             {
2760                 dVAR;
2761
2762 #ifdef FIXNEGATIVEZERO
2763                 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2764                     tbuf[0] = '0';
2765                     tbuf[1] = 0;
2766                     len = 1;
2767                 }
2768 #endif
2769                 SvUPGRADE(sv, SVt_PV);
2770                 if (lp)
2771                     *lp = len;
2772                 s = SvGROW_mutable(sv, len + 1);
2773                 SvCUR_set(sv, len);
2774                 SvPOKp_on(sv);
2775                 return (char*)memcpy(s, tbuf, len + 1);
2776             }
2777         }
2778         if (SvROK(sv)) {
2779             goto return_rok;
2780         }
2781         assert(SvTYPE(sv) >= SVt_PVMG);
2782         /* This falls through to the report_uninit near the end of the
2783            function. */
2784     } else if (SvTHINKFIRST(sv)) {
2785         if (SvROK(sv)) {
2786         return_rok:
2787             if (SvAMAGIC(sv)) {
2788                 SV *const tmpstr = AMG_CALLun(sv,string);
2789                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2790                     /* Unwrap this:  */
2791                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2792                      */
2793
2794                     char *pv;
2795                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2796                         if (flags & SV_CONST_RETURN) {
2797                             pv = (char *) SvPVX_const(tmpstr);
2798                         } else {
2799                             pv = (flags & SV_MUTABLE_RETURN)
2800                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2801                         }
2802                         if (lp)
2803                             *lp = SvCUR(tmpstr);
2804                     } else {
2805                         pv = sv_2pv_flags(tmpstr, lp, flags);
2806                     }
2807                     if (SvUTF8(tmpstr))
2808                         SvUTF8_on(sv);
2809                     else
2810                         SvUTF8_off(sv);
2811                     return pv;
2812                 }
2813             }
2814             {
2815                 STRLEN len;
2816                 char *retval;
2817                 char *buffer;
2818                 SV *const referent = SvRV(sv);
2819
2820                 if (!referent) {
2821                     len = 7;
2822                     retval = buffer = savepvn("NULLREF", len);
2823                 } else if (SvTYPE(referent) == SVt_REGEXP) {
2824                     REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2825                     I32 seen_evals = 0;
2826
2827                     assert(re);
2828
2829                     /* If the regex is UTF-8 we want the containing scalar to
2830                        have an UTF-8 flag too */
2831                     if (RX_UTF8(re))
2832                         SvUTF8_on(sv);
2833                     else
2834                         SvUTF8_off(sv);
2835
2836                     if ((seen_evals = RX_SEEN_EVALS(re)))
2837                         PL_reginterp_cnt += seen_evals;
2838
2839                     if (lp)
2840                         *lp = RX_WRAPLEN(re);
2841
2842                     return RX_WRAPPED(re);
2843                 } else {
2844                     const char *const typestr = sv_reftype(referent, 0);
2845                     const STRLEN typelen = strlen(typestr);
2846                     UV addr = PTR2UV(referent);
2847                     const char *stashname = NULL;
2848                     STRLEN stashnamelen = 0; /* hush, gcc */
2849                     const char *buffer_end;
2850
2851                     if (SvOBJECT(referent)) {
2852                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2853
2854                         if (name) {
2855                             stashname = HEK_KEY(name);
2856                             stashnamelen = HEK_LEN(name);
2857
2858                             if (HEK_UTF8(name)) {
2859                                 SvUTF8_on(sv);
2860                             } else {
2861                                 SvUTF8_off(sv);
2862                             }
2863                         } else {
2864                             stashname = "__ANON__";
2865                             stashnamelen = 8;
2866                         }
2867                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2868                             + 2 * sizeof(UV) + 2 /* )\0 */;
2869                     } else {
2870                         len = typelen + 3 /* (0x */
2871                             + 2 * sizeof(UV) + 2 /* )\0 */;
2872                     }
2873
2874                     Newx(buffer, len, char);
2875                     buffer_end = retval = buffer + len;
2876
2877                     /* Working backwards  */
2878                     *--retval = '\0';
2879                     *--retval = ')';
2880                     do {
2881                         *--retval = PL_hexdigit[addr & 15];
2882                     } while (addr >>= 4);
2883                     *--retval = 'x';
2884                     *--retval = '0';
2885                     *--retval = '(';
2886
2887                     retval -= typelen;
2888                     memcpy(retval, typestr, typelen);
2889
2890                     if (stashname) {
2891                         *--retval = '=';
2892                         retval -= stashnamelen;
2893                         memcpy(retval, stashname, stashnamelen);
2894                     }
2895                     /* retval may not neccesarily have reached the start of the
2896                        buffer here.  */
2897                     assert (retval >= buffer);
2898
2899                     len = buffer_end - retval - 1; /* -1 for that \0  */
2900                 }
2901                 if (lp)
2902                     *lp = len;
2903                 SAVEFREEPV(buffer);
2904                 return retval;
2905             }
2906         }
2907         if (SvREADONLY(sv) && !SvOK(sv)) {
2908             if (lp)
2909                 *lp = 0;
2910             if (flags & SV_UNDEF_RETURNS_NULL)
2911                 return NULL;
2912             if (ckWARN(WARN_UNINITIALIZED))
2913                 report_uninit(sv);
2914             return (char *)"";
2915         }
2916     }
2917     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2918         /* I'm assuming that if both IV and NV are equally valid then
2919            converting the IV is going to be more efficient */
2920         const U32 isUIOK = SvIsUV(sv);
2921         char buf[TYPE_CHARS(UV)];
2922         char *ebuf, *ptr;
2923         STRLEN len;
2924
2925         if (SvTYPE(sv) < SVt_PVIV)
2926             sv_upgrade(sv, SVt_PVIV);
2927         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2928         len = ebuf - ptr;
2929         /* inlined from sv_setpvn */
2930         s = SvGROW_mutable(sv, len + 1);
2931         Move(ptr, s, len, char);
2932         s += len;
2933         *s = '\0';
2934     }
2935     else if (SvNOKp(sv)) {
2936         dSAVE_ERRNO;
2937         if (SvTYPE(sv) < SVt_PVNV)
2938             sv_upgrade(sv, SVt_PVNV);
2939         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2940         s = SvGROW_mutable(sv, NV_DIG + 20);
2941         /* some Xenix systems wipe out errno here */
2942 #ifdef apollo
2943         if (SvNVX(sv) == 0.0)
2944             my_strlcpy(s, "0", SvLEN(sv));
2945         else
2946 #endif /*apollo*/
2947         {
2948             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2949         }
2950         RESTORE_ERRNO;
2951 #ifdef FIXNEGATIVEZERO
2952         if (*s == '-' && s[1] == '0' && !s[2]) {
2953             s[0] = '0';
2954             s[1] = 0;
2955         }
2956 #endif
2957         while (*s) s++;
2958 #ifdef hcx
2959         if (s[-1] == '.')
2960             *--s = '\0';
2961 #endif
2962     }
2963     else {
2964         if (isGV_with_GP(sv)) {
2965             GV *const gv = MUTABLE_GV(sv);
2966             const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2967             SV *const buffer = sv_newmortal();
2968
2969             /* FAKE globs can get coerced, so need to turn this off temporarily
2970                if it is on.  */
2971             SvFAKE_off(gv);
2972             gv_efullname3(buffer, gv, "*");
2973             SvFLAGS(gv) |= wasfake;
2974
2975             if (SvPOK(buffer)) {
2976                 if (lp) {
2977                     *lp = SvCUR(buffer);
2978                 }
2979                 return SvPVX(buffer);
2980             }
2981             else {
2982                 if (lp)
2983                     *lp = 0;
2984                 return (char *)"";
2985             }
2986         }
2987
2988         if (lp)
2989             *lp = 0;
2990         if (flags & SV_UNDEF_RETURNS_NULL)
2991             return NULL;
2992         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2993             report_uninit(sv);
2994         if (SvTYPE(sv) < SVt_PV)
2995             /* Typically the caller expects that sv_any is not NULL now.  */
2996             sv_upgrade(sv, SVt_PV);
2997         return (char *)"";
2998     }
2999     {
3000         const STRLEN len = s - SvPVX_const(sv);
3001         if (lp)
3002             *lp = len;
3003         SvCUR_set(sv, len);
3004     }
3005     SvPOK_on(sv);
3006     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3007                           PTR2UV(sv),SvPVX_const(sv)));
3008     if (flags & SV_CONST_RETURN)
3009         return (char *)SvPVX_const(sv);
3010     if (flags & SV_MUTABLE_RETURN)
3011         return SvPVX_mutable(sv);
3012     return SvPVX(sv);
3013 }
3014
3015 /*
3016 =for apidoc sv_copypv
3017
3018 Copies a stringified representation of the source SV into the
3019 destination SV.  Automatically performs any necessary mg_get and
3020 coercion of numeric values into strings.  Guaranteed to preserve
3021 UTF8 flag even from overloaded objects.  Similar in nature to
3022 sv_2pv[_flags] but operates directly on an SV instead of just the
3023 string.  Mostly uses sv_2pv_flags to do its work, except when that
3024 would lose the UTF-8'ness of the PV.
3025
3026 =cut
3027 */
3028
3029 void
3030 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3031 {
3032     STRLEN len;
3033     const char * const s = SvPV_const(ssv,len);
3034
3035     PERL_ARGS_ASSERT_SV_COPYPV;
3036
3037     sv_setpvn(dsv,s,len);
3038     if (SvUTF8(ssv))
3039         SvUTF8_on(dsv);
3040     else
3041         SvUTF8_off(dsv);
3042 }
3043
3044 /*
3045 =for apidoc sv_2pvbyte
3046
3047 Return a pointer to the byte-encoded representation of the SV, and set *lp
3048 to its length.  May cause the SV to be downgraded from UTF-8 as a
3049 side-effect.
3050
3051 Usually accessed via the C<SvPVbyte> macro.
3052
3053 =cut
3054 */
3055
3056 char *
3057 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3058 {
3059     PERL_ARGS_ASSERT_SV_2PVBYTE;
3060
3061     sv_utf8_downgrade(sv,0);
3062     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3063 }
3064
3065 /*
3066 =for apidoc sv_2pvutf8
3067
3068 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3069 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3070
3071 Usually accessed via the C<SvPVutf8> macro.
3072
3073 =cut
3074 */
3075
3076 char *
3077 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3078 {
3079     PERL_ARGS_ASSERT_SV_2PVUTF8;
3080
3081     sv_utf8_upgrade(sv);
3082     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3083 }
3084
3085
3086 /*
3087 =for apidoc sv_2bool
3088
3089 This function is only called on magical items, and is only used by
3090 sv_true() or its macro equivalent.
3091
3092 =cut
3093 */
3094
3095 bool
3096 Perl_sv_2bool(pTHX_ register SV *const sv)
3097 {
3098     dVAR;
3099
3100     PERL_ARGS_ASSERT_SV_2BOOL;
3101
3102     SvGETMAGIC(sv);
3103
3104     if (!SvOK(sv))
3105         return 0;
3106     if (SvROK(sv)) {
3107         if (SvAMAGIC(sv)) {
3108             SV * const tmpsv = AMG_CALLun(sv,bool_);
3109             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3110                 return cBOOL(SvTRUE(tmpsv));
3111         }
3112         return SvRV(sv) != 0;
3113     }
3114     if (SvPOKp(sv)) {
3115         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3116         if (Xpvtmp &&
3117                 (*sv->sv_u.svu_pv > '0' ||
3118                 Xpvtmp->xpv_cur > 1 ||
3119                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3120             return 1;
3121         else
3122             return 0;
3123     }
3124     else {
3125         if (SvIOKp(sv))
3126             return SvIVX(sv) != 0;
3127         else {
3128             if (SvNOKp(sv))
3129                 return SvNVX(sv) != 0.0;
3130             else {
3131                 if (isGV_with_GP(sv))
3132                     return TRUE;
3133                 else
3134                     return FALSE;
3135             }
3136         }
3137     }
3138 }
3139
3140 /*
3141 =for apidoc sv_utf8_upgrade
3142
3143 Converts the PV of an SV to its UTF-8-encoded form.
3144 Forces the SV to string form if it is not already.
3145 Will C<mg_get> on C<sv> if appropriate.
3146 Always sets the SvUTF8 flag to avoid future validity checks even
3147 if the whole string is the same in UTF-8 as not.
3148 Returns the number of bytes in the converted string
3149
3150 This is not as a general purpose byte encoding to Unicode interface:
3151 use the Encode extension for that.
3152
3153 =for apidoc sv_utf8_upgrade_nomg
3154
3155 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3156
3157 =for apidoc sv_utf8_upgrade_flags
3158
3159 Converts the PV of an SV to its UTF-8-encoded form.
3160 Forces the SV to string form if it is not already.
3161 Always sets the SvUTF8 flag to avoid future validity checks even
3162 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3163 will C<mg_get> on C<sv> if appropriate, else not.
3164 Returns the number of bytes in the converted string
3165 C<sv_utf8_upgrade> and
3166 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3167
3168 This is not as a general purpose byte encoding to Unicode interface:
3169 use the Encode extension for that.
3170
3171 =cut
3172
3173 The grow version is currently not externally documented.  It adds a parameter,
3174 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3175 have free after it upon return.  This allows the caller to reserve extra space
3176 that it intends to fill, to avoid extra grows.
3177
3178 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3179 which can be used to tell this function to not first check to see if there are
3180 any characters that are different in UTF-8 (variant characters) which would
3181 force it to allocate a new string to sv, but to assume there are.  Typically
3182 this flag is used by a routine that has already parsed the string to find that
3183 there are such characters, and passes this information on so that the work
3184 doesn't have to be repeated.
3185
3186 (One might think that the calling routine could pass in the position of the
3187 first such variant, so it wouldn't have to be found again.  But that is not the
3188 case, because typically when the caller is likely to use this flag, it won't be
3189 calling this routine unless it finds something that won't fit into a byte.
3190 Otherwise it tries to not upgrade and just use bytes.  But some things that
3191 do fit into a byte are variants in utf8, and the caller may not have been
3192 keeping track of these.)
3193
3194 If the routine itself changes the string, it adds a trailing NUL.  Such a NUL
3195 isn't guaranteed due to having other routines do the work in some input cases,
3196 or if the input is already flagged as being in utf8.
3197
3198 The speed of this could perhaps be improved for many cases if someone wanted to
3199 write a fast function that counts the number of variant characters in a string,
3200 especially if it could return the position of the first one.
3201
3202 */
3203
3204 STRLEN
3205 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3206 {
3207     dVAR;
3208
3209     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3210
3211     if (sv == &PL_sv_undef)
3212         return 0;
3213     if (!SvPOK(sv)) {
3214         STRLEN len = 0;
3215         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3216             (void) sv_2pv_flags(sv,&len, flags);
3217             if (SvUTF8(sv)) {
3218                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3219                 return len;
3220             }
3221         } else {
3222             (void) SvPV_force(sv,len);
3223         }
3224     }
3225
3226     if (SvUTF8(sv)) {
3227         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3228         return SvCUR(sv);
3229     }
3230
3231     if (SvIsCOW(sv)) {
3232         sv_force_normal_flags(sv, 0);
3233     }
3234
3235     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3236         sv_recode_to_utf8(sv, PL_encoding);
3237         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3238         return SvCUR(sv);
3239     }
3240
3241     if (SvCUR(sv) == 0) {
3242         if (extra) SvGROW(sv, extra);
3243     } else { /* Assume Latin-1/EBCDIC */
3244         /* This function could be much more efficient if we
3245          * had a FLAG in SVs to signal if there are any variant
3246          * chars in the PV.  Given that there isn't such a flag
3247          * make the loop as fast as possible (although there are certainly ways
3248          * to speed this up, eg. through vectorization) */
3249         U8 * s = (U8 *) SvPVX_const(sv);
3250         U8 * e = (U8 *) SvEND(sv);
3251         U8 *t = s;
3252         STRLEN two_byte_count = 0;
3253
3254         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3255
3256         /* See if really will need to convert to utf8.  We mustn't rely on our
3257          * incoming SV being well formed and having a trailing '\0', as certain
3258          * code in pp_formline can send us partially built SVs. */
3259
3260         while (t < e) {
3261             const U8 ch = *t++;
3262             if (NATIVE_IS_INVARIANT(ch)) continue;
3263
3264             t--;    /* t already incremented; re-point to first variant */
3265             two_byte_count = 1;
3266             goto must_be_utf8;
3267         }
3268
3269         /* utf8 conversion not needed because all are invariants.  Mark as
3270          * UTF-8 even if no variant - saves scanning loop */
3271         SvUTF8_on(sv);
3272         return SvCUR(sv);
3273
3274 must_be_utf8:
3275
3276         /* Here, the string should be converted to utf8, either because of an
3277          * input flag (two_byte_count = 0), or because a character that
3278          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3279          * the beginning of the string (if we didn't examine anything), or to
3280          * the first variant.  In either case, everything from s to t - 1 will
3281          * occupy only 1 byte each on output.
3282          *
3283          * There are two main ways to convert.  One is to create a new string
3284          * and go through the input starting from the beginning, appending each
3285          * converted value onto the new string as we go along.  It's probably
3286          * best to allocate enough space in the string for the worst possible
3287          * case rather than possibly running out of space and having to
3288          * reallocate and then copy what we've done so far.  Since everything
3289          * from s to t - 1 is invariant, the destination can be initialized
3290          * with these using a fast memory copy
3291          *
3292          * The other way is to figure out exactly how big the string should be
3293          * by parsing the entire input.  Then you don't have to make it big
3294          * enough to handle the worst possible case, and more importantly, if
3295          * the string you already have is large enough, you don't have to
3296          * allocate a new string, you can copy the last character in the input
3297          * string to the final position(s) that will be occupied by the
3298          * converted string and go backwards, stopping at t, since everything
3299          * before that is invariant.
3300          *
3301          * There are advantages and disadvantages to each method.
3302          *
3303          * In the first method, we can allocate a new string, do the memory
3304          * copy from the s to t - 1, and then proceed through the rest of the
3305          * string byte-by-byte.
3306          *
3307          * In the second method, we proceed through the rest of the input
3308          * string just calculating how big the converted string will be.  Then
3309          * there are two cases:
3310          *  1)  if the string has enough extra space to handle the converted
3311          *      value.  We go backwards through the string, converting until we
3312          *      get to the position we are at now, and then stop.  If this
3313          *      position is far enough along in the string, this method is
3314          *      faster than the other method.  If the memory copy were the same
3315          *      speed as the byte-by-byte loop, that position would be about
3316          *      half-way, as at the half-way mark, parsing to the end and back
3317          *      is one complete string's parse, the same amount as starting
3318          *      over and going all the way through.  Actually, it would be
3319          *      somewhat less than half-way, as it's faster to just count bytes
3320          *      than to also copy, and we don't have the overhead of allocating
3321          *      a new string, changing the scalar to use it, and freeing the
3322          *      existing one.  But if the memory copy is fast, the break-even
3323          *      point is somewhere after half way.  The counting loop could be
3324          *      sped up by vectorization, etc, to move the break-even point
3325          *      further towards the beginning.
3326          *  2)  if the string doesn't have enough space to handle the converted
3327          *      value.  A new string will have to be allocated, and one might
3328          *      as well, given that, start from the beginning doing the first
3329          *      method.  We've spent extra time parsing the string and in
3330          *      exchange all we've gotten is that we know precisely how big to
3331          *      make the new one.  Perl is more optimized for time than space,
3332          *      so this case is a loser.
3333          * So what I've decided to do is not use the 2nd method unless it is
3334          * guaranteed that a new string won't have to be allocated, assuming
3335          * the worst case.  I also decided not to put any more conditions on it
3336          * than this, for now.  It seems likely that, since the worst case is
3337          * twice as big as the unknown portion of the string (plus 1), we won't
3338          * be guaranteed enough space, causing us to go to the first method,
3339          * unless the string is short, or the first variant character is near
3340          * the end of it.  In either of these cases, it seems best to use the
3341          * 2nd method.  The only circumstance I can think of where this would
3342          * be really slower is if the string had once had much more data in it
3343          * than it does now, but there is still a substantial amount in it  */
3344
3345         {
3346             STRLEN invariant_head = t - s;
3347             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3348             if (SvLEN(sv) < size) {
3349
3350                 /* Here, have decided to allocate a new string */
3351
3352                 U8 *dst;
3353                 U8 *d;
3354
3355                 Newx(dst, size, U8);
3356
3357                 /* If no known invariants at the beginning of the input string,
3358                  * set so starts from there.  Otherwise, can use memory copy to
3359                  * get up to where we are now, and then start from here */
3360
3361                 if (invariant_head <= 0) {
3362                     d = dst;
3363                 } else {
3364                     Copy(s, dst, invariant_head, char);
3365                     d = dst + invariant_head;
3366                 }
3367
3368                 while (t < e) {
3369                     const UV uv = NATIVE8_TO_UNI(*t++);
3370                     if (UNI_IS_INVARIANT(uv))
3371                         *d++ = (U8)UNI_TO_NATIVE(uv);
3372                     else {
3373                         *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3374                         *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3375                     }
3376                 }
3377                 *d = '\0';
3378                 SvPV_free(sv); /* No longer using pre-existing string */
3379                 SvPV_set(sv, (char*)dst);
3380                 SvCUR_set(sv, d - dst);
3381                 SvLEN_set(sv, size);
3382             } else {
3383
3384                 /* Here, have decided to get the exact size of the string.
3385                  * Currently this happens only when we know that there is
3386                  * guaranteed enough space to fit the converted string, so
3387                  * don't have to worry about growing.  If two_byte_count is 0,
3388                  * then t points to the first byte of the string which hasn't
3389                  * been examined yet.  Otherwise two_byte_count is 1, and t
3390                  * points to the first byte in the string that will expand to
3391                  * two.  Depending on this, start examining at t or 1 after t.
3392                  * */
3393
3394                 U8 *d = t + two_byte_count;
3395
3396
3397                 /* Count up the remaining bytes that expand to two */
3398
3399                 while (d < e) {
3400                     const U8 chr = *d++;
3401                     if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3402                 }
3403
3404                 /* The string will expand by just the number of bytes that
3405                  * occupy two positions.  But we are one afterwards because of
3406                  * the increment just above.  This is the place to put the
3407                  * trailing NUL, and to set the length before we decrement */
3408
3409                 d += two_byte_count;
3410                 SvCUR_set(sv, d - s);
3411                 *d-- = '\0';
3412
3413
3414                 /* Having decremented d, it points to the position to put the
3415                  * very last byte of the expanded string.  Go backwards through
3416                  * the string, copying and expanding as we go, stopping when we
3417                  * get to the part that is invariant the rest of the way down */
3418
3419                 e--;
3420                 while (e >= t) {
3421                     const U8 ch = NATIVE8_TO_UNI(*e--);
3422                     if (UNI_IS_INVARIANT(ch)) {
3423                         *d-- = UNI_TO_NATIVE(ch);
3424                     } else {
3425                         *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3426                         *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3427                     }
3428                 }
3429             }
3430         }
3431     }
3432
3433     /* Mark as UTF-8 even if no variant - saves scanning loop */
3434     SvUTF8_on(sv);
3435     return SvCUR(sv);
3436 }
3437
3438 /*
3439 =for apidoc sv_utf8_downgrade
3440
3441 Attempts to convert the PV of an SV from characters to bytes.
3442 If the PV contains a character that cannot fit
3443 in a byte, this conversion will fail;
3444 in this case, either returns false or, if C<fail_ok> is not
3445 true, croaks.
3446
3447 This is not as a general purpose Unicode to byte encoding interface:
3448 use the Encode extension for that.
3449
3450 =cut
3451 */
3452
3453 bool
3454 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3455 {
3456     dVAR;
3457
3458     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3459
3460     if (SvPOKp(sv) && SvUTF8(sv)) {
3461         if (SvCUR(sv)) {
3462             U8 *s;
3463             STRLEN len;
3464
3465             if (SvIsCOW(sv)) {
3466                 sv_force_normal_flags(sv, 0);
3467             }
3468             s = (U8 *) SvPV(sv, len);
3469             if (!utf8_to_bytes(s, &len)) {
3470                 if (fail_ok)
3471                     return FALSE;
3472                 else {
3473                     if (PL_op)
3474                         Perl_croak(aTHX_ "Wide character in %s",
3475                                    OP_DESC(PL_op));
3476                     else
3477                         Perl_croak(aTHX_ "Wide character");
3478                 }
3479             }
3480             SvCUR_set(sv, len);
3481         }
3482     }
3483     SvUTF8_off(sv);
3484     return TRUE;
3485 }
3486
3487 /*
3488 =for apidoc sv_utf8_encode
3489
3490 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3491 flag off so that it looks like octets again.
3492
3493 =cut
3494 */
3495
3496 void
3497 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3498 {
3499     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3500
3501     if (SvIsCOW(sv)) {
3502         sv_force_normal_flags(sv, 0);
3503     }
3504     if (SvREADONLY(sv)) {
3505         Perl_croak(aTHX_ "%s", PL_no_modify);
3506     }
3507     (void) sv_utf8_upgrade(sv);
3508     SvUTF8_off(sv);
3509 }
3510
3511 /*
3512 =for apidoc sv_utf8_decode
3513
3514 If the PV of the SV is an octet sequence in UTF-8
3515 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3516 so that it looks like a character. If the PV contains only single-byte
3517 characters, the C<SvUTF8> flag stays being off.
3518 Scans PV for validity and returns false if the PV is invalid UTF-8.
3519
3520 =cut
3521 */
3522
3523 bool
3524 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3525 {
3526     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3527
3528     if (SvPOKp(sv)) {
3529         const U8 *c;
3530         const U8 *e;
3531
3532         /* The octets may have got themselves encoded - get them back as
3533          * bytes
3534          */
3535         if (!sv_utf8_downgrade(sv, TRUE))
3536             return FALSE;
3537
3538         /* it is actually just a matter of turning the utf8 flag on, but
3539          * we want to make sure everything inside is valid utf8 first.
3540          */
3541         c = (const U8 *) SvPVX_const(sv);
3542         if (!is_utf8_string(c, SvCUR(sv)+1))
3543             return FALSE;
3544         e = (const U8 *) SvEND(sv);
3545         while (c < e) {
3546             const U8 ch = *c++;
3547             if (!UTF8_IS_INVARIANT(ch)) {
3548                 SvUTF8_on(sv);
3549                 break;
3550             }
3551         }
3552     }
3553     return TRUE;
3554 }
3555
3556 /*
3557 =for apidoc sv_setsv
3558
3559 Copies the contents of the source SV C<ssv> into the destination SV
3560 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3561 function if the source SV needs to be reused. Does not handle 'set' magic.
3562 Loosely speaking, it performs a copy-by-value, obliterating any previous
3563 content of the destination.
3564
3565 You probably want to use one of the assortment of wrappers, such as
3566 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3567 C<SvSetMagicSV_nosteal>.
3568
3569 =for apidoc sv_setsv_flags
3570
3571 Copies the contents of the source SV C<ssv> into the destination SV
3572 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3573 function if the source SV needs to be reused. Does not handle 'set' magic.
3574 Loosely speaking, it performs a copy-by-value, obliterating any previous
3575 content of the destination.
3576 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3577 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3578 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3579 and C<sv_setsv_nomg> are implemented in terms of this function.
3580
3581 You probably want to use one of the assortment of wrappers, such as
3582 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3583 C<SvSetMagicSV_nosteal>.
3584
3585 This is the primary function for copying scalars, and most other
3586 copy-ish functions and macros use this underneath.
3587
3588 =cut
3589 */
3590
3591 static void
3592 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3593 {
3594     I32 mro_changes = 0; /* 1 = method, 2 = isa */
3595
3596     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3597
3598     if (dtype != SVt_PVGV) {
3599         const char * const name = GvNAME(sstr);
3600         const STRLEN len = GvNAMELEN(sstr);
3601         {
3602             if (dtype >= SVt_PV) {
3603                 SvPV_free(dstr);
3604                 SvPV_set(dstr, 0);
3605                 SvLEN_set(dstr, 0);
3606                 SvCUR_set(dstr, 0);
3607             }
3608             SvUPGRADE(dstr, SVt_PVGV);
3609             (void)SvOK_off(dstr);
3610             /* FIXME - why are we doing this, then turning it off and on again
3611                below?  */
3612             isGV_with_GP_on(dstr);
3613         }
3614         GvSTASH(dstr) = GvSTASH(sstr);
3615         if (GvSTASH(dstr))
3616             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3617         gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3618         SvFAKE_on(dstr);        /* can coerce to non-glob */
3619     }
3620
3621     if(GvGP(MUTABLE_GV(sstr))) {
3622         /* If source has method cache entry, clear it */
3623         if(GvCVGEN(sstr)) {
3624             SvREFCNT_dec(GvCV(sstr));
3625             GvCV(sstr) = NULL;
3626             GvCVGEN(sstr) = 0;
3627         }
3628         /* If source has a real method, then a method is
3629            going to change */
3630         else if(GvCV((const GV *)sstr)) {
3631             mro_changes = 1;
3632         }
3633     }
3634
3635     /* If dest already had a real method, that's a change as well */
3636     if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3637         mro_changes = 1;
3638     }
3639
3640     if(strEQ(GvNAME((const GV *)dstr),"ISA"))
3641         mro_changes = 2;
3642
3643     gp_free(MUTABLE_GV(dstr));
3644     isGV_with_GP_off(dstr);
3645     (void)SvOK_off(dstr);
3646     isGV_with_GP_on(dstr);
3647     GvINTRO_off(dstr);          /* one-shot flag */
3648     GvGP(dstr) = gp_ref(GvGP(sstr));
3649     if (SvTAINTED(sstr))
3650         SvTAINT(dstr);
3651     if (GvIMPORTED(dstr) != GVf_IMPORTED
3652         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3653         {
3654             GvIMPORTED_on(dstr);
3655         }
3656     GvMULTI_on(dstr);
3657     if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3658     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3659     return;
3660 }
3661
3662 static void
3663 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3664 {
3665     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3666     SV *dref = NULL;
3667     const int intro = GvINTRO(dstr);
3668     SV **location;
3669     U8 import_flag = 0;
3670     const U32 stype = SvTYPE(sref);
3671
3672     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3673
3674     if (intro) {
3675         GvINTRO_off(dstr);      /* one-shot flag */
3676         GvLINE(dstr) = CopLINE(PL_curcop);
3677         GvEGV(dstr) = MUTABLE_GV(dstr);
3678     }
3679     GvMULTI_on(dstr);
3680     switch (stype) {
3681     case SVt_PVCV:
3682         location = (SV **) &GvCV(dstr);
3683         import_flag = GVf_IMPORTED_CV;
3684         goto common;
3685     case SVt_PVHV:
3686         location = (SV **) &GvHV(dstr);
3687         import_flag = GVf_IMPORTED_HV;
3688         goto common;
3689     case SVt_PVAV:
3690         location = (SV **) &GvAV(dstr);
3691         import_flag = GVf_IMPORTED_AV;
3692         goto common;
3693     case SVt_PVIO:
3694         location = (SV **) &GvIOp(dstr);
3695         goto common;
3696     case SVt_PVFM:
3697         location = (SV **) &GvFORM(dstr);
3698         goto common;
3699     default:
3700         location = &GvSV(dstr);
3701         import_flag = GVf_IMPORTED_SV;
3702     common:
3703         if (intro) {
3704             if (stype == SVt_PVCV) {
3705                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3706                 if (GvCVGEN(dstr)) {
3707                     SvREFCNT_dec(GvCV(dstr));
3708                     GvCV(dstr) = NULL;
3709                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3710                 }
3711             }
3712             SAVEGENERICSV(*location);
3713         }
3714         else
3715             dref = *location;
3716         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3717             CV* const cv = MUTABLE_CV(*location);
3718             if (cv) {
3719                 if (!GvCVGEN((const GV *)dstr) &&
3720                     (CvROOT(cv) || CvXSUB(cv)))
3721                     {
3722                         /* Redefining a sub - warning is mandatory if
3723                            it was a const and its value changed. */
3724                         if (CvCONST(cv) && CvCONST((const CV *)sref)
3725                             && cv_const_sv(cv)
3726                             == cv_const_sv((const CV *)sref)) {
3727                             NOOP;
3728                             /* They are 2 constant subroutines generated from
3729                                the same constant. This probably means that
3730                                they are really the "same" proxy subroutine
3731                                instantiated in 2 places. Most likely this is
3732                                when a constant is exported twice.  Don't warn.
3733                             */
3734                         }
3735                         else if (ckWARN(WARN_REDEFINE)
3736                                  || (CvCONST(cv)
3737                                      && (!CvCONST((const CV *)sref)
3738                                          || sv_cmp(cv_const_sv(cv),
3739                                                    cv_const_sv((const CV *)
3740                                                                sref))))) {
3741                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3742                                         (const char *)
3743                                         (CvCONST(cv)
3744                                          ? "Constant subroutine %s::%s redefined"
3745                                          : "Subroutine %s::%s redefined"),
3746                                         HvNAME_get(GvSTASH((const GV *)dstr)),
3747                                         GvENAME(MUTABLE_GV(dstr)));
3748                         }
3749                     }
3750                 if (!intro)
3751                     cv_ckproto_len(cv, (const GV *)dstr,
3752                                    SvPOK(sref) ? SvPVX_const(sref) : NULL,
3753                                    SvPOK(sref) ? SvCUR(sref) : 0);
3754             }
3755             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3756             GvASSUMECV_on(dstr);
3757             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3758         }
3759         *location = sref;
3760         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3761             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3762             GvFLAGS(dstr) |= import_flag;
3763         }
3764         if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
3765             sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3766             mro_isa_changed_in(GvSTASH(dstr));
3767         }
3768         break;
3769     }
3770     SvREFCNT_dec(dref);
3771     if (SvTAINTED(sstr))
3772         SvTAINT(dstr);
3773     return;
3774 }
3775
3776 void
3777 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3778 {
3779     dVAR;
3780     register U32 sflags;
3781     register int dtype;
3782     register svtype stype;
3783
3784     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3785
3786     if (sstr == dstr)
3787         return;
3788
3789     if (SvIS_FREED(dstr)) {
3790         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3791                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3792     }
3793     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3794     if (!sstr)
3795         sstr = &PL_sv_undef;
3796     if (SvIS_FREED(sstr)) {
3797         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3798                    (void*)sstr, (void*)dstr);
3799     }
3800     stype = SvTYPE(sstr);
3801     dtype = SvTYPE(dstr);
3802
3803     (void)SvAMAGIC_off(dstr);
3804     if ( SvVOK(dstr) )
3805     {
3806         /* need to nuke the magic */
3807         mg_free(dstr);
3808     }
3809
3810     /* There's a lot of redundancy below but we're going for speed here */
3811
3812     switch (stype) {
3813     case SVt_NULL:
3814       undef_sstr:
3815         if (dtype != SVt_PVGV) {
3816             (void)SvOK_off(dstr);
3817             return;
3818         }
3819         break;
3820     case SVt_IV:
3821         if (SvIOK(sstr)) {
3822             switch (dtype) {
3823             case SVt_NULL:
3824                 sv_upgrade(dstr, SVt_IV);
3825                 break;
3826             case SVt_NV:
3827             case SVt_PV:
3828                 sv_upgrade(dstr, SVt_PVIV);
3829                 break;
3830             case SVt_PVGV:
3831                 goto end_of_first_switch;
3832             }
3833             (void)SvIOK_only(dstr);
3834             SvIV_set(dstr,  SvIVX(sstr));
3835             if (SvIsUV(sstr))
3836                 SvIsUV_on(dstr);
3837             /* SvTAINTED can only be true if the SV has taint magic, which in
3838                turn means that the SV type is PVMG (or greater). This is the
3839                case statement for SVt_IV, so this cannot be true (whatever gcov
3840                may say).  */
3841             assert(!SvTAINTED(sstr));
3842             return;
3843         }
3844         if (!SvROK(sstr))
3845             goto undef_sstr;
3846         if (dtype < SVt_PV && dtype != SVt_IV)
3847             sv_upgrade(dstr, SVt_IV);
3848         break;
3849
3850     case SVt_NV:
3851         if (SvNOK(sstr)) {
3852             switch (dtype) {
3853             case SVt_NULL:
3854             case SVt_IV:
3855                 sv_upgrade(dstr, SVt_NV);
3856                 break;
3857             case SVt_PV:
3858             case SVt_PVIV:
3859                 sv_upgrade(dstr, SVt_PVNV);
3860                 break;
3861             case SVt_PVGV:
3862                 goto end_of_first_switch;
3863             }
3864             SvNV_set(dstr, SvNVX(sstr));
3865             (void)SvNOK_only(dstr);
3866             /* SvTAINTED can only be true if the SV has taint magic, which in
3867                turn means that the SV type is PVMG (or greater). This is the
3868                case statement for SVt_NV, so this cannot be true (whatever gcov
3869                may say).  */
3870             assert(!SvTAINTED(sstr));
3871             return;
3872         }
3873         goto undef_sstr;
3874
3875     case SVt_PVFM:
3876 #ifdef PERL_OLD_COPY_ON_WRITE
3877         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3878             if (dtype < SVt_PVIV)
3879                 sv_upgrade(dstr, SVt_PVIV);
3880             break;
3881         }
3882         /* Fall through */
3883 #endif
3884     case SVt_PV:
3885         if (dtype < SVt_PV)
3886             sv_upgrade(dstr, SVt_PV);
3887         break;
3888     case SVt_PVIV:
3889         if (dtype < SVt_PVIV)
3890             sv_upgrade(dstr, SVt_PVIV);
3891         break;
3892     case SVt_PVNV:
3893         if (dtype < SVt_PVNV)
3894             sv_upgrade(dstr, SVt_PVNV);
3895         break;
3896     default:
3897         {
3898         const char * const type = sv_reftype(sstr,0);
3899         if (PL_op)
3900             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
3901         else
3902             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3903         }
3904         break;
3905
3906     case SVt_REGEXP:
3907         if (dtype < SVt_REGEXP)
3908             sv_upgrade(dstr, SVt_REGEXP);
3909         break;
3910
3911         /* case SVt_BIND: */
3912     case SVt_PVLV:
3913     case SVt_PVGV:
3914         if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3915             glob_assign_glob(dstr, sstr, dtype);
3916             return;
3917         }
3918         /* SvVALID means that this PVGV is playing at being an FBM.  */
3919         /*FALLTHROUGH*/
3920
3921     case SVt_PVMG:
3922         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3923             mg_get(sstr);
3924             if (SvTYPE(sstr) != stype) {
3925                 stype = SvTYPE(sstr);
3926                 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3927                     glob_assign_glob(dstr, sstr, dtype);
3928                     return;
3929                 }
3930             }
3931         }
3932         if (stype == SVt_PVLV)
3933             SvUPGRADE(dstr, SVt_PVNV);
3934         else
3935             SvUPGRADE(dstr, (svtype)stype);
3936     }
3937  end_of_first_switch:
3938
3939     /* dstr may have been upgraded.  */
3940     dtype = SvTYPE(dstr);
3941     sflags = SvFLAGS(sstr);
3942
3943     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3944         /* Assigning to a subroutine sets the prototype.  */
3945         if (SvOK(sstr)) {
3946             STRLEN len;
3947             const char *const ptr = SvPV_const(sstr, len);
3948
3949             SvGROW(dstr, len + 1);
3950             Copy(ptr, SvPVX(dstr), len + 1, char);
3951             SvCUR_set(dstr, len);
3952             SvPOK_only(dstr);
3953             SvFLAGS(dstr) |= sflags & SVf_UTF8;
3954         } else {
3955             SvOK_off(dstr);
3956         }
3957     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3958         const char * const type = sv_reftype(dstr,0);
3959         if (PL_op)
3960             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
3961         else
3962             Perl_croak(aTHX_ "Cannot copy to %s", type);
3963     } else if (sflags & SVf_ROK) {
3964         if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3965             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3966             sstr = SvRV(sstr);
3967             if (sstr == dstr) {
3968                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3969                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3970                 {
3971                     GvIMPORTED_on(dstr);
3972                 }
3973                 GvMULTI_on(dstr);
3974                 return;
3975             }
3976             glob_assign_glob(dstr, sstr, dtype);
3977             return;
3978         }
3979
3980         if (dtype >= SVt_PV) {
3981             if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3982                 glob_assign_ref(dstr, sstr);
3983                 return;
3984             }
3985             if (SvPVX_const(dstr)) {
3986                 SvPV_free(dstr);
3987                 SvLEN_set(dstr, 0);
3988                 SvCUR_set(dstr, 0);
3989             }
3990         }
3991         (void)SvOK_off(dstr);
3992         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3993         SvFLAGS(dstr) |= sflags & SVf_ROK;
3994         assert(!(sflags & SVp_NOK));
3995         assert(!(sflags & SVp_IOK));
3996         assert(!(sflags & SVf_NOK));
3997         assert(!(sflags & SVf_IOK));
3998     }
3999     else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
4000         if (!(sflags & SVf_OK)) {
4001             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4002                            "Undefined value assigned to typeglob");
4003         }
4004         else {
4005             GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4006             if (dstr != (const SV *)gv) {
4007                 if (GvGP(dstr))
4008                     gp_free(MUTABLE_GV(dstr));
4009                 GvGP(dstr) = gp_ref(GvGP(gv));
4010             }
4011         }
4012     }
4013     else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4014         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4015     }
4016     else if (sflags & SVp_POK) {
4017         bool isSwipe = 0;
4018
4019         /*
4020          * Check to see if we can just swipe the string.  If so, it's a
4021          * possible small lose on short strings, but a big win on long ones.
4022          * It might even be a win on short strings if SvPVX_const(dstr)
4023          * has to be allocated and SvPVX_const(sstr) has to be freed.
4024          * Likewise if we can set up COW rather than doing an actual copy, we
4025          * drop to the else clause, as the swipe code and the COW setup code
4026          * have much in common.
4027          */
4028
4029         /* Whichever path we take through the next code, we want this true,
4030            and doing it now facilitates the COW check.  */
4031         (void)SvPOK_only(dstr);
4032
4033         if (
4034             /* If we're already COW then this clause is not true, and if COW
4035                is allowed then we drop down to the else and make dest COW
4036                with us.  If caller hasn't said that we're allowed to COW
4037                shared hash keys then we don't do the COW setup, even if the
4038                source scalar is a shared hash key scalar.  */
4039             (((flags & SV_COW_SHARED_HASH_KEYS)
4040                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4041                : 1 /* If making a COW copy is forbidden then the behaviour we
4042                        desire is as if the source SV isn't actually already
4043                        COW, even if it is.  So we act as if the source flags
4044                        are not COW, rather than actually testing them.  */
4045               )
4046 #ifndef PERL_OLD_COPY_ON_WRITE
4047              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4048                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4049                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4050                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4051                 but in turn, it's somewhat dead code, never expected to go
4052                 live, but more kept as a placeholder on how to do it better
4053                 in a newer implementation.  */
4054              /* If we are COW and dstr is a suitable target then we drop down
4055                 into the else and make dest a COW of us.  */
4056              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4057 #endif
4058              )
4059             &&
4060             !(isSwipe =
4061                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4062                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4063                  (!(flags & SV_NOSTEAL)) &&
4064                                         /* and we're allowed to steal temps */
4065                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4066                  SvLEN(sstr)    &&        /* and really is a string */
4067                                 /* and won't be needed again, potentially */
4068               !(PL_op && PL_op->op_type == OP_AASSIGN))
4069 #ifdef PERL_OLD_COPY_ON_WRITE
4070             && ((flags & SV_COW_SHARED_HASH_KEYS)
4071                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4072                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4073                      && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4074                 : 1)
4075 #endif
4076             ) {
4077             /* Failed the swipe test, and it's not a shared hash key either.
4078                Have to copy the string.  */
4079             STRLEN len = SvCUR(sstr);
4080             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4081             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4082             SvCUR_set(dstr, len);
4083             *SvEND(dstr) = '\0';
4084         } else {
4085             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4086                be true in here.  */
4087             /* Either it's a shared hash key, or it's suitable for
4088                copy-on-write or we can swipe the string.  */
4089             if (DEBUG_C_TEST) {
4090                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4091                 sv_dump(sstr);
4092                 sv_dump(dstr);
4093             }
4094 #ifdef PERL_OLD_COPY_ON_WRITE
4095             if (!isSwipe) {
4096                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4097                     != (SVf_FAKE | SVf_READONLY)) {
4098                     SvREADONLY_on(sstr);
4099                     SvFAKE_on(sstr);
4100                     /* Make the source SV into a loop of 1.
4101                        (about to become 2) */
4102                     SV_COW_NEXT_SV_SET(sstr, sstr);
4103                 }
4104             }
4105 #endif
4106             /* Initial code is common.  */
4107             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4108                 SvPV_free(dstr);
4109             }
4110
4111             if (!isSwipe) {
4112                 /* making another shared SV.  */
4113                 STRLEN cur = SvCUR(sstr);
4114                 STRLEN len = SvLEN(sstr);
4115 #ifdef PERL_OLD_COPY_ON_WRITE
4116                 if (len) {
4117                     assert (SvTYPE(dstr) >= SVt_PVIV);
4118                     /* SvIsCOW_normal */
4119                     /* splice us in between source and next-after-source.  */
4120                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4121                     SV_COW_NEXT_SV_SET(sstr, dstr);
4122                     SvPV_set(dstr, SvPVX_mutable(sstr));
4123                 } else
4124 #endif
4125                 {
4126                     /* SvIsCOW_shared_hash */
4127                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4128                                           "Copy on write: Sharing hash\n"));
4129
4130                     assert (SvTYPE(dstr) >= SVt_PV);
4131                     SvPV_set(dstr,
4132                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4133                 }
4134                 SvLEN_set(dstr, len);
4135                 SvCUR_set(dstr, cur);
4136                 SvREADONLY_on(dstr);
4137                 SvFAKE_on(dstr);
4138             }
4139             else
4140                 {       /* Passes the swipe test.  */
4141                 SvPV_set(dstr, SvPVX_mutable(sstr));
4142                 SvLEN_set(dstr, SvLEN(sstr));
4143                 SvCUR_set(dstr, SvCUR(sstr));
4144
4145                 SvTEMP_off(dstr);
4146                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4147                 SvPV_set(sstr, NULL);
4148                 SvLEN_set(sstr, 0);
4149                 SvCUR_set(sstr, 0);
4150                 SvTEMP_off(sstr);
4151             }
4152         }
4153         if (sflags & SVp_NOK) {
4154             SvNV_set(dstr, SvNVX(sstr));
4155         }
4156         if (sflags & SVp_IOK) {
4157             SvIV_set(dstr, SvIVX(sstr));
4158             /* Must do this otherwise some other overloaded use of 0x80000000
4159                gets confused. I guess SVpbm_VALID */
4160             if (sflags & SVf_IVisUV)
4161                 SvIsUV_on(dstr);
4162         }
4163         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4164         {
4165             const MAGIC * const smg = SvVSTRING_mg(sstr);
4166             if (smg) {
4167                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4168                          smg->mg_ptr, smg->mg_len);
4169                 SvRMAGICAL_on(dstr);
4170             }
4171         }
4172     }
4173     else if (sflags & (SVp_IOK|SVp_NOK)) {
4174         (void)SvOK_off(dstr);
4175         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4176         if (sflags & SVp_IOK) {
4177             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4178             SvIV_set(dstr, SvIVX(sstr));
4179         }
4180         if (sflags & SVp_NOK) {
4181             SvNV_set(dstr, SvNVX(sstr));
4182         }
4183     }
4184     else {
4185         if (isGV_with_GP(sstr)) {
4186             /* This stringification rule for globs is spread in 3 places.
4187                This feels bad. FIXME.  */
4188             const U32 wasfake = sflags & SVf_FAKE;
4189
4190             /* FAKE globs can get coerced, so need to turn this off
4191                temporarily if it is on.  */
4192             SvFAKE_off(sstr);
4193             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4194             SvFLAGS(sstr) |= wasfake;
4195         }
4196         else
4197             (void)SvOK_off(dstr);
4198     }
4199     if (SvTAINTED(sstr))
4200         SvTAINT(dstr);
4201 }
4202
4203 /*
4204 =for apidoc sv_setsv_mg
4205
4206 Like C<sv_setsv>, but also handles 'set' magic.
4207
4208 =cut
4209 */
4210
4211 void
4212 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4213 {
4214     PERL_ARGS_ASSERT_SV_SETSV_MG;
4215
4216     sv_setsv(dstr,sstr);
4217     SvSETMAGIC(dstr);
4218 }
4219
4220 #ifdef PERL_OLD_COPY_ON_WRITE
4221 SV *
4222 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4223 {
4224     STRLEN cur = SvCUR(sstr);
4225     STRLEN len = SvLEN(sstr);
4226     register char *new_pv;
4227
4228     PERL_ARGS_ASSERT_SV_SETSV_COW;
4229
4230     if (DEBUG_C_TEST) {
4231         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4232                       (void*)sstr, (void*)dstr);
4233         sv_dump(sstr);
4234         if (dstr)
4235                     sv_dump(dstr);
4236     }
4237
4238     if (dstr) {
4239         if (SvTHINKFIRST(dstr))
4240             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4241         else if (SvPVX_const(dstr))
4242             Safefree(SvPVX_const(dstr));
4243     }
4244     else
4245         new_SV(dstr);
4246     SvUPGRADE(dstr, SVt_PVIV);
4247
4248     assert (SvPOK(sstr));
4249     assert (SvPOKp(sstr));
4250     assert (!SvIOK(sstr));
4251     assert (!SvIOKp(sstr));
4252     assert (!SvNOK(sstr));
4253     assert (!SvNOKp(sstr));
4254
4255     if (SvIsCOW(sstr)) {
4256
4257         if (SvLEN(sstr) == 0) {
4258             /* source is a COW shared hash key.  */
4259             DEBUG_C(PerlIO_printf(Perl_debug_log,
4260                                   "Fast copy on write: Sharing hash\n"));
4261             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4262             goto common_exit;
4263         }
4264         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4265     } else {
4266         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4267         SvUPGRADE(sstr, SVt_PVIV);
4268         SvREADONLY_on(sstr);
4269         SvFAKE_on(sstr);
4270         DEBUG_C(PerlIO_printf(Perl_debug_log,
4271                               "Fast copy on write: Converting sstr to COW\n"));
4272         SV_COW_NEXT_SV_SET(dstr, sstr);
4273     }
4274     SV_COW_NEXT_SV_SET(sstr, dstr);
4275     new_pv = SvPVX_mutable(sstr);
4276
4277   common_exit:
4278     SvPV_set(dstr, new_pv);
4279     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4280     if (SvUTF8(sstr))
4281         SvUTF8_on(dstr);
4282     SvLEN_set(dstr, len);
4283     SvCUR_set(dstr, cur);
4284     if (DEBUG_C_TEST) {
4285         sv_dump(dstr);
4286     }
4287     return dstr;
4288 }
4289 #endif
4290
4291 /*
4292 =for apidoc sv_setpvn
4293
4294 Copies a string into an SV.  The C<len> parameter indicates the number of
4295 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4296 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4297
4298 =cut
4299 */
4300
4301 void
4302 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4303 {
4304     dVAR;
4305     register char *dptr;
4306
4307     PERL_ARGS_ASSERT_SV_SETPVN;
4308
4309     SV_CHECK_THINKFIRST_COW_DROP(sv);
4310     if (!ptr) {
4311         (void)SvOK_off(sv);
4312         return;
4313     }
4314     else {
4315         /* len is STRLEN which is unsigned, need to copy to signed */
4316         const IV iv = len;
4317         if (iv < 0)
4318             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4319     }
4320     SvUPGRADE(sv, SVt_PV);
4321
4322     dptr = SvGROW(sv, len + 1);
4323     Move(ptr,dptr,len,char);
4324     dptr[len] = '\0';
4325     SvCUR_set(sv, len);
4326     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4327     SvTAINT(sv);
4328 }
4329
4330 /*
4331 =for apidoc sv_setpvn_mg
4332
4333 Like C<sv_setpvn>, but also handles 'set' magic.
4334
4335 =cut
4336 */
4337
4338 void
4339 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4340 {
4341     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4342
4343     sv_setpvn(sv,ptr,len);
4344     SvSETMAGIC(sv);
4345 }
4346
4347 /*
4348 =for apidoc sv_setpv
4349
4350 Copies a string into an SV.  The string must be null-terminated.  Does not
4351 handle 'set' magic.  See C<sv_setpv_mg>.
4352
4353 =cut
4354 */
4355
4356 void
4357 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4358 {
4359     dVAR;
4360     register STRLEN len;
4361
4362     PERL_ARGS_ASSERT_SV_SETPV;
4363
4364     SV_CHECK_THINKFIRST_COW_DROP(sv);
4365     if (!ptr) {
4366         (void)SvOK_off(sv);
4367         return;
4368     }
4369     len = strlen(ptr);
4370     SvUPGRADE(sv, SVt_PV);
4371
4372     SvGROW(sv, len + 1);
4373     Move(ptr,SvPVX(sv),len+1,char);
4374     SvCUR_set(sv, len);
4375     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4376     SvTAINT(sv);
4377 }
4378
4379 /*
4380 =for apidoc sv_setpv_mg
4381
4382 Like C<sv_setpv>, but also handles 'set' magic.
4383
4384 =cut
4385 */
4386
4387 void
4388 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4389 {
4390     PERL_ARGS_ASSERT_SV_SETPV_MG;
4391
4392     sv_setpv(sv,ptr);
4393     SvSETMAGIC(sv);
4394 }
4395
4396 /*
4397 =for apidoc sv_usepvn_flags
4398
4399 Tells an SV to use C<ptr> to find its string value.  Normally the
4400 string is stored inside the SV but sv_usepvn allows the SV to use an
4401 outside string.  The C<ptr> should point to memory that was allocated
4402 by C<malloc>.  The string length, C<len>, must be supplied.  By default
4403 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4404 so that pointer should not be freed or used by the programmer after
4405 giving it to sv_usepvn, and neither should any pointers from "behind"
4406 that pointer (e.g. ptr + 1) be used.
4407
4408 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4409 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4410 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4411 C<len>, and already meets the requirements for storing in C<SvPVX>)
4412
4413 =cut
4414 */
4415
4416 void
4417 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4418 {
4419     dVAR;
4420     STRLEN allocate;
4421
4422     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4423
4424     SV_CHECK_THINKFIRST_COW_DROP(sv);
4425     SvUPGRADE(sv, SVt_PV);
4426     if (!ptr) {
4427         (void)SvOK_off(sv);
4428         if (flags & SV_SMAGIC)
4429             SvSETMAGIC(sv);
4430         return;
4431     }
4432     if (SvPVX_const(sv))
4433         SvPV_free(sv);
4434
4435 #ifdef DEBUGGING
4436     if (flags & SV_HAS_TRAILING_NUL)
4437         assert(ptr[len] == '\0');
4438 #endif
4439
4440     allocate = (flags & SV_HAS_TRAILING_NUL)
4441         ? len + 1 :
4442 #ifdef Perl_safesysmalloc_size
4443         len + 1;
4444 #else
4445         PERL_STRLEN_ROUNDUP(len + 1);
4446 #endif
4447     if (flags & SV_HAS_TRAILING_NUL) {
4448         /* It's long enough - do nothing.
4449            Specfically Perl_newCONSTSUB is relying on this.  */
4450     } else {
4451 #ifdef DEBUGGING
4452         /* Force a move to shake out bugs in callers.  */
4453         char *new_ptr = (char*)safemalloc(allocate);
4454         Copy(ptr, new_ptr, len, char);
4455         PoisonFree(ptr,len,char);
4456         Safefree(ptr);
4457         ptr = new_ptr;
4458 #else
4459         ptr = (char*) saferealloc (ptr, allocate);
4460 #endif
4461     }
4462 #ifdef Perl_safesysmalloc_size
4463     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4464 #else
4465     SvLEN_set(sv, allocate);
4466 #endif
4467     SvCUR_set(sv, len);
4468     SvPV_set(sv, ptr);
4469     if (!(flags & SV_HAS_TRAILING_NUL)) {
4470         ptr[len] = '\0';
4471     }
4472     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4473     SvTAINT(sv);
4474     if (flags & SV_SMAGIC)
4475         SvSETMAGIC(sv);
4476 }
4477
4478 #ifdef PERL_OLD_COPY_ON_WRITE
4479 /* Need to do this *after* making the SV normal, as we need the buffer
4480    pointer to remain valid until after we've copied it.  If we let go too early,
4481    another thread could invalidate it by unsharing last of the same hash key
4482    (which it can do by means other than releasing copy-on-write Svs)
4483    or by changing the other copy-on-write SVs in the loop.  */
4484 STATIC void
4485 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4486 {
4487     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4488
4489     { /* this SV was SvIsCOW_normal(sv) */
4490          /* we need to find the SV pointing to us.  */
4491         SV *current = SV_COW_NEXT_SV(after);
4492
4493         if (current == sv) {
4494             /* The SV we point to points back to us (there were only two of us
4495                in the loop.)
4496                Hence other SV is no longer copy on write either.  */
4497             SvFAKE_off(after);
4498             SvREADONLY_off(after);
4499         } else {
4500             /* We need to follow the pointers around the loop.  */
4501             SV *next;
4502             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4503                 assert (next);
4504                 current = next;
4505                  /* don't loop forever if the structure is bust, and we have
4506                     a pointer into a closed loop.  */
4507                 assert (current != after);
4508                 assert (SvPVX_const(current) == pvx);
4509             }
4510             /* Make the SV before us point to the SV after us.  */
4511             SV_COW_NEXT_SV_SET(current, after);
4512         }
4513     }
4514 }
4515 #endif
4516 /*
4517 =for apidoc sv_force_normal_flags
4518
4519 Undo various types of fakery on an SV: if the PV is a shared string, make
4520 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4521 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4522 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4523 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4524 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4525 set to some other value.) In addition, the C<flags> parameter gets passed to
4526 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4527 with flags set to 0.
4528
4529 =cut
4530 */
4531
4532 void
4533 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4534 {
4535     dVAR;
4536
4537     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4538
4539 #ifdef PERL_OLD_COPY_ON_WRITE
4540     if (SvREADONLY(sv)) {
4541         if (SvFAKE(sv)) {
4542             const char * const pvx = SvPVX_const(sv);
4543             const STRLEN len = SvLEN(sv);
4544             const STRLEN cur = SvCUR(sv);
4545             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4546                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4547                we'll fail an assertion.  */
4548             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4549
4550             if (DEBUG_C_TEST) {
4551                 PerlIO_printf(Perl_debug_log,
4552                               "Copy on write: Force normal %ld\n",
4553                               (long) flags);
4554                 sv_dump(sv);
4555             }
4556             SvFAKE_off(sv);
4557             SvREADONLY_off(sv);
4558             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4559             SvPV_set(sv, NULL);
4560             SvLEN_set(sv, 0);
4561             if (flags & SV_COW_DROP_PV) {
4562                 /* OK, so we don't need to copy our buffer.  */
4563                 SvPOK_off(sv);
4564             } else {
4565                 SvGROW(sv, cur + 1);
4566                 Move(pvx,SvPVX(sv),cur,char);
4567                 SvCUR_set(sv, cur);
4568                 *SvEND(sv) = '\0';
4569             }
4570             if (len) {
4571                 sv_release_COW(sv, pvx, next);
4572             } else {
4573                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4574             }
4575             if (DEBUG_C_TEST) {
4576                 sv_dump(sv);
4577             }
4578         }
4579         else if (IN_PERL_RUNTIME)
4580             Perl_croak(aTHX_ "%s", PL_no_modify);
4581     }
4582 #else
4583     if (SvREADONLY(sv)) {
4584         if (SvFAKE(sv)) {
4585             const char * const pvx = SvPVX_const(sv);
4586             const STRLEN len = SvCUR(sv);
4587             SvFAKE_off(sv);
4588             SvREADONLY_off(sv);
4589             SvPV_set(sv, NULL);
4590             SvLEN_set(sv, 0);
4591             SvGROW(sv, len + 1);
4592             Move(pvx,SvPVX(sv),len,char);
4593             *SvEND(sv) = '\0';
4594             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4595         }
4596         else if (IN_PERL_RUNTIME)
4597             Perl_croak(aTHX_ "%s", PL_no_modify);
4598     }
4599 #endif
4600     if (SvROK(sv))
4601         sv_unref_flags(sv, flags);
4602     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4603         sv_unglob(sv);
4604     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4605         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4606            to sv_unglob. We only need it here, so inline it.  */
4607         const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4608         SV *const temp = newSV_type(new_type);
4609         void *const temp_p = SvANY(sv);
4610
4611         if (new_type == SVt_PVMG) {
4612             SvMAGIC_set(temp, SvMAGIC(sv));
4613             SvMAGIC_set(sv, NULL);
4614             SvSTASH_set(temp, SvSTASH(sv));
4615             SvSTASH_set(sv, NULL);
4616         }
4617         SvCUR_set(temp, SvCUR(sv));
4618         /* Remember that SvPVX is in the head, not the body. */
4619         if (SvLEN(temp)) {
4620             SvLEN_set(temp, SvLEN(sv));
4621             /* This signals "buffer is owned by someone else" in sv_clear,
4622                which is the least effort way to stop it freeing the buffer.
4623             */
4624             SvLEN_set(sv, SvLEN(sv)+1);
4625         } else {
4626             /* Their buffer is already owned by someone else. */
4627             SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4628             SvLEN_set(temp, SvCUR(sv)+1);
4629         }
4630
4631         /* Now swap the rest of the bodies. */
4632
4633         SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4634         SvFLAGS(sv) |= new_type;
4635         SvANY(sv) = SvANY(temp);
4636
4637         SvFLAGS(temp) &= ~(SVTYPEMASK);
4638         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4639         SvANY(temp) = temp_p;
4640
4641         SvREFCNT_dec(temp);
4642     }
4643 }
4644
4645 /*
4646 =for apidoc sv_chop
4647
4648 Efficient removal of characters from the beginning of the string buffer.
4649 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4650 the string buffer.  The C<ptr> becomes the first character of the adjusted
4651 string. Uses the "OOK hack".
4652 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4653 refer to the same chunk of data.
4654
4655 =cut
4656 */
4657
4658 void
4659 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4660 {
4661     STRLEN delta;
4662     STRLEN old_delta;
4663     U8 *p;
4664 #ifdef DEBUGGING
4665     const U8 *real_start;
4666 #endif
4667     STRLEN max_delta;
4668
4669     PERL_ARGS_ASSERT_SV_CHOP;
4670
4671     if (!ptr || !SvPOKp(sv))
4672         return;
4673     delta = ptr - SvPVX_const(sv);
4674     if (!delta) {
4675         /* Nothing to do.  */
4676         return;
4677     }
4678     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4679        nothing uses the value of ptr any more.  */
4680     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4681     if (ptr <= SvPVX_const(sv))
4682         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4683                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4684     SV_CHECK_THINKFIRST(sv);
4685     if (delta > max_delta)
4686         Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4687                    SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4688                    SvPVX_const(sv) + max_delta);
4689
4690     if (!SvOOK(sv)) {
4691         if (!SvLEN(sv)) { /* make copy of shared string */
4692             const char *pvx = SvPVX_const(sv);
4693             const STRLEN len = SvCUR(sv);
4694             SvGROW(sv, len + 1);
4695             Move(pvx,SvPVX(sv),len,char);
4696             *SvEND(sv) = '\0';
4697         }
4698         SvFLAGS(sv) |= SVf_OOK;
4699         old_delta = 0;
4700     } else {
4701         SvOOK_offset(sv, old_delta);
4702     }
4703     SvLEN_set(sv, SvLEN(sv) - delta);
4704     SvCUR_set(sv, SvCUR(sv) - delta);
4705     SvPV_set(sv, SvPVX(sv) + delta);
4706
4707     p = (U8 *)SvPVX_const(sv);
4708
4709     delta += old_delta;
4710
4711 #ifdef DEBUGGING
4712     real_start = p - delta;
4713 #endif
4714
4715     assert(delta);
4716     if (delta < 0x100) {
4717         *--p = (U8) delta;
4718     } else {
4719         *--p = 0;
4720         p -= sizeof(STRLEN);
4721         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4722     }
4723
4724 #ifdef DEBUGGING
4725     /* Fill the preceding buffer with sentinals to verify that no-one is
4726        using it.  */
4727     while (p > real_start) {
4728         --p;
4729         *p = (U8)PTR2UV(p);
4730     }
4731 #endif
4732 }
4733
4734 /*
4735 =for apidoc sv_catpvn
4736
4737 Concatenates the string onto the end of the string which is in the SV.  The
4738 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4739 status set, then the bytes appended should be valid UTF-8.
4740 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4741
4742 =for apidoc sv_catpvn_flags
4743
4744 Concatenates the string onto the end of the string which is in the SV.  The
4745 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4746 status set, then the bytes appended should be valid UTF-8.
4747 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4748 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4749 in terms of this function.
4750
4751 =cut
4752 */
4753
4754 void
4755 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4756 {
4757     dVAR;
4758     STRLEN dlen;
4759     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4760
4761     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4762
4763     SvGROW(dsv, dlen + slen + 1);
4764     if (sstr == dstr)
4765         sstr = SvPVX_const(dsv);
4766     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4767     SvCUR_set(dsv, SvCUR(dsv) + slen);
4768     *SvEND(dsv) = '\0';
4769     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4770     SvTAINT(dsv);
4771     if (flags & SV_SMAGIC)
4772         SvSETMAGIC(dsv);
4773 }
4774
4775 /*
4776 =for apidoc sv_catsv
4777
4778 Concatenates the string from SV C<ssv> onto the end of the string in
4779 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4780 not 'set' magic.  See C<sv_catsv_mg>.
4781
4782 =for apidoc sv_catsv_flags
4783
4784 Concatenates the string from SV C<ssv> onto the end of the string in
4785 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4786 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4787 and C<sv_catsv_nomg> are implemented in terms of this function.
4788
4789 =cut */
4790
4791 void
4792 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4793 {
4794     dVAR;
4795
4796     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4797
4798    if (ssv) {
4799         STRLEN slen;
4800         const char *spv = SvPV_const(ssv, slen);
4801         if (spv) {
4802             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4803                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4804                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4805                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4806                 dsv->sv_flags doesn't have that bit set.
4807                 Andy Dougherty  12 Oct 2001
4808             */
4809             const I32 sutf8 = DO_UTF8(ssv);
4810             I32 dutf8;
4811
4812             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4813                 mg_get(dsv);
4814             dutf8 = DO_UTF8(dsv);
4815
4816             if (dutf8 != sutf8) {
4817                 if (dutf8) {
4818                     /* Not modifying source SV, so taking a temporary copy. */
4819                     SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4820
4821                     sv_utf8_upgrade(csv);
4822                     spv = SvPV_const(csv, slen);
4823                 }
4824                 else
4825                     /* Leave enough space for the cat that's about to happen */
4826                     sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4827             }
4828             sv_catpvn_nomg(dsv, spv, slen);
4829         }
4830     }
4831     if (flags & SV_SMAGIC)
4832         SvSETMAGIC(dsv);
4833 }
4834
4835 /*
4836 =for apidoc sv_catpv
4837
4838 Concatenates the string onto the end of the string which is in the SV.
4839 If the SV has the UTF-8 status set, then the bytes appended should be
4840 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4841
4842 =cut */
4843
4844 void
4845 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4846 {
4847     dVAR;
4848     register STRLEN len;
4849     STRLEN tlen;
4850     char *junk;
4851
4852     PERL_ARGS_ASSERT_SV_CATPV;
4853
4854     if (!ptr)
4855         return;
4856     junk = SvPV_force(sv, tlen);
4857     len = strlen(ptr);
4858     SvGROW(sv, tlen + len + 1);
4859     if (ptr == junk)
4860         ptr = SvPVX_const(sv);
4861     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4862     SvCUR_set(sv, SvCUR(sv) + len);
4863     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4864     SvTAINT(sv);
4865 }
4866
4867 /*
4868 =for apidoc sv_catpv_mg
4869
4870 Like C<sv_catpv>, but also handles 'set' magic.
4871
4872 =cut
4873 */
4874
4875 void
4876 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4877 {
4878     PERL_ARGS_ASSERT_SV_CATPV_MG;
4879
4880     sv_catpv(sv,ptr);
4881     SvSETMAGIC(sv);
4882 }
4883
4884 /*
4885 =for apidoc newSV
4886
4887 Creates a new SV.  A non-zero C<len> parameter indicates the number of
4888 bytes of preallocated string space the SV should have.  An extra byte for a
4889 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
4890 space is allocated.)  The reference count for the new SV is set to 1.
4891
4892 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4893 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4894 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4895 L<perlhack/PERL_MEM_LOG>).  The older API is still there for use in XS
4896 modules supporting older perls.
4897
4898 =cut
4899 */
4900
4901 SV *
4902 Perl_newSV(pTHX_ const STRLEN len)
4903 {
4904     dVAR;
4905     register SV *sv;
4906
4907     new_SV(sv);
4908     if (len) {
4909         sv_upgrade(sv, SVt_PV);
4910         SvGROW(sv, len + 1);
4911     }
4912     return sv;
4913 }
4914 /*
4915 =for apidoc sv_magicext
4916
4917 Adds magic to an SV, upgrading it if necessary. Applies the
4918 supplied vtable and returns a pointer to the magic added.
4919
4920 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4921 In particular, you can add magic to SvREADONLY SVs, and add more than
4922 one instance of the same 'how'.
4923
4924 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4925 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4926 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4927 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4928
4929 (This is now used as a subroutine by C<sv_magic>.)
4930
4931 =cut
4932 */
4933 MAGIC *
4934 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4935                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4936 {
4937     dVAR;
4938     MAGIC* mg;
4939
4940     PERL_ARGS_ASSERT_SV_MAGICEXT;
4941
4942     SvUPGRADE(sv, SVt_PVMG);
4943     Newxz(mg, 1, MAGIC);
4944     mg->mg_moremagic = SvMAGIC(sv);
4945     SvMAGIC_set(sv, mg);
4946
4947     /* Sometimes a magic contains a reference loop, where the sv and
4948        object refer to each other.  To prevent a reference loop that
4949        would prevent such objects being freed, we look for such loops
4950        and if we find one we avoid incrementing the object refcount.
4951
4952        Note we cannot do this to avoid self-tie loops as intervening RV must
4953        have its REFCNT incremented to keep it in existence.
4954
4955     */
4956     if (!obj || obj == sv ||
4957         how == PERL_MAGIC_arylen ||
4958         how == PERL_MAGIC_symtab ||
4959         (SvTYPE(obj) == SVt_PVGV &&
4960             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4961              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4962              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4963     {
4964         mg->mg_obj = obj;
4965     }
4966     else {
4967         mg->mg_obj = SvREFCNT_inc_simple(obj);
4968         mg->mg_flags |= MGf_REFCOUNTED;
4969     }
4970
4971     /* Normal self-ties simply pass a null object, and instead of
4972        using mg_obj directly, use the SvTIED_obj macro to produce a
4973        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4974        with an RV obj pointing to the glob containing the PVIO.  In
4975        this case, to avoid a reference loop, we need to weaken the
4976        reference.
4977     */
4978
4979     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4980         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
4981     {
4982       sv_rvweaken(obj);
4983     }
4984
4985     mg->mg_type = how;
4986     mg->mg_len = namlen;
4987     if (name) {
4988         if (namlen > 0)
4989             mg->mg_ptr = savepvn(name, namlen);
4990         else if (namlen == HEf_SVKEY) {
4991             /* Yes, this is casting away const. This is only for the case of
4992                HEf_SVKEY. I think we need to document this abberation of the
4993                constness of the API, rather than making name non-const, as
4994                that change propagating outwards a long way.  */
4995             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
4996         } else
4997             mg->mg_ptr = (char *) name;
4998     }
4999     mg->mg_virtual = (MGVTBL *) vtable;
5000
5001     mg_magical(sv);
5002     if (SvGMAGICAL(sv))
5003         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5004     return mg;
5005 }
5006
5007 /*
5008 =for apidoc sv_magic
5009
5010 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5011 then adds a new magic item of type C<how> to the head of the magic list.
5012
5013 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5014 handling of the C<name> and C<namlen> arguments.
5015
5016 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5017 to add more than one instance of the same 'how'.
5018
5019 =cut
5020 */
5021
5022 void
5023 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5024              const char *const name, const I32 namlen)
5025 {
5026     dVAR;
5027     const MGVTBL *vtable;
5028     MAGIC* mg;
5029
5030     PERL_ARGS_ASSERT_SV_MAGIC;
5031
5032 #ifdef PERL_OLD_COPY_ON_WRITE
5033     if (SvIsCOW(sv))
5034         sv_force_normal_flags(sv, 0);
5035 #endif
5036     if (SvREADONLY(sv)) {
5037         if (
5038             /* its okay to attach magic to shared strings; the subsequent
5039              * upgrade to PVMG will unshare the string */
5040             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5041
5042             && IN_PERL_RUNTIME
5043             && how != PERL_MAGIC_regex_global
5044             && how != PERL_MAGIC_bm
5045             && how != PERL_MAGIC_fm
5046             && how != PERL_MAGIC_sv
5047             && how != PERL_MAGIC_backref
5048            )
5049         {
5050             Perl_croak(aTHX_ "%s", PL_no_modify);
5051         }
5052     }
5053     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5054         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5055             /* sv_magic() refuses to add a magic of the same 'how' as an
5056                existing one
5057              */
5058             if (how == PERL_MAGIC_taint) {
5059                 mg->mg_len |= 1;
5060                 /* Any scalar which already had taint magic on which someone
5061                    (erroneously?) did SvIOK_on() or similar will now be
5062                    incorrectly sporting public "OK" flags.  */
5063                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5064             }
5065             return;
5066         }
5067     }
5068
5069     switch (how) {
5070     case PERL_MAGIC_sv:
5071         vtable = &PL_vtbl_sv;
5072         break;
5073     case PERL_MAGIC_overload:
5074         vtable = &PL_vtbl_amagic;
5075         break;
5076     case PERL_MAGIC_overload_elem:
5077         vtable = &PL_vtbl_amagicelem;
5078         break;
5079     case PERL_MAGIC_overload_table:
5080         vtable = &PL_vtbl_ovrld;
5081         break;
5082     case PERL_MAGIC_bm:
5083         vtable = &PL_vtbl_bm;
5084         break;
5085     case PERL_MAGIC_regdata:
5086         vtable = &PL_vtbl_regdata;
5087         break;
5088     case PERL_MAGIC_regdatum:
5089         vtable = &PL_vtbl_regdatum;
5090         break;
5091     case PERL_MAGIC_env:
5092         vtable = &PL_vtbl_env;
5093         break;
5094     case PERL_MAGIC_fm:
5095         vtable = &PL_vtbl_fm;
5096         break;
5097     case PERL_MAGIC_envelem:
5098         vtable = &PL_vtbl_envelem;
5099         break;
5100     case PERL_MAGIC_regex_global:
5101         vtable = &PL_vtbl_mglob;
5102         break;
5103     case PERL_MAGIC_isa:
5104         vtable = &PL_vtbl_isa;
5105         break;
5106     case PERL_MAGIC_isaelem:
5107         vtable = &PL_vtbl_isaelem;
5108         break;
5109     case PERL_MAGIC_nkeys:
5110         vtable = &PL_vtbl_nkeys;
5111         break;
5112     case PERL_MAGIC_dbfile:
5113         vtable = NULL;
5114         break;
5115     case PERL_MAGIC_dbline:
5116         vtable = &PL_vtbl_dbline;
5117         break;
5118 #ifdef USE_LOCALE_COLLATE
5119     case PERL_MAGIC_collxfrm:
5120         vtable = &PL_vtbl_collxfrm;
5121         break;
5122 #endif /* USE_LOCALE_COLLATE */
5123     case PERL_MAGIC_tied:
5124         vtable = &PL_vtbl_pack;
5125         break;
5126     case PERL_MAGIC_tiedelem:
5127     case PERL_MAGIC_tiedscalar:
5128         vtable = &PL_vtbl_packelem;
5129         break;
5130     case PERL_MAGIC_qr:
5131         vtable = &PL_vtbl_regexp;
5132         break;
5133     case PERL_MAGIC_sig:
5134         vtable = &PL_vtbl_sig;
5135         break;
5136     case PERL_MAGIC_sigelem:
5137         vtable = &PL_vtbl_sigelem;
5138         break;
5139     case PERL_MAGIC_taint:
5140         vtable = &PL_vtbl_taint;
5141         break;
5142     case PERL_MAGIC_uvar:
5143         vtable = &PL_vtbl_uvar;
5144         break;
5145     case PERL_MAGIC_vec:
5146         vtable = &PL_vtbl_vec;
5147         break;
5148     case PERL_MAGIC_arylen_p:
5149     case PERL_MAGIC_rhash:
5150     case PERL_MAGIC_symtab:
5151     case PERL_MAGIC_vstring:
5152         vtable = NULL;
5153         break;
5154     case PERL_MAGIC_utf8:
5155         vtable = &PL_vtbl_utf8;
5156         break;
5157     case PERL_MAGIC_substr:
5158         vtable = &PL_vtbl_substr;
5159         break;
5160     case PERL_MAGIC_defelem:
5161         vtable = &PL_vtbl_defelem;
5162         break;
5163     case PERL_MAGIC_arylen:
5164         vtable = &PL_vtbl_arylen;
5165         break;
5166     case PERL_MAGIC_pos:
5167         vtable = &PL_vtbl_pos;
5168         break;
5169     case PERL_MAGIC_backref:
5170         vtable = &PL_vtbl_backref;
5171         break;
5172     case PERL_MAGIC_hintselem:
5173         vtable = &PL_vtbl_hintselem;
5174         break;
5175     case PERL_MAGIC_hints:
5176         vtable = &PL_vtbl_hints;
5177         break;
5178     case PERL_MAGIC_ext:
5179         /* Reserved for use by extensions not perl internals.           */
5180         /* Useful for attaching extension internal data to perl vars.   */
5181         /* Note that multiple extensions may clash if magical scalars   */
5182         /* etc holding private data from one are passed to another.     */
5183         vtable = NULL;
5184         break;
5185     default:
5186         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5187     }
5188
5189     /* Rest of work is done else where */
5190     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5191
5192     switch (how) {
5193     case PERL_MAGIC_taint:
5194         mg->mg_len = 1;
5195         break;
5196     case PERL_MAGIC_ext:
5197     case PERL_MAGIC_dbfile:
5198         SvRMAGICAL_on(sv);
5199         break;
5200     }
5201 }
5202
5203 /*
5204 =for apidoc sv_unmagic
5205
5206 Removes all magic of type C<type> from an SV.
5207
5208 =cut
5209 */
5210
5211 int
5212 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5213 {
5214     MAGIC* mg;
5215     MAGIC** mgp;
5216
5217     PERL_ARGS_ASSERT_SV_UNMAGIC;
5218
5219     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5220         return 0;
5221     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5222     for (mg = *mgp; mg; mg = *mgp) {
5223         if (mg->mg_type == type) {
5224             const MGVTBL* const vtbl = mg->mg_virtual;
5225             *mgp = mg->mg_moremagic;
5226             if (vtbl && vtbl->svt_free)
5227                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5228             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5229                 if (mg->mg_len > 0)
5230                     Safefree(mg->mg_ptr);
5231                 else if (mg->mg_len == HEf_SVKEY)
5232                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5233                 else if (mg->mg_type == PERL_MAGIC_utf8)
5234                     Safefree(mg->mg_ptr);
5235             }
5236             if (mg->mg_flags & MGf_REFCOUNTED)
5237                 SvREFCNT_dec(mg->mg_obj);
5238             Safefree(mg);
5239         }
5240         else
5241             mgp = &mg->mg_moremagic;
5242     }
5243     if (SvMAGIC(sv)) {
5244         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5245             mg_magical(sv);     /*    else fix the flags now */
5246     }
5247     else {
5248         SvMAGICAL_off(sv);
5249         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5250     }
5251     return 0;
5252 }
5253
5254 /*
5255 =for apidoc sv_rvweaken
5256
5257 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5258 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5259 push a back-reference to this RV onto the array of backreferences
5260 associated with that magic. If the RV is magical, set magic will be
5261 called after the RV is cleared.
5262
5263 =cut
5264 */
5265
5266 SV *
5267 Perl_sv_rvweaken(pTHX_ SV *const sv)
5268 {
5269     SV *tsv;
5270
5271     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5272
5273     if (!SvOK(sv))  /* let undefs pass */
5274         return sv;
5275     if (!SvROK(sv))
5276         Perl_croak(aTHX_ "Can't weaken a nonreference");
5277     else if (SvWEAKREF(sv)) {
5278         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5279         return sv;
5280     }
5281     tsv = SvRV(sv);
5282     Perl_sv_add_backref(aTHX_ tsv, sv);
5283     SvWEAKREF_on(sv);
5284     SvREFCNT_dec(tsv);
5285     return sv;
5286 }
5287
5288 /* Give tsv backref magic if it hasn't already got it, then push a
5289  * back-reference to sv onto the array associated with the backref magic.
5290  */
5291
5292 /* A discussion about the backreferences array and its refcount:
5293  *
5294  * The AV holding the backreferences is pointed to either as the mg_obj of
5295  * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5296  * structure, from the xhv_backreferences field. (A HV without hv_aux will
5297  * have the standard magic instead.) The array is created with a refcount
5298  * of 2. This means that if during global destruction the array gets
5299  * picked on first to have its refcount decremented by the random zapper,
5300  * it won't actually be freed, meaning it's still theere for when its
5301  * parent gets freed.
5302  * When the parent SV is freed, in the case of magic, the magic is freed,
5303  * Perl_magic_killbackrefs is called which decrements one refcount, then
5304  * mg_obj is freed which kills the second count.
5305  * In the vase of a HV being freed, one ref is removed by
5306  * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5307  * calls.
5308  */
5309
5310 void
5311 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5312 {
5313     dVAR;
5314     AV *av;
5315
5316     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5317
5318     if (SvTYPE(tsv) == SVt_PVHV) {
5319         AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5320
5321         av = *avp;
5322         if (!av) {
5323             /* There is no AV in the offical place - try a fixup.  */
5324             MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5325
5326             if (mg) {
5327                 /* Aha. They've got it stowed in magic.  Bring it back.  */
5328                 av = MUTABLE_AV(mg->mg_obj);
5329                 /* Stop mg_free decreasing the refernce count.  */
5330                 mg->mg_obj = NULL;
5331                 /* Stop mg_free even calling the destructor, given that
5332                    there's no AV to free up.  */
5333                 mg->mg_virtual = 0;
5334                 sv_unmagic(tsv, PERL_MAGIC_backref);
5335             } else {
5336                 av = newAV();
5337                 AvREAL_off(av);
5338                 SvREFCNT_inc_simple_void(av); /* see discussion above */
5339             }
5340             *avp = av;
5341         }
5342     } else {
5343         const MAGIC *const mg
5344             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5345         if (mg)
5346             av = MUTABLE_AV(mg->mg_obj);
5347         else {
5348             av = newAV();
5349             AvREAL_off(av);
5350             sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
5351             /* av now has a refcnt of 2; see discussion above */
5352         }
5353     }
5354     if (AvFILLp(av) >= AvMAX(av)) {
5355         av_extend(av, AvFILLp(av)+1);
5356     }
5357     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5358 }
5359
5360 /* delete a back-reference to ourselves from the backref magic associated
5361  * with the SV we point to.
5362  */
5363
5364 STATIC void
5365 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5366 {
5367     dVAR;
5368     AV *av = NULL;
5369     SV **svp;
5370     I32 i;
5371
5372     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5373
5374     if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5375         av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5376         /* We mustn't attempt to "fix up" the hash here by moving the
5377            backreference array back to the hv_aux structure, as that is stored
5378            in the main HvARRAY(), and hfreentries assumes that no-one
5379            reallocates HvARRAY() while it is running.  */
5380     }
5381     if (!av) {
5382         const MAGIC *const mg
5383             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5384         if (mg)
5385             av = MUTABLE_AV(mg->mg_obj);
5386     }
5387
5388     if (!av)
5389         Perl_croak(aTHX_ "panic: del_backref");
5390
5391     assert(!SvIS_FREED(av));
5392
5393     svp = AvARRAY(av);
5394     /* We shouldn't be in here more than once, but for paranoia reasons lets
5395        not assume this.  */
5396     for (i = AvFILLp(av); i >= 0; i--) {
5397         if (svp[i] == sv) {
5398             const SSize_t fill = AvFILLp(av);
5399             if (i != fill) {
5400                 /* We weren't the last entry.
5401                    An unordered list has this property that you can take the
5402                    last element off the end to fill the hole, and it's still
5403                    an unordered list :-)
5404                 */
5405                 svp[i] = svp[fill];
5406             }
5407             svp[fill] = NULL;
5408             AvFILLp(av) = fill - 1;
5409         }
5410     }
5411 }
5412
5413 int
5414 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5415 {
5416     SV **svp = AvARRAY(av);
5417
5418     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5419     PERL_UNUSED_ARG(sv);
5420
5421     assert(!svp || !SvIS_FREED(av));
5422     if (svp) {
5423         SV *const *const last = svp + AvFILLp(av);
5424
5425         while (svp <= last) {
5426             if (*svp) {
5427                 SV *const referrer = *svp;
5428                 if (SvWEAKREF(referrer)) {
5429                     /* XXX Should we check that it hasn't changed? */
5430                     SvRV_set(referrer, 0);
5431                     SvOK_off(referrer);
5432                     SvWEAKREF_off(referrer);
5433                     SvSETMAGIC(referrer);
5434                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5435                            SvTYPE(referrer) == SVt_PVLV) {
5436                     /* You lookin' at me?  */
5437                     assert(GvSTASH(referrer));
5438                     assert(GvSTASH(referrer) == (const HV *)sv);
5439                     GvSTASH(referrer) = 0;
5440                 } else {
5441                     Perl_croak(aTHX_
5442                                "panic: magic_killbackrefs (flags=%"UVxf")",
5443                                (UV)SvFLAGS(referrer));
5444                 }
5445
5446                 *svp = NULL;
5447             }
5448             svp++;
5449         }
5450     }
5451     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5452     return 0;
5453 }
5454
5455 /*
5456 =for apidoc sv_insert
5457
5458 Inserts a string at the specified offset/length within the SV. Similar to
5459 the Perl substr() function. Handles get magic.
5460
5461 =for apidoc sv_insert_flags
5462
5463 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5464
5465 =cut
5466 */
5467
5468 void
5469 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5470 {
5471     dVAR;
5472     register char *big;
5473     register char *mid;
5474     register char *midend;
5475     register char *bigend;
5476     register I32 i;
5477     STRLEN curlen;
5478
5479     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5480
5481     if (!bigstr)
5482         Perl_croak(aTHX_ "Can't modify non-existent substring");
5483     SvPV_force_flags(bigstr, curlen, flags);
5484     (void)SvPOK_only_UTF8(bigstr);
5485     if (offset + len > curlen) {
5486         SvGROW(bigstr, offset+len+1);
5487         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5488         SvCUR_set(bigstr, offset+len);
5489     }
5490
5491     SvTAINT(bigstr);
5492     i = littlelen - len;
5493     if (i > 0) {                        /* string might grow */
5494         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5495         mid = big + offset + len;
5496         midend = bigend = big + SvCUR(bigstr);
5497         bigend += i;
5498         *bigend = '\0';
5499         while (midend > mid)            /* shove everything down */
5500             *--bigend = *--midend;
5501         Move(little,big+offset,littlelen,char);
5502         SvCUR_set(bigstr, SvCUR(bigstr) + i);
5503         SvSETMAGIC(bigstr);
5504         return;
5505     }
5506     else if (i == 0) {
5507         Move(little,SvPVX(bigstr)+offset,len,char);
5508         SvSETMAGIC(bigstr);
5509         return;
5510     }
5511
5512     big = SvPVX(bigstr);
5513     mid = big + offset;
5514     midend = mid + len;
5515     bigend = big + SvCUR(bigstr);
5516
5517     if (midend > bigend)
5518         Perl_croak(aTHX_ "panic: sv_insert");
5519
5520     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5521         if (littlelen) {
5522             Move(little, mid, littlelen,char);
5523             mid += littlelen;
5524         }
5525         i = bigend - midend;
5526         if (i > 0) {
5527             Move(midend, mid, i,char);
5528             mid += i;
5529         }
5530         *mid = '\0';
5531         SvCUR_set(bigstr, mid - big);
5532     }
5533     else if ((i = mid - big)) { /* faster from front */
5534         midend -= littlelen;
5535         mid = midend;
5536         Move(big, midend - i, i, char);
5537         sv_chop(bigstr,midend-i);
5538         if (littlelen)
5539             Move(little, mid, littlelen,char);
5540     }
5541     else if (littlelen) {
5542         midend -= littlelen;
5543         sv_chop(bigstr,midend);
5544         Move(little,midend,littlelen,char);
5545     }
5546     else {
5547         sv_chop(bigstr,midend);
5548     }
5549     SvSETMAGIC(bigstr);
5550 }
5551
5552 /*
5553 =for apidoc sv_replace
5554
5555 Make the first argument a copy of the second, then delete the original.
5556 The target SV physically takes over ownership of the body of the source SV
5557 and inherits its flags; however, the target keeps any magic it owns,
5558 and any magic in the source is discarded.
5559 Note that this is a rather specialist SV copying operation; most of the
5560 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5561
5562 =cut
5563 */
5564
5565 void
5566 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5567 {
5568     dVAR;
5569     const U32 refcnt = SvREFCNT(sv);
5570
5571     PERL_ARGS_ASSERT_SV_REPLACE;
5572
5573     SV_CHECK_THINKFIRST_COW_DROP(sv);
5574     if (SvREFCNT(nsv) != 1) {
5575         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5576                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5577     }
5578     if (SvMAGICAL(sv)) {
5579         if (SvMAGICAL(nsv))
5580             mg_free(nsv);
5581         else
5582             sv_upgrade(nsv, SVt_PVMG);
5583         SvMAGIC_set(nsv, SvMAGIC(sv));
5584         SvFLAGS(nsv) |= SvMAGICAL(sv);
5585         SvMAGICAL_off(sv);
5586         SvMAGIC_set(sv, NULL);
5587     }
5588     SvREFCNT(sv) = 0;
5589     sv_clear(sv);
5590     assert(!SvREFCNT(sv));
5591 #ifdef DEBUG_LEAKING_SCALARS
5592     sv->sv_flags  = nsv->sv_flags;
5593     sv->sv_any    = nsv->sv_any;
5594     sv->sv_refcnt = nsv->sv_refcnt;
5595     sv->sv_u      = nsv->sv_u;
5596 #else
5597     StructCopy(nsv,sv,SV);
5598 #endif
5599     if(SvTYPE(sv) == SVt_IV) {
5600         SvANY(sv)
5601             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5602     }
5603
5604
5605 #ifdef PERL_OLD_COPY_ON_WRITE
5606     if (SvIsCOW_normal(nsv)) {
5607         /* We need to follow the pointers around the loop to make the
5608            previous SV point to sv, rather than nsv.  */
5609         SV *next;
5610         SV *current = nsv;
5611         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5612             assert(next);
5613             current = next;
5614             assert(SvPVX_const(current) == SvPVX_const(nsv));
5615         }
5616         /* Make the SV before us point to the SV after us.  */
5617         if (DEBUG_C_TEST) {
5618             PerlIO_printf(Perl_debug_log, "previous is\n");
5619             sv_dump(current);
5620             PerlIO_printf(Perl_debug_log,
5621                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5622                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5623         }
5624         SV_COW_NEXT_SV_SET(current, sv);
5625     }
5626 #endif
5627     SvREFCNT(sv) = refcnt;
5628     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5629     SvREFCNT(nsv) = 0;
5630     del_SV(nsv);
5631 }
5632
5633 /*
5634 =for apidoc sv_clear
5635
5636 Clear an SV: call any destructors, free up any memory used by the body,
5637 and free the body itself. The SV's head is I<not> freed, although
5638 its type is set to all 1's so that it won't inadvertently be assumed
5639 to be live during global destruction etc.
5640 This function should only be called when REFCNT is zero. Most of the time
5641 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5642 instead.
5643
5644 =cut
5645 */
5646
5647 void
5648 Perl_sv_clear(pTHX_ register SV *const sv)
5649 {
5650     dVAR;
5651     const U32 type = SvTYPE(sv);
5652     const struct body_details *const sv_type_details
5653         = bodies_by_type + type;
5654     HV *stash;
5655
5656     PERL_ARGS_ASSERT_SV_CLEAR;
5657     assert(SvREFCNT(sv) == 0);
5658     assert(SvTYPE(sv) != SVTYPEMASK);
5659
5660     if (type <= SVt_IV) {
5661         /* See the comment in sv.h about the collusion between this early
5662            return and the overloading of the NULL slots in the size table.  */
5663         if (SvROK(sv))
5664             goto free_rv;
5665         SvFLAGS(sv) &= SVf_BREAK;
5666         SvFLAGS(sv) |= SVTYPEMASK;
5667         return;
5668     }
5669
5670     if (SvOBJECT(sv)) {
5671         if (PL_defstash &&      /* Still have a symbol table? */
5672             SvDESTROYABLE(sv))
5673         {
5674             dSP;
5675             HV* stash;
5676             do {
5677                 CV* destructor;
5678                 stash = SvSTASH(sv);
5679                 destructor = StashHANDLER(stash,DESTROY);
5680                 if (destructor
5681                         /* A constant subroutine can have no side effects, so
5682                            don't bother calling it.  */
5683                         && !CvCONST(destructor)
5684                         /* Don't bother calling an empty destructor */
5685                         && (CvISXSUB(destructor)
5686                         || (CvSTART(destructor)
5687                             && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))))
5688                 {
5689                     SV* const tmpref = newRV(sv);
5690                     SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
5691                     ENTER;
5692                     PUSHSTACKi(PERLSI_DESTROY);
5693                     EXTEND(SP, 2);
5694                     PUSHMARK(SP);
5695                     PUSHs(tmpref);
5696                     PUTBACK;
5697                     call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5698
5699
5700                     POPSTACK;
5701                     SPAGAIN;
5702                     LEAVE;
5703                     if(SvREFCNT(tmpref) < 2) {
5704                         /* tmpref is not kept alive! */
5705                         SvREFCNT(sv)--;
5706                         SvRV_set(tmpref, NULL);
5707                         SvROK_off(tmpref);
5708                     }
5709                     SvREFCNT_dec(tmpref);
5710                 }
5711             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5712
5713
5714             if (SvREFCNT(sv)) {
5715                 if (PL_in_clean_objs)
5716                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5717                           HvNAME_get(stash));
5718                 /* DESTROY gave object new lease on life */
5719                 return;
5720             }
5721         }
5722
5723         if (SvOBJECT(sv)) {
5724             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
5725             SvOBJECT_off(sv);   /* Curse the object. */
5726             if (type != SVt_PVIO)
5727                 --PL_sv_objcount;       /* XXX Might want something more general */
5728         }
5729     }
5730     if (type >= SVt_PVMG) {
5731         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5732             SvREFCNT_dec(SvOURSTASH(sv));
5733         } else if (SvMAGIC(sv))
5734             mg_free(sv);
5735         if (type == SVt_PVMG && SvPAD_TYPED(sv))
5736             SvREFCNT_dec(SvSTASH(sv));
5737     }
5738     switch (type) {
5739         /* case SVt_BIND: */
5740     case SVt_PVIO:
5741         if (IoIFP(sv) &&
5742             IoIFP(sv) != PerlIO_stdin() &&
5743             IoIFP(sv) != PerlIO_stdout() &&
5744             IoIFP(sv) != PerlIO_stderr())
5745         {
5746             io_close(MUTABLE_IO(sv), FALSE);
5747         }
5748         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5749             PerlDir_close(IoDIRP(sv));
5750         IoDIRP(sv) = (DIR*)NULL;
5751         Safefree(IoTOP_NAME(sv));
5752         Safefree(IoFMT_NAME(sv));
5753         Safefree(IoBOTTOM_NAME(sv));
5754         goto freescalar;
5755     case SVt_REGEXP:
5756         /* FIXME for plugins */
5757         pregfree2((REGEXP*) sv);
5758         goto freescalar;
5759     case SVt_PVCV:
5760     case SVt_PVFM:
5761         cv_undef(MUTABLE_CV(sv));
5762         goto freescalar;
5763     case SVt_PVHV:
5764         if (PL_last_swash_hv == (const HV *)sv) {
5765             PL_last_swash_hv = NULL;
5766         }
5767         Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5768         hv_undef(MUTABLE_HV(sv));
5769         break;
5770     case SVt_PVAV:
5771         if (PL_comppad == MUTABLE_AV(sv)) {
5772             PL_comppad = NULL;
5773             PL_curpad = NULL;
5774         }
5775         av_undef(MUTABLE_AV(sv));
5776         break;
5777     case SVt_PVLV:
5778         if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5779             SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5780             HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5781             PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5782         }
5783         else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
5784             SvREFCNT_dec(LvTARG(sv));
5785     case SVt_PVGV:
5786         if (isGV_with_GP(sv)) {
5787             if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5788                && HvNAME_get(stash))
5789                 mro_method_changed_in(stash);
5790             gp_free(MUTABLE_GV(sv));
5791             if (GvNAME_HEK(sv))
5792                 unshare_hek(GvNAME_HEK(sv));
5793             /* If we're in a stash, we don't own a reference to it. However it does
5794                have a back reference to us, which needs to be cleared.  */
5795             if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5796                     sv_del_backref(MUTABLE_SV(stash), sv);
5797         }
5798         /* FIXME. There are probably more unreferenced pointers to SVs in the
5799            interpreter struct that we should check and tidy in a similar
5800            fashion to this:  */
5801         if ((const GV *)sv == PL_last_in_gv)
5802             PL_last_in_gv = NULL;
5803     case SVt_PVMG:
5804     case SVt_PVNV:
5805     case SVt_PVIV:
5806     case SVt_PV:
5807       freescalar:
5808         /* Don't bother with SvOOK_off(sv); as we're only going to free it.  */
5809         if (SvOOK(sv)) {
5810             STRLEN offset;
5811             SvOOK_offset(sv, offset);
5812             SvPV_set(sv, SvPVX_mutable(sv) - offset);
5813             /* Don't even bother with turning off the OOK flag.  */
5814         }
5815         if (SvROK(sv)) {
5816         free_rv:
5817             {
5818                 SV * const target = SvRV(sv);
5819                 if (SvWEAKREF(sv))
5820                     sv_del_backref(target, sv);
5821                 else
5822                     SvREFCNT_dec(target);
5823             }
5824         }
5825 #ifdef PERL_OLD_COPY_ON_WRITE
5826         else if (SvPVX_const(sv)) {
5827             if (SvIsCOW(sv)) {
5828                 if (DEBUG_C_TEST) {
5829                     PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5830                     sv_dump(sv);
5831                 }
5832                 if (SvLEN(sv)) {
5833                     sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5834                 } else {
5835                     unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5836                 }
5837
5838                 SvFAKE_off(sv);
5839             } else if (SvLEN(sv)) {
5840                 Safefree(SvPVX_const(sv));
5841             }
5842         }
5843 #else
5844         else if (SvPVX_const(sv) && SvLEN(sv))
5845             Safefree(SvPVX_mutable(sv));
5846         else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5847             unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5848             SvFAKE_off(sv);
5849         }
5850 #endif
5851         break;
5852     case SVt_NV:
5853         break;
5854     }
5855
5856     SvFLAGS(sv) &= SVf_BREAK;
5857     SvFLAGS(sv) |= SVTYPEMASK;
5858
5859     if (sv_type_details->arena) {
5860         del_body(((char *)SvANY(sv) + sv_type_details->offset),
5861                  &PL_body_roots[type]);
5862     }
5863     else if (sv_type_details->body_size) {
5864         my_safefree(SvANY(sv));
5865     }
5866 }
5867
5868 /*
5869 =for apidoc sv_newref
5870
5871 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5872 instead.
5873
5874 =cut
5875 */
5876
5877 SV *
5878 Perl_sv_newref(pTHX_ SV *const sv)
5879 {
5880     PERL_UNUSED_CONTEXT;
5881     if (sv)
5882         (SvREFCNT(sv))++;
5883     return sv;
5884 }
5885
5886 /*
5887 =for apidoc sv_free
5888
5889 Decrement an SV's reference count, and if it drops to zero, call
5890 C<sv_clear> to invoke destructors and free up any memory used by
5891 the body; finally, deallocate the SV's head itself.
5892 Normally called via a wrapper macro C<SvREFCNT_dec>.
5893
5894 =cut
5895 */
5896
5897 void
5898 Perl_sv_free(pTHX_ SV *const sv)
5899 {
5900     dVAR;
5901     if (!sv)
5902         return;
5903     if (SvREFCNT(sv) == 0) {
5904         if (SvFLAGS(sv) & SVf_BREAK)
5905             /* this SV's refcnt has been artificially decremented to
5906              * trigger cleanup */
5907             return;
5908         if (PL_in_clean_all) /* All is fair */
5909             return;
5910         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5911             /* make sure SvREFCNT(sv)==0 happens very seldom */
5912             SvREFCNT(sv) = (~(U32)0)/2;
5913             return;
5914         }
5915         if (ckWARN_d(WARN_INTERNAL)) {
5916 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5917             Perl_dump_sv_child(aTHX_ sv);
5918 #else
5919   #ifdef DEBUG_LEAKING_SCALARS
5920             sv_dump(sv);
5921   #endif
5922 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5923             if (PL_warnhook == PERL_WARNHOOK_FATAL
5924                 || ckDEAD(packWARN(WARN_INTERNAL))) {
5925                 /* Don't let Perl_warner cause us to escape our fate:  */
5926                 abort();
5927             }
5928 #endif
5929             /* This may not return:  */
5930             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5931                         "Attempt to free unreferenced scalar: SV 0x%"UVxf
5932                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5933 #endif
5934         }
5935 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5936         abort();
5937 #endif
5938         return;
5939     }
5940     if (--(SvREFCNT(sv)) > 0)
5941         return;
5942     Perl_sv_free2(aTHX_ sv);
5943 }
5944
5945 void
5946 Perl_sv_free2(pTHX_ SV *const sv)
5947 {
5948     dVAR;
5949
5950     PERL_ARGS_ASSERT_SV_FREE2;
5951
5952 #ifdef DEBUGGING
5953     if (SvTEMP(sv)) {
5954         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
5955                          "Attempt to free temp prematurely: SV 0x%"UVxf
5956                          pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5957         return;
5958     }
5959 #endif
5960     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5961         /* make sure SvREFCNT(sv)==0 happens very seldom */
5962         SvREFCNT(sv) = (~(U32)0)/2;
5963         return;
5964     }
5965     sv_clear(sv);
5966     if (! SvREFCNT(sv))
5967         del_SV(sv);
5968 }
5969
5970 /*
5971 =for apidoc sv_len
5972
5973 Returns the length of the string in the SV. Handles magic and type
5974 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5975
5976 =cut
5977 */
5978
5979 STRLEN
5980 Perl_sv_len(pTHX_ register SV *const sv)
5981 {
5982     STRLEN len;
5983
5984     if (!sv)
5985         return 0;
5986
5987     if (SvGMAGICAL(sv))
5988         len = mg_length(sv);
5989     else
5990         (void)SvPV_const(sv, len);
5991     return len;
5992 }
5993
5994 /*
5995 =for apidoc sv_len_utf8
5996
5997 Returns the number of characters in the string in an SV, counting wide
5998 UTF-8 bytes as a single character. Handles magic and type coercion.
5999
6000 =cut
6001 */
6002
6003 /*
6004  * The length is cached in PERL_MAGIC_utf8, in the mg_len field.  Also the
6005  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6006  * (Note that the mg_len is not the length of the mg_ptr field.
6007  * This allows the cache to store the character length of the string without
6008  * needing to malloc() extra storage to attach to the mg_ptr.)
6009  *
6010  */
6011
6012 STRLEN
6013 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6014 {
6015     if (!sv)
6016         return 0;
6017
6018     if (SvGMAGICAL(sv))
6019         return mg_length(sv);
6020     else
6021     {
6022         STRLEN len;
6023         const U8 *s = (U8*)SvPV_const(sv, len);
6024
6025         if (PL_utf8cache) {
6026             STRLEN ulen;
6027             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6028
6029             if (mg && mg->mg_len != -1) {
6030                 ulen = mg->mg_len;
6031                 if (PL_utf8cache < 0) {
6032                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6033                     if (real != ulen) {
6034                         /* Need to turn the assertions off otherwise we may
6035                            recurse infinitely while printing error messages.
6036                         */
6037                         SAVEI8(PL_utf8cache);
6038                         PL_utf8cache = 0;
6039                         Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
6040                                    " real %"UVuf" for %"SVf,
6041                                    (UV) ulen, (UV) real, SVfARG(sv));
6042                     }
6043                 }
6044             }
6045             else {
6046                 ulen = Perl_utf8_length(aTHX_ s, s + len);
6047                 if (!SvREADONLY(sv)) {
6048                     if (!mg && (SvTYPE(sv) < SVt_PVMG ||
6049                                 !(mg = mg_find(sv, PERL_MAGIC_utf8)))) {
6050                         mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
6051                                          &PL_vtbl_utf8, 0, 0);
6052                     }
6053                     assert(mg);
6054                     mg->mg_len = ulen;
6055                     /* For now, treat "overflowed" as "still unknown".
6056                        See RT #72924.  */
6057                     if (ulen != (STRLEN) mg->mg_len)
6058                         mg->mg_len = -1;
6059                 }
6060             }
6061             return ulen;
6062         }
6063         return Perl_utf8_length(aTHX_ s, s + len);
6064     }
6065 }
6066
6067 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6068    offset.  */
6069 static STRLEN
6070 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6071                       STRLEN uoffset)
6072 {
6073     const U8 *s = start;
6074
6075     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6076
6077     while (s < send && uoffset--)
6078         s += UTF8SKIP(s);
6079     if (s > send) {
6080         /* This is the existing behaviour. Possibly it should be a croak, as
6081            it's actually a bounds error  */
6082         s = send;
6083     }
6084     return s - start;
6085 }
6086
6087 /* Given the length of the string in both bytes and UTF-8 characters, decide
6088    whether to walk forwards or backwards to find the byte corresponding to
6089    the passed in UTF-8 offset.  */
6090 static STRLEN
6091 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6092                       const STRLEN uoffset, const STRLEN uend)
6093 {
6094     STRLEN backw = uend - uoffset;
6095
6096     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6097
6098     if (uoffset < 2 * backw) {
6099         /* The assumption is that going forwards is twice the speed of going
6100            forward (that's where the 2 * backw comes from).
6101            (The real figure of course depends on the UTF-8 data.)  */
6102         return sv_pos_u2b_forwards(start, send, uoffset);
6103     }
6104
6105     while (backw--) {
6106         send--;
6107         while (UTF8_IS_CONTINUATION(*send))
6108             send--;
6109     }
6110     return send - start;
6111 }
6112
6113 /* For the string representation of the given scalar, find the byte
6114    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
6115    give another position in the string, *before* the sought offset, which
6116    (which is always true, as 0, 0 is a valid pair of positions), which should
6117    help reduce the amount of linear searching.
6118    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6119    will be used to reduce the amount of linear searching. The cache will be
6120    created if necessary, and the found value offered to it for update.  */
6121 static STRLEN
6122 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6123                     const U8 *const send, const STRLEN uoffset,
6124                     STRLEN uoffset0, STRLEN boffset0)
6125 {
6126     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
6127     bool found = FALSE;
6128
6129     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6130
6131     assert (uoffset >= uoffset0);
6132
6133     if (!SvREADONLY(sv)
6134         && PL_utf8cache
6135         && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6136                      (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6137         if ((*mgp)->mg_ptr) {
6138             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6139             if (cache[0] == uoffset) {
6140                 /* An exact match. */
6141                 return cache[1];
6142             }
6143             if (cache[2] == uoffset) {
6144                 /* An exact match. */
6145                 return cache[3];
6146             }
6147
6148             if (cache[0] < uoffset) {
6149                 /* The cache already knows part of the way.   */
6150                 if (cache[0] > uoffset0) {
6151                     /* The cache knows more than the passed in pair  */
6152                     uoffset0 = cache[0];
6153                     boffset0 = cache[1];
6154                 }
6155                 if ((*mgp)->mg_len != -1) {
6156                     /* And we know the end too.  */
6157                     boffset = boffset0
6158                         + sv_pos_u2b_midway(start + boffset0, send,
6159                                               uoffset - uoffset0,
6160                                               (*mgp)->mg_len - uoffset0);
6161                 } else {
6162                     boffset = boffset0
6163                         + sv_pos_u2b_forwards(start + boffset0,
6164                                                 send, uoffset - uoffset0);
6165                 }
6166             }
6167             else if (cache[2] < uoffset) {
6168                 /* We're between the two cache entries.  */
6169                 if (cache[2] > uoffset0) {
6170                     /* and the cache knows more than the passed in pair  */
6171                     uoffset0 = cache[2];
6172                     boffset0 = cache[3];
6173                 }
6174
6175                 boffset = boffset0
6176                     + sv_pos_u2b_midway(start + boffset0,
6177                                           start + cache[1],
6178                                           uoffset - uoffset0,
6179                                           cache[0] - uoffset0);
6180             } else {
6181                 boffset = boffset0
6182                     + sv_pos_u2b_midway(start + boffset0,
6183                                           start + cache[3],
6184                                           uoffset - uoffset0,
6185                                           cache[2] - uoffset0);
6186             }
6187             found = TRUE;
6188         }
6189         else if ((*mgp)->mg_len != -1) {
6190             /* If we can take advantage of a passed in offset, do so.  */
6191             /* In fact, offset0 is either 0, or less than offset, so don't
6192                need to worry about the other possibility.  */
6193             boffset = boffset0
6194                 + sv_pos_u2b_midway(start + boffset0, send,
6195                                       uoffset - uoffset0,
6196                                       (*mgp)->mg_len - uoffset0);
6197             found = TRUE;
6198         }
6199     }
6200
6201     if (!found || PL_utf8cache < 0) {
6202         const STRLEN real_boffset
6203             = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6204                                                send, uoffset - uoffset0);
6205
6206         if (found && PL_utf8cache < 0) {
6207             if (real_boffset != boffset) {
6208                 /* Need to turn the assertions off otherwise we may recurse
6209                    infinitely while printing error messages.  */
6210                 SAVEI8(PL_utf8cache);
6211                 PL_utf8cache = 0;
6212                 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
6213                            " real %"UVuf" for %"SVf,
6214                            (UV) boffset, (UV) real_boffset, SVfARG(sv));
6215             }
6216         }
6217         boffset = real_boffset;
6218     }
6219
6220     if (PL_utf8cache)
6221         utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6222     return boffset;
6223 }
6224
6225
6226 /*
6227 =for apidoc sv_pos_u2b_flags
6228
6229 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6230 the start of the string, to a count of the equivalent number of bytes; if
6231 lenp is non-zero, it does the same to lenp, but this time starting from
6232 the offset, rather than from the start of the string. Handles type coercion.
6233 I<flags> is passed to C<SvPV_flags>, and usually should be
6234 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6235
6236 =cut
6237 */
6238
6239 /*
6240  * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6241  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6242  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6243  *
6244  */
6245
6246 STRLEN
6247 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6248                       U32 flags)
6249 {
6250     const U8 *start;
6251     STRLEN len;
6252     STRLEN boffset;
6253
6254     PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6255
6256     start = (U8*)SvPV_flags(sv, len, flags);
6257     if (len) {
6258         const U8 * const send = start + len;
6259         MAGIC *mg = NULL;
6260         boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6261
6262         if (lenp) {
6263             /* Convert the relative offset to absolute.  */
6264             const STRLEN uoffset2 = uoffset + *lenp;
6265             const STRLEN boffset2
6266                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6267                                       uoffset, boffset) - boffset;
6268
6269             *lenp = boffset2;
6270         }
6271     } else {
6272         if (lenp)
6273             *lenp = 0;
6274         boffset = 0;
6275     }
6276
6277     return boffset;
6278 }
6279
6280 /*
6281 =for apidoc sv_pos_u2b
6282
6283 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6284 the start of the string, to a count of the equivalent number of bytes; if
6285 lenp is non-zero, it does the same to lenp, but this time starting from
6286 the offset, rather than from the start of the string. Handles magic and
6287 type coercion.
6288
6289 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6290 than 2Gb.
6291
6292 =cut
6293 */
6294
6295 /*
6296  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6297  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6298  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
6299  *
6300  */
6301
6302 /* This function is subject to size and sign problems */
6303
6304 void
6305 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6306 {
6307     PERL_ARGS_ASSERT_SV_POS_U2B;
6308
6309     if (lenp) {
6310         STRLEN ulen = (STRLEN)*lenp;
6311         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6312                                          SV_GMAGIC|SV_CONST_RETURN);
6313         *lenp = (I32)ulen;
6314     } else {
6315         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6316                                          SV_GMAGIC|SV_CONST_RETURN);
6317     }
6318 }
6319
6320 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6321    byte length pairing. The (byte) length of the total SV is passed in too,
6322    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6323    may not have updated SvCUR, so we can't rely on reading it directly.
6324
6325    The proffered utf8/byte length pairing isn't used if the cache already has
6326    two pairs, and swapping either for the proffered pair would increase the
6327    RMS of the intervals between known byte offsets.
6328
6329    The cache itself consists of 4 STRLEN values
6330    0: larger UTF-8 offset
6331    1: corresponding byte offset
6332    2: smaller UTF-8 offset
6333    3: corresponding byte offset
6334
6335    Unused cache pairs have the value 0, 0.
6336    Keeping the cache "backwards" means that the invariant of
6337    cache[0] >= cache[2] is maintained even with empty slots, which means that
6338    the code that uses it doesn't need to worry if only 1 entry has actually
6339    been set to non-zero.  It also makes the "position beyond the end of the
6340    cache" logic much simpler, as the first slot is always the one to start
6341    from.
6342 */
6343 static void
6344 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6345                            const STRLEN utf8, const STRLEN blen)
6346 {
6347     STRLEN *cache;
6348
6349     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6350
6351     if (SvREADONLY(sv))
6352         return;
6353
6354     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6355                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6356         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6357                            0);
6358         (*mgp)->mg_len = -1;
6359     }
6360     assert(*mgp);
6361
6362     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6363         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6364         (*mgp)->mg_ptr = (char *) cache;
6365     }
6366     assert(cache);
6367
6368     if (PL_utf8cache < 0 && SvPOKp(sv)) {
6369         /* SvPOKp() because it's possible that sv has string overloading, and
6370            therefore is a reference, hence SvPVX() is actually a pointer.
6371            This cures the (very real) symptoms of RT 69422, but I'm not actually
6372            sure whether we should even be caching the results of UTF-8
6373            operations on overloading, given that nothing stops overloading
6374            returning a different value every time it's called.  */
6375         const U8 *start = (const U8 *) SvPVX_const(sv);
6376         const STRLEN realutf8 = utf8_length(start, start + byte);
6377
6378         if (realutf8 != utf8) {
6379             /* Need to turn the assertions off otherwise we may recurse
6380                infinitely while printing error messages.  */
6381             SAVEI8(PL_utf8cache);
6382             PL_utf8cache = 0;
6383             Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6384                        " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6385         }
6386     }
6387
6388     /* Cache is held with the later position first, to simplify the code
6389        that deals with unbounded ends.  */
6390
6391     ASSERT_UTF8_CACHE(cache);
6392     if (cache[1] == 0) {
6393         /* Cache is totally empty  */
6394         cache[0] = utf8;
6395         cache[1] = byte;
6396     } else if (cache[3] == 0) {
6397         if (byte > cache[1]) {
6398             /* New one is larger, so goes first.  */
6399             cache[2] = cache[0];
6400             cache[3] = cache[1];
6401             cache[0] = utf8;
6402             cache[1] = byte;
6403         } else {
6404             cache[2] = utf8;
6405             cache[3] = byte;
6406         }
6407     } else {
6408 #define THREEWAY_SQUARE(a,b,c,d) \
6409             ((float)((d) - (c))) * ((float)((d) - (c))) \
6410             + ((float)((c) - (b))) * ((float)((c) - (b))) \
6411                + ((float)((b) - (a))) * ((float)((b) - (a)))
6412
6413         /* Cache has 2 slots in use, and we know three potential pairs.
6414            Keep the two that give the lowest RMS distance. Do the
6415            calcualation in bytes simply because we always know the byte
6416            length.  squareroot has the same ordering as the positive value,
6417            so don't bother with the actual square root.  */
6418         const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6419         if (byte > cache[1]) {
6420             /* New position is after the existing pair of pairs.  */
6421             const float keep_earlier
6422                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6423             const float keep_later
6424                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6425
6426             if (keep_later < keep_earlier) {
6427                 if (keep_later < existing) {
6428                     cache[2] = cache[0];
6429                     cache[3] = cache[1];
6430                     cache[0] = utf8;
6431                     cache[1] = byte;
6432                 }
6433             }
6434             else {
6435                 if (keep_earlier < existing) {
6436                     cache[0] = utf8;
6437                     cache[1] = byte;
6438                 }
6439             }
6440         }
6441         else if (byte > cache[3]) {
6442             /* New position is between the existing pair of pairs.  */
6443             const float keep_earlier
6444                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6445             const float keep_later
6446                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6447
6448             if (keep_later < keep_earlier) {
6449                 if (keep_later < existing) {
6450                     cache[2] = utf8;
6451                     cache[3] = byte;
6452                 }
6453             }
6454             else {
6455                 if (keep_earlier < existing) {
6456                     cache[0] = utf8;
6457                     cache[1] = byte;
6458                 }
6459             }
6460         }
6461         else {
6462             /* New position is before the existing pair of pairs.  */
6463             const float keep_earlier
6464                 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6465             const float keep_later
6466                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6467
6468             if (keep_later < keep_earlier) {
6469                 if (keep_later < existing) {
6470                     cache[2] = utf8;
6471                     cache[3] = byte;
6472                 }
6473             }
6474             else {
6475                 if (keep_earlier < existing) {
6476                     cache[0] = cache[2];
6477                     cache[1] = cache[3];
6478                     cache[2] = utf8;
6479                     cache[3] = byte;
6480                 }
6481             }
6482         }
6483     }
6484     ASSERT_UTF8_CACHE(cache);
6485 }
6486
6487 /* We already know all of the way, now we may be able to walk back.  The same
6488    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6489    backward is half the speed of walking forward. */
6490 static STRLEN
6491 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6492                     const U8 *end, STRLEN endu)
6493 {
6494     const STRLEN forw = target - s;
6495     STRLEN backw = end - target;
6496
6497     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6498
6499     if (forw < 2 * backw) {
6500         return utf8_length(s, target);
6501     }
6502
6503     while (end > target) {
6504         end--;
6505         while (UTF8_IS_CONTINUATION(*end)) {
6506             end--;
6507         }
6508         endu--;
6509     }
6510     return endu;
6511 }
6512
6513 /*
6514 =for apidoc sv_pos_b2u
6515
6516 Converts the value pointed to by offsetp from a count of bytes from the
6517 start of the string, to a count of the equivalent number of UTF-8 chars.
6518 Handles magic and type coercion.
6519
6520 =cut
6521 */
6522
6523 /*
6524  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6525  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6526  * byte offsets.
6527  *
6528  */
6529 void
6530 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6531 {
6532     const U8* s;
6533     const STRLEN byte = *offsetp;
6534     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
6535     STRLEN blen;
6536     MAGIC* mg = NULL;
6537     const U8* send;
6538     bool found = FALSE;
6539
6540     PERL_ARGS_ASSERT_SV_POS_B2U;
6541
6542     if (!sv)
6543         return;
6544
6545     s = (const U8*)SvPV_const(sv, blen);
6546
6547     if (blen < byte)
6548         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6549
6550     send = s + byte;
6551
6552     if (!SvREADONLY(sv)
6553         && PL_utf8cache
6554         && SvTYPE(sv) >= SVt_PVMG
6555         && (mg = mg_find(sv, PERL_MAGIC_utf8)))
6556     {
6557         if (mg->mg_ptr) {
6558             STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6559             if (cache[1] == byte) {
6560                 /* An exact match. */
6561                 *offsetp = cache[0];
6562                 return;
6563             }
6564             if (cache[3] == byte) {
6565                 /* An exact match. */
6566                 *offsetp = cache[2];
6567                 return;
6568             }
6569
6570             if (cache[1] < byte) {
6571                 /* We already know part of the way. */
6572                 if (mg->mg_len != -1) {
6573                     /* Actually, we know the end too.  */
6574                     len = cache[0]
6575                         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6576                                               s + blen, mg->mg_len - cache[0]);
6577                 } else {
6578                     len = cache[0] + utf8_length(s + cache[1], send);
6579                 }
6580             }
6581             else if (cache[3] < byte) {
6582                 /* We're between the two cached pairs, so we do the calculation
6583                    offset by the byte/utf-8 positions for the earlier pair,
6584                    then add the utf-8 characters from the string start to
6585                    there.  */
6586                 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6587                                           s + cache[1], cache[0] - cache[2])
6588                     + cache[2];
6589
6590             }
6591             else { /* cache[3] > byte */
6592                 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6593                                           cache[2]);
6594
6595             }
6596             ASSERT_UTF8_CACHE(cache);
6597             found = TRUE;
6598         } else if (mg->mg_len != -1) {
6599             len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6600             found = TRUE;
6601         }
6602     }
6603     if (!found || PL_utf8cache < 0) {
6604         const STRLEN real_len = utf8_length(s, send);
6605
6606         if (found && PL_utf8cache < 0) {
6607             if (len != real_len) {
6608                 /* Need to turn the assertions off otherwise we may recurse
6609                    infinitely while printing error messages.  */
6610                 SAVEI8(PL_utf8cache);
6611                 PL_utf8cache = 0;
6612                 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6613                            " real %"UVuf" for %"SVf,
6614                            (UV) len, (UV) real_len, SVfARG(sv));
6615             }
6616         }
6617         len = real_len;
6618     }
6619     *offsetp = len;
6620
6621     if (PL_utf8cache)
6622         utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6623 }
6624
6625 /*
6626 =for apidoc sv_eq
6627
6628 Returns a boolean indicating whether the strings in the two SVs are
6629 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6630 coerce its args to strings if necessary.
6631
6632 =cut
6633 */
6634
6635 I32
6636 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6637 {
6638     dVAR;
6639     const char *pv1;
6640     STRLEN cur1;
6641     const char *pv2;
6642     STRLEN cur2;
6643     I32  eq     = 0;
6644     char *tpv   = NULL;
6645     SV* svrecode = NULL;
6646
6647     if (!sv1) {
6648         pv1 = "";
6649         cur1 = 0;
6650     }
6651     else {
6652         /* if pv1 and pv2 are the same, second SvPV_const call may
6653          * invalidate pv1, so we may need to make a copy */
6654         if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6655             pv1 = SvPV_const(sv1, cur1);
6656             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6657         }
6658         pv1 = SvPV_const(sv1, cur1);
6659     }
6660
6661     if (!sv2){
6662         pv2 = "";
6663         cur2 = 0;
6664     }
6665     else
6666         pv2 = SvPV_const(sv2, cur2);
6667
6668     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6669         /* Differing utf8ness.
6670          * Do not UTF8size the comparands as a side-effect. */
6671          if (PL_encoding) {
6672               if (SvUTF8(sv1)) {
6673                    svrecode = newSVpvn(pv2, cur2);
6674                    sv_recode_to_utf8(svrecode, PL_encoding);
6675                    pv2 = SvPV_const(svrecode, cur2);
6676               }
6677               else {
6678                    svrecode = newSVpvn(pv1, cur1);
6679                    sv_recode_to_utf8(svrecode, PL_encoding);
6680                    pv1 = SvPV_const(svrecode, cur1);
6681               }
6682               /* Now both are in UTF-8. */
6683               if (cur1 != cur2) {
6684                    SvREFCNT_dec(svrecode);
6685                    return FALSE;
6686               }
6687          }
6688          else {
6689               bool is_utf8 = TRUE;
6690
6691               if (SvUTF8(sv1)) {
6692                    /* sv1 is the UTF-8 one,
6693                     * if is equal it must be downgrade-able */
6694                    char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6695                                                      &cur1, &is_utf8);
6696                    if (pv != pv1)
6697                         pv1 = tpv = pv;
6698               }
6699               else {
6700                    /* sv2 is the UTF-8 one,
6701                     * if is equal it must be downgrade-able */
6702                    char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6703                                                       &cur2, &is_utf8);
6704                    if (pv != pv2)
6705                         pv2 = tpv = pv;
6706               }
6707               if (is_utf8) {
6708                    /* Downgrade not possible - cannot be eq */
6709                    assert (tpv == 0);
6710                    return FALSE;
6711               }
6712          }
6713     }
6714
6715     if (cur1 == cur2)
6716         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6717
6718     SvREFCNT_dec(svrecode);
6719     if (tpv)
6720         Safefree(tpv);
6721
6722     return eq;
6723 }
6724
6725 /*
6726 =for apidoc sv_cmp
6727
6728 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
6729 string in C<sv1> is less than, equal to, or greater than the string in
6730 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6731 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
6732
6733 =cut
6734 */
6735
6736 I32
6737 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6738 {
6739     dVAR;
6740     STRLEN cur1, cur2;
6741     const char *pv1, *pv2;
6742     char *tpv = NULL;
6743     I32  cmp;
6744     SV *svrecode = NULL;
6745
6746     if (!sv1) {
6747         pv1 = "";
6748         cur1 = 0;
6749     }
6750     else
6751         pv1 = SvPV_const(sv1, cur1);
6752
6753     if (!sv2) {
6754         pv2 = "";
6755         cur2 = 0;
6756     }
6757     else
6758         pv2 = SvPV_const(sv2, cur2);
6759
6760     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6761         /* Differing utf8ness.
6762          * Do not UTF8size the comparands as a side-effect. */
6763         if (SvUTF8(sv1)) {
6764             if (PL_encoding) {
6765                  svrecode = newSVpvn(pv2, cur2);
6766                  sv_recode_to_utf8(svrecode, PL_encoding);
6767                  pv2 = SvPV_const(svrecode, cur2);
6768             }
6769             else {
6770                  pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6771             }
6772         }
6773         else {
6774             if (PL_encoding) {
6775                  svrecode = newSVpvn(pv1, cur1);
6776                  sv_recode_to_utf8(svrecode, PL_encoding);
6777                  pv1 = SvPV_const(svrecode, cur1);
6778             }
6779             else {
6780                  pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6781             }
6782         }
6783     }
6784
6785     if (!cur1) {
6786         cmp = cur2 ? -1 : 0;
6787     } else if (!cur2) {
6788         cmp = 1;
6789     } else {
6790         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6791
6792         if (retval) {
6793             cmp = retval < 0 ? -1 : 1;
6794         } else if (cur1 == cur2) {
6795             cmp = 0;
6796         } else {
6797             cmp = cur1 < cur2 ? -1 : 1;
6798         }
6799     }
6800
6801     SvREFCNT_dec(svrecode);
6802     if (tpv)
6803         Safefree(tpv);
6804
6805     return cmp;
6806 }
6807
6808 /*
6809 =for apidoc sv_cmp_locale
6810
6811 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6812 'use bytes' aware, handles get magic, and will coerce its args to strings
6813 if necessary.  See also C<sv_cmp>.
6814
6815 =cut
6816 */
6817
6818 I32
6819 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6820 {
6821     dVAR;
6822 #ifdef USE_LOCALE_COLLATE
6823
6824     char *pv1, *pv2;
6825     STRLEN len1, len2;
6826     I32 retval;
6827
6828     if (PL_collation_standard)
6829         goto raw_compare;
6830
6831     len1 = 0;
6832     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6833     len2 = 0;
6834     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6835
6836     if (!pv1 || !len1) {
6837         if (pv2 && len2)
6838             return -1;
6839         else
6840             goto raw_compare;
6841     }
6842     else {
6843         if (!pv2 || !len2)
6844             return 1;
6845     }
6846
6847     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6848
6849     if (retval)
6850         return retval < 0 ? -1 : 1;
6851
6852     /*
6853      * When the result of collation is equality, that doesn't mean
6854      * that there are no differences -- some locales exclude some
6855      * characters from consideration.  So to avoid false equalities,
6856      * we use the raw string as a tiebreaker.
6857      */
6858
6859   raw_compare:
6860     /*FALLTHROUGH*/
6861
6862 #endif /* USE_LOCALE_COLLATE */
6863
6864     return sv_cmp(sv1, sv2);
6865 }
6866
6867
6868 #ifdef USE_LOCALE_COLLATE
6869
6870 /*
6871 =for apidoc sv_collxfrm
6872
6873 Add Collate Transform magic to an SV if it doesn't already have it.
6874
6875 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6876 scalar data of the variable, but transformed to such a format that a normal
6877 memory comparison can be used to compare the data according to the locale
6878 settings.
6879
6880 =cut
6881 */
6882
6883 char *
6884 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6885 {
6886     dVAR;
6887     MAGIC *mg;
6888
6889     PERL_ARGS_ASSERT_SV_COLLXFRM;
6890
6891     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6892     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6893         const char *s;
6894         char *xf;
6895         STRLEN len, xlen;
6896
6897         if (mg)
6898             Safefree(mg->mg_ptr);
6899         s = SvPV_const(sv, len);
6900         if ((xf = mem_collxfrm(s, len, &xlen))) {
6901             if (! mg) {
6902 #ifdef PERL_OLD_COPY_ON_WRITE
6903                 if (SvIsCOW(sv))
6904                     sv_force_normal_flags(sv, 0);
6905 #endif
6906                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6907                                  0, 0);
6908                 assert(mg);
6909             }
6910             mg->mg_ptr = xf;
6911             mg->mg_len = xlen;
6912         }
6913         else {
6914             if (mg) {
6915                 mg->mg_ptr = NULL;
6916                 mg->mg_len = -1;
6917             }
6918         }
6919     }
6920     if (mg && mg->mg_ptr) {
6921         *nxp = mg->mg_len;
6922         return mg->mg_ptr + sizeof(PL_collation_ix);
6923     }
6924     else {
6925         *nxp = 0;
6926         return NULL;
6927     }
6928 }
6929
6930 #endif /* USE_LOCALE_COLLATE */
6931
6932 /*
6933 =for apidoc sv_gets
6934
6935 Get a line from the filehandle and store it into the SV, optionally
6936 appending to the currently-stored string.
6937
6938 =cut
6939 */
6940
6941 char *
6942 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6943 {
6944     dVAR;
6945     const char *rsptr;
6946     STRLEN rslen;
6947     register STDCHAR rslast;
6948     register STDCHAR *bp;
6949     register I32 cnt;
6950     I32 i = 0;
6951     I32 rspara = 0;
6952
6953     PERL_ARGS_ASSERT_SV_GETS;
6954
6955     if (SvTHINKFIRST(sv))
6956         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6957     /* XXX. If you make this PVIV, then copy on write can copy scalars read
6958        from <>.
6959        However, perlbench says it's slower, because the existing swipe code
6960        is faster than copy on write.
6961        Swings and roundabouts.  */
6962     SvUPGRADE(sv, SVt_PV);
6963
6964     SvSCREAM_off(sv);
6965
6966     if (append) {
6967         if (PerlIO_isutf8(fp)) {
6968             if (!SvUTF8(sv)) {
6969                 sv_utf8_upgrade_nomg(sv);
6970                 sv_pos_u2b(sv,&append,0);
6971             }
6972         } else if (SvUTF8(sv)) {
6973             SV * const tsv = newSV(0);
6974             sv_gets(tsv, fp, 0);
6975             sv_utf8_upgrade_nomg(tsv);
6976             SvCUR_set(sv,append);
6977             sv_catsv(sv,tsv);
6978             sv_free(tsv);
6979             goto return_string_or_null;
6980         }
6981     }
6982
6983     SvPOK_only(sv);
6984     if (PerlIO_isutf8(fp))
6985         SvUTF8_on(sv);
6986
6987     if (IN_PERL_COMPILETIME) {
6988         /* we always read code in line mode */
6989         rsptr = "\n";
6990         rslen = 1;
6991     }
6992     else if (RsSNARF(PL_rs)) {
6993         /* If it is a regular disk file use size from stat() as estimate
6994            of amount we are going to read -- may result in mallocing
6995            more memory than we really need if the layers below reduce
6996            the size we read (e.g. CRLF or a gzip layer).
6997          */
6998         Stat_t st;
6999         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
7000             const Off_t offset = PerlIO_tell(fp);
7001             if (offset != (Off_t) -1 && st.st_size + append > offset) {
7002                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7003             }
7004         }
7005         rsptr = NULL;
7006         rslen = 0;
7007     }
7008     else if (RsRECORD(PL_rs)) {
7009       I32 bytesread;
7010       char *buffer;
7011       U32 recsize;
7012 #ifdef VMS
7013       int fd;
7014 #endif
7015
7016       /* Grab the size of the record we're getting */
7017       recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7018       buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7019       /* Go yank in */
7020 #ifdef VMS
7021       /* VMS wants read instead of fread, because fread doesn't respect */
7022       /* RMS record boundaries. This is not necessarily a good thing to be */
7023       /* doing, but we've got no other real choice - except avoid stdio
7024          as implementation - perhaps write a :vms layer ?
7025        */
7026       fd = PerlIO_fileno(fp);
7027       if (fd == -1) { /* in-memory file from PerlIO::Scalar */
7028           bytesread = PerlIO_read(fp, buffer, recsize);
7029       }
7030       else {
7031           bytesread = PerlLIO_read(fd, buffer, recsize);
7032       }
7033 #else
7034       bytesread = PerlIO_read(fp, buffer, recsize);
7035 #endif
7036       if (bytesread < 0)
7037           bytesread = 0;
7038       SvCUR_set(sv, bytesread + append);
7039       buffer[bytesread] = '\0';
7040       goto return_string_or_null;
7041     }
7042     else if (RsPARA(PL_rs)) {
7043         rsptr = "\n\n";
7044         rslen = 2;
7045         rspara = 1;
7046     }
7047     else {
7048         /* Get $/ i.e. PL_rs into same encoding as stream wants */
7049         if (PerlIO_isutf8(fp)) {
7050             rsptr = SvPVutf8(PL_rs, rslen);
7051         }
7052         else {
7053             if (SvUTF8(PL_rs)) {
7054                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7055                     Perl_croak(aTHX_ "Wide character in $/");
7056                 }
7057             }
7058             rsptr = SvPV_const(PL_rs, rslen);
7059         }
7060     }
7061
7062     rslast = rslen ? rsptr[rslen - 1] : '\0';
7063
7064     if (rspara) {               /* have to do this both before and after */
7065         do {                    /* to make sure file boundaries work right */
7066             if (PerlIO_eof(fp))
7067                 return 0;
7068             i = PerlIO_getc(fp);
7069             if (i != '\n') {
7070                 if (i == -1)
7071                     return 0;
7072                 PerlIO_ungetc(fp,i);
7073                 break;
7074             }
7075         } while (i != EOF);
7076     }
7077
7078     /* See if we know enough about I/O mechanism to cheat it ! */
7079
7080     /* This used to be #ifdef test - it is made run-time test for ease
7081        of abstracting out stdio interface. One call should be cheap
7082        enough here - and may even be a macro allowing compile
7083        time optimization.
7084      */
7085
7086     if (PerlIO_fast_gets(fp)) {
7087
7088     /*
7089      * We're going to steal some values from the stdio struct
7090      * and put EVERYTHING in the innermost loop into registers.
7091      */
7092     register STDCHAR *ptr;
7093     STRLEN bpx;
7094     I32 shortbuffered;
7095
7096 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7097     /* An ungetc()d char is handled separately from the regular
7098      * buffer, so we getc() it back out and stuff it in the buffer.
7099      */
7100     i = PerlIO_getc(fp);
7101     if (i == EOF) return 0;
7102     *(--((*fp)->_ptr)) = (unsigned char) i;
7103     (*fp)->_cnt++;
7104 #endif
7105
7106     /* Here is some breathtakingly efficient cheating */
7107
7108     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
7109     /* make sure we have the room */
7110     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7111         /* Not room for all of it
7112            if we are looking for a separator and room for some
7113          */
7114         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7115             /* just process what we have room for */
7116             shortbuffered = cnt - SvLEN(sv) + append + 1;
7117             cnt -= shortbuffered;
7118         }
7119         else {
7120             shortbuffered = 0;
7121             /* remember that cnt can be negative */
7122             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7123         }
7124     }
7125     else
7126         shortbuffered = 0;
7127     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
7128     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7129     DEBUG_P(PerlIO_printf(Perl_debug_log,
7130         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7131     DEBUG_P(PerlIO_printf(Perl_debug_log,
7132         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7133                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7134                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7135     for (;;) {
7136       screamer:
7137         if (cnt > 0) {
7138             if (rslen) {
7139                 while (cnt > 0) {                    /* this     |  eat */
7140                     cnt--;
7141                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
7142                         goto thats_all_folks;        /* screams  |  sed :-) */
7143                 }
7144             }
7145             else {
7146                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
7147                 bp += cnt;                           /* screams  |  dust */
7148                 ptr += cnt;                          /* louder   |  sed :-) */
7149                 cnt = 0;
7150             }
7151         }
7152
7153         if (shortbuffered) {            /* oh well, must extend */
7154             cnt = shortbuffered;
7155             shortbuffered = 0;
7156             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7157             SvCUR_set(sv, bpx);
7158             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7159             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7160             continue;
7161         }
7162
7163         DEBUG_P(PerlIO_printf(Perl_debug_log,
7164                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7165                               PTR2UV(ptr),(long)cnt));
7166         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7167 #if 0
7168         DEBUG_P(PerlIO_printf(Perl_debug_log,
7169             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7170             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7171             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7172 #endif
7173         /* This used to call 'filbuf' in stdio form, but as that behaves like
7174            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7175            another abstraction.  */
7176         i   = PerlIO_getc(fp);          /* get more characters */
7177 #if 0
7178         DEBUG_P(PerlIO_printf(Perl_debug_log,
7179             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7180             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7181             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7182 #endif
7183         cnt = PerlIO_get_cnt(fp);
7184         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
7185         DEBUG_P(PerlIO_printf(Perl_debug_log,
7186             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7187
7188         if (i == EOF)                   /* all done for ever? */
7189             goto thats_really_all_folks;
7190
7191         bpx = bp - (STDCHAR*)SvPVX_const(sv);   /* box up before relocation */
7192         SvCUR_set(sv, bpx);
7193         SvGROW(sv, bpx + cnt + 2);
7194         bp = (STDCHAR*)SvPVX_const(sv) + bpx;   /* unbox after relocation */
7195
7196         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
7197
7198         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
7199             goto thats_all_folks;
7200     }
7201
7202 thats_all_folks:
7203     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7204           memNE((char*)bp - rslen, rsptr, rslen))
7205         goto screamer;                          /* go back to the fray */
7206 thats_really_all_folks:
7207     if (shortbuffered)
7208         cnt += shortbuffered;
7209         DEBUG_P(PerlIO_printf(Perl_debug_log,
7210             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7211     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
7212     DEBUG_P(PerlIO_printf(Perl_debug_log,
7213         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7214         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7215         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7216     *bp = '\0';
7217     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));      /* set length */
7218     DEBUG_P(PerlIO_printf(Perl_debug_log,
7219         "Screamer: done, len=%ld, string=|%.*s|\n",
7220         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7221     }
7222    else
7223     {
7224        /*The big, slow, and stupid way. */
7225 #ifdef USE_HEAP_INSTEAD_OF_STACK        /* Even slower way. */
7226         STDCHAR *buf = NULL;
7227         Newx(buf, 8192, STDCHAR);
7228         assert(buf);
7229 #else
7230         STDCHAR buf[8192];
7231 #endif
7232
7233 screamer2:
7234         if (rslen) {
7235             register const STDCHAR * const bpe = buf + sizeof(buf);
7236             bp = buf;
7237             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7238                 ; /* keep reading */
7239             cnt = bp - buf;
7240         }
7241         else {
7242             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7243             /* Accomodate broken VAXC compiler, which applies U8 cast to
7244              * both args of ?: operator, causing EOF to change into 255
7245              */
7246             if (cnt > 0)
7247                  i = (U8)buf[cnt - 1];
7248             else
7249                  i = EOF;
7250         }
7251
7252         if (cnt < 0)
7253             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
7254         if (append)
7255              sv_catpvn(sv, (char *) buf, cnt);
7256         else
7257              sv_setpvn(sv, (char *) buf, cnt);
7258
7259         if (i != EOF &&                 /* joy */
7260             (!rslen ||
7261              SvCUR(sv) < rslen ||
7262              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7263         {
7264             append = -1;
7265             /*
7266              * If we're reading from a TTY and we get a short read,
7267              * indicating that the user hit his EOF character, we need
7268              * to notice it now, because if we try to read from the TTY
7269              * again, the EOF condition will disappear.
7270              *
7271              * The comparison of cnt to sizeof(buf) is an optimization
7272              * that prevents unnecessary calls to feof().
7273              *
7274              * - jik 9/25/96
7275              */
7276             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7277                 goto screamer2;
7278         }
7279
7280 #ifdef USE_HEAP_INSTEAD_OF_STACK
7281         Safefree(buf);
7282 #endif
7283     }
7284
7285     if (rspara) {               /* have to do this both before and after */
7286         while (i != EOF) {      /* to make sure file boundaries work right */
7287             i = PerlIO_getc(fp);
7288             if (i != '\n') {
7289                 PerlIO_ungetc(fp,i);
7290                 break;
7291             }
7292         }
7293     }
7294
7295 return_string_or_null:
7296     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7297 }
7298
7299 /*
7300 =for apidoc sv_inc
7301
7302 Auto-increment of the value in the SV, doing string to numeric conversion
7303 if necessary. Handles 'get' magic.
7304
7305 =cut
7306 */
7307
7308 void
7309 Perl_sv_inc(pTHX_ register SV *const sv)
7310 {
7311     dVAR;
7312     register char *d;
7313     int flags;
7314
7315     if (!sv)
7316         return;
7317     SvGETMAGIC(sv);
7318     if (SvTHINKFIRST(sv)) {
7319         if (SvIsCOW(sv))
7320             sv_force_normal_flags(sv, 0);
7321         if (SvREADONLY(sv)) {
7322             if (IN_PERL_RUNTIME)
7323                 Perl_croak(aTHX_ "%s", PL_no_modify);
7324         }
7325         if (SvROK(sv)) {
7326             IV i;
7327             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7328                 return;
7329             i = PTR2IV(SvRV(sv));
7330             sv_unref(sv);
7331             sv_setiv(sv, i);
7332         }
7333     }
7334     flags = SvFLAGS(sv);
7335     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7336         /* It's (privately or publicly) a float, but not tested as an
7337            integer, so test it to see. */
7338         (void) SvIV(sv);
7339         flags = SvFLAGS(sv);
7340     }
7341     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7342         /* It's publicly an integer, or privately an integer-not-float */
7343 #ifdef PERL_PRESERVE_IVUV
7344       oops_its_int:
7345 #endif
7346         if (SvIsUV(sv)) {
7347             if (SvUVX(sv) == UV_MAX)
7348                 sv_setnv(sv, UV_MAX_P1);
7349             else
7350                 (void)SvIOK_only_UV(sv);
7351                 SvUV_set(sv, SvUVX(sv) + 1);
7352         } else {
7353             if (SvIVX(sv) == IV_MAX)
7354                 sv_setuv(sv, (UV)IV_MAX + 1);
7355             else {
7356                 (void)SvIOK_only(sv);
7357                 SvIV_set(sv, SvIVX(sv) + 1);
7358             }
7359         }
7360         return;
7361     }
7362     if (flags & SVp_NOK) {
7363         const NV was = SvNVX(sv);
7364         if (NV_OVERFLOWS_INTEGERS_AT &&
7365             was >= NV_OVERFLOWS_INTEGERS_AT) {
7366             Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7367                            "Lost precision when incrementing %" NVff " by 1",
7368                            was);
7369         }
7370         (void)SvNOK_only(sv);
7371         SvNV_set(sv, was + 1.0);
7372         return;
7373     }
7374
7375     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7376         if ((flags & SVTYPEMASK) < SVt_PVIV)
7377             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7378         (void)SvIOK_only(sv);
7379         SvIV_set(sv, 1);
7380         return;
7381     }
7382     d = SvPVX(sv);
7383     while (isALPHA(*d)) d++;
7384     while (isDIGIT(*d)) d++;
7385     if (d < SvEND(sv)) {
7386 #ifdef PERL_PRESERVE_IVUV
7387         /* Got to punt this as an integer if needs be, but we don't issue
7388            warnings. Probably ought to make the sv_iv_please() that does
7389            the conversion if possible, and silently.  */
7390         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7391         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7392             /* Need to try really hard to see if it's an integer.
7393                9.22337203685478e+18 is an integer.
7394                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7395                so $a="9.22337203685478e+18"; $a+0; $a++
7396                needs to be the same as $a="9.22337203685478e+18"; $a++
7397                or we go insane. */
7398
7399             (void) sv_2iv(sv);
7400             if (SvIOK(sv))
7401                 goto oops_its_int;
7402
7403             /* sv_2iv *should* have made this an NV */
7404             if (flags & SVp_NOK) {
7405                 (void)SvNOK_only(sv);
7406                 SvNV_set(sv, SvNVX(sv) + 1.0);
7407                 return;
7408             }
7409             /* I don't think we can get here. Maybe I should assert this
7410                And if we do get here I suspect that sv_setnv will croak. NWC
7411                Fall through. */
7412 #if defined(USE_LONG_DOUBLE)
7413             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",
7414                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7415 #else
7416             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7417                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7418 #endif
7419         }
7420 #endif /* PERL_PRESERVE_IVUV */
7421         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7422         return;
7423     }
7424     d--;
7425     while (d >= SvPVX_const(sv)) {
7426         if (isDIGIT(*d)) {
7427             if (++*d <= '9')
7428                 return;
7429             *(d--) = '0';
7430         }
7431         else {
7432 #ifdef EBCDIC
7433             /* MKS: The original code here died if letters weren't consecutive.
7434              * at least it didn't have to worry about non-C locales.  The
7435              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7436              * arranged in order (although not consecutively) and that only
7437              * [A-Za-z] are accepted by isALPHA in the C locale.
7438              */
7439             if (*d != 'z' && *d != 'Z') {
7440                 do { ++*d; } while (!isALPHA(*d));
7441                 return;
7442             }
7443             *(d--) -= 'z' - 'a';
7444 #else
7445             ++*d;
7446             if (isALPHA(*d))
7447                 return;
7448             *(d--) -= 'z' - 'a' + 1;
7449 #endif
7450         }
7451     }
7452     /* oh,oh, the number grew */
7453     SvGROW(sv, SvCUR(sv) + 2);
7454     SvCUR_set(sv, SvCUR(sv) + 1);
7455     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7456         *d = d[-1];
7457     if (isDIGIT(d[1]))
7458         *d = '1';
7459     else
7460         *d = d[1];
7461 }
7462
7463 /*
7464 =for apidoc sv_dec
7465
7466 Auto-decrement of the value in the SV, doing string to numeric conversion
7467 if necessary. Handles 'get' magic.
7468
7469 =cut
7470 */
7471
7472 void
7473 Perl_sv_dec(pTHX_ register SV *const sv)
7474 {
7475     dVAR;
7476     int flags;
7477
7478     if (!sv)
7479         return;
7480     SvGETMAGIC(sv);
7481     if (SvTHINKFIRST(sv)) {
7482         if (SvIsCOW(sv))
7483             sv_force_normal_flags(sv, 0);
7484         if (SvREADONLY(sv)) {
7485             if (IN_PERL_RUNTIME)
7486                 Perl_croak(aTHX_ "%s", PL_no_modify);
7487         }
7488         if (SvROK(sv)) {
7489             IV i;
7490             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7491                 return;
7492             i = PTR2IV(SvRV(sv));
7493             sv_unref(sv);
7494             sv_setiv(sv, i);
7495         }
7496     }
7497     /* Unlike sv_inc we don't have to worry about string-never-numbers
7498        and keeping them magic. But we mustn't warn on punting */
7499     flags = SvFLAGS(sv);
7500     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7501         /* It's publicly an integer, or privately an integer-not-float */
7502 #ifdef PERL_PRESERVE_IVUV
7503       oops_its_int:
7504 #endif
7505         if (SvIsUV(sv)) {
7506             if (SvUVX(sv) == 0) {
7507                 (void)SvIOK_only(sv);
7508                 SvIV_set(sv, -1);
7509             }
7510             else {
7511                 (void)SvIOK_only_UV(sv);
7512                 SvUV_set(sv, SvUVX(sv) - 1);
7513             }
7514         } else {
7515             if (SvIVX(sv) == IV_MIN) {
7516                 sv_setnv(sv, (NV)IV_MIN);
7517                 goto oops_its_num;
7518             }
7519             else {
7520                 (void)SvIOK_only(sv);
7521                 SvIV_set(sv, SvIVX(sv) - 1);
7522             }
7523         }
7524         return;
7525     }
7526     if (flags & SVp_NOK) {
7527     oops_its_num:
7528         {
7529             const NV was = SvNVX(sv);
7530             if (NV_OVERFLOWS_INTEGERS_AT &&
7531                 was <= -NV_OVERFLOWS_INTEGERS_AT) {
7532                 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7533                                "Lost precision when decrementing %" NVff " by 1",
7534                                was);
7535             }
7536             (void)SvNOK_only(sv);
7537             SvNV_set(sv, was - 1.0);
7538             return;
7539         }
7540     }
7541     if (!(flags & SVp_POK)) {
7542         if ((flags & SVTYPEMASK) < SVt_PVIV)
7543             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7544         SvIV_set(sv, -1);
7545         (void)SvIOK_only(sv);
7546         return;
7547     }
7548 #ifdef PERL_PRESERVE_IVUV
7549     {
7550         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7551         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7552             /* Need to try really hard to see if it's an integer.
7553                9.22337203685478e+18 is an integer.
7554                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7555                so $a="9.22337203685478e+18"; $a+0; $a--
7556                needs to be the same as $a="9.22337203685478e+18"; $a--
7557                or we go insane. */
7558
7559             (void) sv_2iv(sv);
7560             if (SvIOK(sv))
7561                 goto oops_its_int;
7562
7563             /* sv_2iv *should* have made this an NV */
7564             if (flags & SVp_NOK) {
7565                 (void)SvNOK_only(sv);
7566                 SvNV_set(sv, SvNVX(sv) - 1.0);
7567                 return;
7568             }
7569             /* I don't think we can get here. Maybe I should assert this
7570                And if we do get here I suspect that sv_setnv will croak. NWC
7571                Fall through. */
7572 #if defined(USE_LONG_DOUBLE)
7573             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",
7574                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7575 #else
7576             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7577                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7578 #endif
7579         }
7580     }
7581 #endif /* PERL_PRESERVE_IVUV */
7582     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);   /* punt */
7583 }
7584
7585 /* this define is used to eliminate a chunk of duplicated but shared logic
7586  * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
7587  * used anywhere but here - yves
7588  */
7589 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
7590     STMT_START {      \
7591         EXTEND_MORTAL(1); \
7592         PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
7593     } STMT_END
7594
7595 /*
7596 =for apidoc sv_mortalcopy
7597
7598 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7599 The new SV is marked as mortal. It will be destroyed "soon", either by an
7600 explicit call to FREETMPS, or by an implicit call at places such as
7601 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
7602
7603 =cut
7604 */
7605
7606 /* Make a string that will exist for the duration of the expression
7607  * evaluation.  Actually, it may have to last longer than that, but
7608  * hopefully we won't free it until it has been assigned to a
7609  * permanent location. */
7610
7611 SV *
7612 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7613 {
7614     dVAR;
7615     register SV *sv;
7616
7617     new_SV(sv);
7618     sv_setsv(sv,oldstr);
7619     PUSH_EXTEND_MORTAL__SV_C(sv);
7620     SvTEMP_on(sv);
7621     return sv;
7622 }
7623
7624 /*
7625 =for apidoc sv_newmortal
7626
7627 Creates a new null SV which is mortal.  The reference count of the SV is
7628 set to 1. It will be destroyed "soon", either by an explicit call to
7629 FREETMPS, or by an implicit call at places such as statement boundaries.
7630 See also C<sv_mortalcopy> and C<sv_2mortal>.
7631
7632 =cut
7633 */
7634
7635 SV *
7636 Perl_sv_newmortal(pTHX)
7637 {
7638     dVAR;
7639     register SV *sv;
7640
7641     new_SV(sv);
7642     SvFLAGS(sv) = SVs_TEMP;
7643     PUSH_EXTEND_MORTAL__SV_C(sv);
7644     return sv;
7645 }
7646
7647
7648 /*
7649 =for apidoc newSVpvn_flags
7650
7651 Creates a new SV and copies a string into it.  The reference count for the
7652 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7653 string.  You are responsible for ensuring that the source string is at least
7654 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7655 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7656 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7657 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
7658 C<SVf_UTF8> flag will be set on the new SV.
7659 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7660
7661     #define newSVpvn_utf8(s, len, u)                    \
7662         newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7663
7664 =cut
7665 */
7666
7667 SV *
7668 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7669 {
7670     dVAR;
7671     register SV *sv;
7672
7673     /* All the flags we don't support must be zero.
7674        And we're new code so I'm going to assert this from the start.  */
7675     assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7676     new_SV(sv);
7677     sv_setpvn(sv,s,len);
7678
7679     /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
7680      * and do what it does outselves here.
7681      * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
7682      * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
7683      * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
7684      * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
7685      */
7686
7687     SvFLAGS(sv) |= flags;
7688
7689     if(flags & SVs_TEMP){
7690         PUSH_EXTEND_MORTAL__SV_C(sv);
7691     }
7692
7693     return sv;
7694 }
7695
7696 /*
7697 =for apidoc sv_2mortal
7698
7699 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
7700 by an explicit call to FREETMPS, or by an implicit call at places such as
7701 statement boundaries.  SvTEMP() is turned on which means that the SV's
7702 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7703 and C<sv_mortalcopy>.
7704
7705 =cut
7706 */
7707
7708 SV *
7709 Perl_sv_2mortal(pTHX_ register SV *const sv)
7710 {
7711     dVAR;
7712     if (!sv)
7713         return NULL;
7714     if (SvREADONLY(sv) && SvIMMORTAL(sv))
7715         return sv;
7716     PUSH_EXTEND_MORTAL__SV_C(sv);
7717     SvTEMP_on(sv);
7718     return sv;
7719 }
7720
7721 /*
7722 =for apidoc newSVpv
7723
7724 Creates a new SV and copies a string into it.  The reference count for the
7725 SV is set to 1.  If C<len> is zero, Perl will compute the length using
7726 strlen().  For efficiency, consider using C<newSVpvn> instead.
7727
7728 =cut
7729 */
7730
7731 SV *
7732 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7733 {
7734     dVAR;
7735     register SV *sv;
7736
7737     new_SV(sv);
7738     sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7739     return sv;
7740 }
7741
7742 /*
7743 =for apidoc newSVpvn
7744
7745 Creates a new SV and copies a string into it.  The reference count for the
7746 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7747 string.  You are responsible for ensuring that the source string is at least
7748 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7749
7750 =cut
7751 */
7752
7753 SV *
7754 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7755 {
7756     dVAR;
7757     register SV *sv;
7758
7759     new_SV(sv);
7760     sv_setpvn(sv,s,len);
7761     return sv;
7762 }
7763
7764 /*
7765 =for apidoc newSVhek
7766
7767 Creates a new SV from the hash key structure.  It will generate scalars that
7768 point to the shared string table where possible. Returns a new (undefined)
7769 SV if the hek is NULL.
7770
7771 =cut
7772 */
7773
7774 SV *
7775 Perl_newSVhek(pTHX_ const HEK *const hek)
7776 {
7777     dVAR;
7778     if (!hek) {
7779         SV *sv;
7780
7781         new_SV(sv);
7782         return sv;
7783     }
7784
7785     if (HEK_LEN(hek) == HEf_SVKEY) {
7786         return newSVsv(*(SV**)HEK_KEY(hek));
7787     } else {
7788         const int flags = HEK_FLAGS(hek);
7789         if (flags & HVhek_WASUTF8) {
7790             /* Trouble :-)
7791                Andreas would like keys he put in as utf8 to come back as utf8
7792             */
7793             STRLEN utf8_len = HEK_LEN(hek);
7794             const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7795             SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7796
7797             SvUTF8_on (sv);
7798             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7799             return sv;
7800         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7801             /* We don't have a pointer to the hv, so we have to replicate the
7802                flag into every HEK. This hv is using custom a hasing
7803                algorithm. Hence we can't return a shared string scalar, as
7804                that would contain the (wrong) hash value, and might get passed
7805                into an hv routine with a regular hash.
7806                Similarly, a hash that isn't using shared hash keys has to have
7807                the flag in every key so that we know not to try to call
7808                share_hek_kek on it.  */
7809
7810             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7811             if (HEK_UTF8(hek))
7812                 SvUTF8_on (sv);
7813             return sv;
7814         }
7815         /* This will be overwhelminly the most common case.  */
7816         {
7817             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7818                more efficient than sharepvn().  */
7819             SV *sv;
7820
7821             new_SV(sv);
7822             sv_upgrade(sv, SVt_PV);
7823             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7824             SvCUR_set(sv, HEK_LEN(hek));
7825             SvLEN_set(sv, 0);
7826             SvREADONLY_on(sv);
7827             SvFAKE_on(sv);
7828             SvPOK_on(sv);
7829             if (HEK_UTF8(hek))
7830                 SvUTF8_on(sv);
7831             return sv;
7832         }
7833     }
7834 }
7835
7836 /*
7837 =for apidoc newSVpvn_share
7838
7839 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7840 table. If the string does not already exist in the table, it is created
7841 first.  Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7842 value is used; otherwise the hash is computed. The string's hash can be later
7843 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7844 that as the string table is used for shared hash keys these strings will have
7845 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7846
7847 =cut
7848 */
7849
7850 SV *
7851 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7852 {
7853     dVAR;
7854     register SV *sv;
7855     bool is_utf8 = FALSE;
7856     const char *const orig_src = src;
7857
7858     if (len < 0) {
7859         STRLEN tmplen = -len;
7860         is_utf8 = TRUE;
7861         /* See the note in hv.c:hv_fetch() --jhi */
7862         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7863         len = tmplen;
7864     }
7865     if (!hash)
7866         PERL_HASH(hash, src, len);
7867     new_SV(sv);
7868     /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7869        changes here, update it there too.  */
7870     sv_upgrade(sv, SVt_PV);
7871     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7872     SvCUR_set(sv, len);
7873     SvLEN_set(sv, 0);
7874     SvREADONLY_on(sv);
7875     SvFAKE_on(sv);
7876     SvPOK_on(sv);
7877     if (is_utf8)
7878         SvUTF8_on(sv);
7879     if (src != orig_src)
7880         Safefree(src);
7881     return sv;
7882 }
7883
7884
7885 #if defined(PERL_IMPLICIT_CONTEXT)
7886
7887 /* pTHX_ magic can't cope with varargs, so this is a no-context
7888  * version of the main function, (which may itself be aliased to us).
7889  * Don't access this version directly.
7890  */
7891
7892 SV *
7893 Perl_newSVpvf_nocontext(const char *const pat, ...)
7894 {
7895     dTHX;
7896     register SV *sv;
7897     va_list args;
7898
7899     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7900
7901     va_start(args, pat);
7902     sv = vnewSVpvf(pat, &args);
7903     va_end(args);
7904     return sv;
7905 }
7906 #endif
7907
7908 /*
7909 =for apidoc newSVpvf
7910
7911 Creates a new SV and initializes it with the string formatted like
7912 C<sprintf>.
7913
7914 =cut
7915 */
7916
7917 SV *
7918 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7919 {
7920     register SV *sv;
7921     va_list args;
7922
7923     PERL_ARGS_ASSERT_NEWSVPVF;
7924
7925     va_start(args, pat);
7926     sv = vnewSVpvf(pat, &args);
7927     va_end(args);
7928     return sv;
7929 }
7930
7931 /* backend for newSVpvf() and newSVpvf_nocontext() */
7932
7933 SV *
7934 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7935 {
7936     dVAR;
7937     register SV *sv;
7938
7939     PERL_ARGS_ASSERT_VNEWSVPVF;
7940
7941     new_SV(sv);
7942     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7943     return sv;
7944 }
7945
7946 /*
7947 =for apidoc newSVnv
7948
7949 Creates a new SV and copies a floating point value into it.
7950 The reference count for the SV is set to 1.
7951
7952 =cut
7953 */
7954
7955 SV *
7956 Perl_newSVnv(pTHX_ const NV n)
7957 {
7958     dVAR;
7959     register SV *sv;
7960
7961     new_SV(sv);
7962     sv_setnv(sv,n);
7963     return sv;
7964 }
7965
7966 /*
7967 =for apidoc newSViv
7968
7969 Creates a new SV and copies an integer into it.  The reference count for the
7970 SV is set to 1.
7971
7972 =cut
7973 */
7974
7975 SV *
7976 Perl_newSViv(pTHX_ const IV i)
7977 {
7978     dVAR;
7979     register SV *sv;
7980
7981     new_SV(sv);
7982     sv_setiv(sv,i);
7983     return sv;
7984 }
7985
7986 /*
7987 =for apidoc newSVuv
7988
7989 Creates a new SV and copies an unsigned integer into it.
7990 The reference count for the SV is set to 1.
7991
7992 =cut
7993 */
7994
7995 SV *
7996 Perl_newSVuv(pTHX_ const UV u)
7997 {
7998     dVAR;
7999     register SV *sv;
8000
8001     new_SV(sv);
8002     sv_setuv(sv,u);
8003     return sv;
8004 }
8005
8006 /*
8007 =for apidoc newSV_type
8008
8009 Creates a new SV, of the type specified.  The reference count for the new SV
8010 is set to 1.
8011
8012 =cut
8013 */
8014
8015 SV *
8016 Perl_newSV_type(pTHX_ const svtype type)
8017 {
8018     register SV *sv;
8019
8020     new_SV(sv);
8021     sv_upgrade(sv, type);
8022     return sv;
8023 }
8024
8025 /*
8026 =for apidoc newRV_noinc
8027
8028 Creates an RV wrapper for an SV.  The reference count for the original
8029 SV is B<not> incremented.
8030
8031 =cut
8032 */
8033
8034 SV *
8035 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8036 {
8037     dVAR;
8038     register SV *sv = newSV_type(SVt_IV);
8039
8040     PERL_ARGS_ASSERT_NEWRV_NOINC;
8041
8042     SvTEMP_off(tmpRef);
8043     SvRV_set(sv, tmpRef);
8044     SvROK_on(sv);
8045     return sv;
8046 }
8047
8048 /* newRV_inc is the official function name to use now.
8049  * newRV_inc is in fact #defined to newRV in sv.h
8050  */
8051
8052 SV *
8053 Perl_newRV(pTHX_ SV *const sv)
8054 {
8055     dVAR;
8056
8057     PERL_ARGS_ASSERT_NEWRV;
8058
8059     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8060 }
8061
8062 /*
8063 =for apidoc newSVsv
8064
8065 Creates a new SV which is an exact duplicate of the original SV.
8066 (Uses C<sv_setsv>).
8067
8068 =cut
8069 */
8070
8071 SV *
8072 Perl_newSVsv(pTHX_ register SV *const old)
8073 {
8074     dVAR;
8075     register SV *sv;
8076
8077     if (!old)
8078         return NULL;
8079     if (SvTYPE(old) == SVTYPEMASK) {
8080         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8081         return NULL;
8082     }
8083     new_SV(sv);
8084     /* SV_GMAGIC is the default for sv_setv()
8085        SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8086        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
8087     sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8088     return sv;
8089 }
8090
8091 /*
8092 =for apidoc sv_reset
8093
8094 Underlying implementation for the C<reset> Perl function.
8095 Note that the perl-level function is vaguely deprecated.
8096
8097 =cut
8098 */
8099
8100 void
8101 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8102 {
8103     dVAR;
8104     char todo[PERL_UCHAR_MAX+1];
8105
8106     PERL_ARGS_ASSERT_SV_RESET;
8107
8108     if (!stash)
8109         return;
8110
8111     if (!*s) {          /* reset ?? searches */
8112         MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8113         if (mg) {
8114             const U32 count = mg->mg_len / sizeof(PMOP**);
8115             PMOP **pmp = (PMOP**) mg->mg_ptr;
8116             PMOP *const *const end = pmp + count;
8117
8118             while (pmp < end) {
8119 #ifdef USE_ITHREADS
8120                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8121 #else
8122                 (*pmp)->op_pmflags &= ~PMf_USED;
8123 #endif
8124                 ++pmp;
8125             }
8126         }
8127         return;
8128     }
8129
8130     /* reset variables */
8131
8132     if (!HvARRAY(stash))
8133         return;
8134
8135     Zero(todo, 256, char);
8136     while (*s) {
8137         I32 max;
8138         I32 i = (unsigned char)*s;
8139         if (s[1] == '-') {
8140             s += 2;
8141         }
8142         max = (unsigned char)*s++;
8143         for ( ; i <= max; i++) {
8144             todo[i] = 1;
8145         }
8146         for (i = 0; i <= (I32) HvMAX(stash); i++) {
8147             HE *entry;
8148             for (entry = HvARRAY(stash)[i];
8149                  entry;
8150                  entry = HeNEXT(entry))
8151             {
8152                 register GV *gv;
8153                 register SV *sv;
8154
8155                 if (!todo[(U8)*HeKEY(entry)])
8156                     continue;
8157                 gv = MUTABLE_GV(HeVAL(entry));
8158                 sv = GvSV(gv);
8159                 if (sv) {
8160                     if (SvTHINKFIRST(sv)) {
8161                         if (!SvREADONLY(sv) && SvROK(sv))
8162                             sv_unref(sv);
8163                         /* XXX Is this continue a bug? Why should THINKFIRST
8164                            exempt us from resetting arrays and hashes?  */
8165                         continue;
8166                     }
8167                     SvOK_off(sv);
8168                     if (SvTYPE(sv) >= SVt_PV) {
8169                         SvCUR_set(sv, 0);
8170                         if (SvPVX_const(sv) != NULL)
8171                             *SvPVX(sv) = '\0';
8172                         SvTAINT(sv);
8173                     }
8174                 }
8175                 if (GvAV(gv)) {
8176                     av_clear(GvAV(gv));
8177                 }
8178                 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8179 #if defined(VMS)
8180                     Perl_die(aTHX_ "Can't reset %%ENV on this system");
8181 #else /* ! VMS */
8182                     hv_clear(GvHV(gv));
8183 #  if defined(USE_ENVIRON_ARRAY)
8184                     if (gv == PL_envgv)
8185                         my_clearenv();
8186 #  endif /* USE_ENVIRON_ARRAY */
8187 #endif /* VMS */
8188                 }
8189             }
8190         }
8191     }
8192 }
8193
8194 /*
8195 =for apidoc sv_2io
8196
8197 Using various gambits, try to get an IO from an SV: the IO slot if its a
8198 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8199 named after the PV if we're a string.
8200
8201 =cut
8202 */
8203
8204 IO*
8205 Perl_sv_2io(pTHX_ SV *const sv)
8206 {
8207     IO* io;
8208     GV* gv;
8209
8210     PERL_ARGS_ASSERT_SV_2IO;
8211
8212     switch (SvTYPE(sv)) {
8213     case SVt_PVIO:
8214         io = MUTABLE_IO(sv);
8215         break;
8216     case SVt_PVGV:
8217         if (isGV_with_GP(sv)) {
8218             gv = MUTABLE_GV(sv);
8219             io = GvIO(gv);
8220             if (!io)
8221                 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8222             break;
8223         }
8224         /* FALL THROUGH */
8225     default:
8226         if (!SvOK(sv))
8227             Perl_croak(aTHX_ PL_no_usym, "filehandle");
8228         if (SvROK(sv))
8229             return sv_2io(SvRV(sv));
8230         gv = gv_fetchsv(sv, 0, SVt_PVIO);
8231         if (gv)
8232             io = GvIO(gv);
8233         else
8234             io = 0;
8235         if (!io)
8236             Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8237         break;
8238     }
8239     return io;
8240 }
8241
8242 /*
8243 =for apidoc sv_2cv
8244
8245 Using various gambits, try to get a CV from an SV; in addition, try if
8246 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8247 The flags in C<lref> are passed to gv_fetchsv.
8248
8249 =cut
8250 */
8251
8252 CV *
8253 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8254 {
8255     dVAR;
8256     GV *gv = NULL;
8257     CV *cv = NULL;
8258
8259     PERL_ARGS_ASSERT_SV_2CV;
8260
8261     if (!sv) {
8262         *st = NULL;
8263         *gvp = NULL;
8264         return NULL;
8265     }
8266     switch (SvTYPE(sv)) {
8267     case SVt_PVCV:
8268         *st = CvSTASH(sv);
8269         *gvp = NULL;
8270         return MUTABLE_CV(sv);
8271     case SVt_PVHV:
8272     case SVt_PVAV:
8273         *st = NULL;
8274         *gvp = NULL;
8275         return NULL;
8276     case SVt_PVGV:
8277         if (isGV_with_GP(sv)) {
8278             gv = MUTABLE_GV(sv);
8279             *gvp = gv;
8280             *st = GvESTASH(gv);
8281             goto fix_gv;
8282         }
8283         /* FALL THROUGH */
8284
8285     default:
8286         if (SvROK(sv)) {
8287             SV * const *sp = &sv;       /* Used in tryAMAGICunDEREF macro. */
8288             SvGETMAGIC(sv);
8289             tryAMAGICunDEREF(to_cv);
8290
8291             sv = SvRV(sv);
8292             if (SvTYPE(sv) == SVt_PVCV) {
8293                 cv = MUTABLE_CV(sv);
8294                 *gvp = NULL;
8295                 *st = CvSTASH(cv);
8296                 return cv;
8297             }
8298             else if(isGV_with_GP(sv))
8299                 gv = MUTABLE_GV(sv);
8300             else
8301                 Perl_croak(aTHX_ "Not a subroutine reference");
8302         }
8303         else if (isGV_with_GP(sv)) {
8304             SvGETMAGIC(sv);
8305             gv = MUTABLE_GV(sv);
8306         }
8307         else
8308             gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8309         *gvp = gv;
8310         if (!gv) {
8311             *st = NULL;
8312             return NULL;
8313         }
8314         /* Some flags to gv_fetchsv mean don't really create the GV  */
8315         if (!isGV_with_GP(gv)) {
8316             *st = NULL;
8317             return NULL;
8318         }
8319         *st = GvESTASH(gv);
8320     fix_gv:
8321         if (lref && !GvCVu(gv)) {
8322             SV *tmpsv;
8323             ENTER;
8324             tmpsv = newSV(0);
8325             gv_efullname3(tmpsv, gv, NULL);
8326             /* XXX this is probably not what they think they're getting.
8327              * It has the same effect as "sub name;", i.e. just a forward
8328              * declaration! */
8329             newSUB(start_subparse(FALSE, 0),
8330                    newSVOP(OP_CONST, 0, tmpsv),
8331                    NULL, NULL);
8332             LEAVE;
8333             if (!GvCVu(gv))
8334                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8335                            SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8336         }
8337         return GvCVu(gv);
8338     }
8339 }
8340
8341 /*
8342 =for apidoc sv_true
8343
8344 Returns true if the SV has a true value by Perl's rules.
8345 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8346 instead use an in-line version.
8347
8348 =cut
8349 */
8350
8351 I32
8352 Perl_sv_true(pTHX_ register SV *const sv)
8353 {
8354     if (!sv)
8355         return 0;
8356     if (SvPOK(sv)) {
8357         register const XPV* const tXpv = (XPV*)SvANY(sv);
8358         if (tXpv &&
8359                 (tXpv->xpv_cur > 1 ||
8360                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8361             return 1;
8362         else
8363             return 0;
8364     }
8365     else {
8366         if (SvIOK(sv))
8367             return SvIVX(sv) != 0;
8368         else {
8369             if (SvNOK(sv))
8370                 return SvNVX(sv) != 0.0;
8371             else
8372                 return sv_2bool(sv);
8373         }
8374     }
8375 }
8376
8377 /*
8378 =for apidoc sv_pvn_force
8379
8380 Get a sensible string out of the SV somehow.
8381 A private implementation of the C<SvPV_force> macro for compilers which
8382 can't cope with complex macro expressions. Always use the macro instead.
8383
8384 =for apidoc sv_pvn_force_flags
8385
8386 Get a sensible string out of the SV somehow.
8387 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8388 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8389 implemented in terms of this function.
8390 You normally want to use the various wrapper macros instead: see
8391 C<SvPV_force> and C<SvPV_force_nomg>
8392
8393 =cut
8394 */
8395
8396 char *
8397 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8398 {
8399     dVAR;
8400
8401     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8402
8403     if (SvTHINKFIRST(sv) && !SvROK(sv))
8404         sv_force_normal_flags(sv, 0);
8405
8406     if (SvPOK(sv)) {
8407         if (lp)
8408             *lp = SvCUR(sv);
8409     }
8410     else {
8411         char *s;
8412         STRLEN len;
8413
8414         if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8415             const char * const ref = sv_reftype(sv,0);
8416             if (PL_op)
8417                 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8418                            ref, OP_DESC(PL_op));
8419             else
8420                 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8421         }
8422         if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8423             || isGV_with_GP(sv))
8424             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8425                 OP_DESC(PL_op));
8426         s = sv_2pv_flags(sv, &len, flags);
8427         if (lp)
8428             *lp = len;
8429
8430         if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
8431             if (SvROK(sv))
8432                 sv_unref(sv);
8433             SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
8434             SvGROW(sv, len + 1);
8435             Move(s,SvPVX(sv),len,char);
8436             SvCUR_set(sv, len);
8437             SvPVX(sv)[len] = '\0';
8438         }
8439         if (!SvPOK(sv)) {
8440             SvPOK_on(sv);               /* validate pointer */
8441             SvTAINT(sv);
8442             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8443                                   PTR2UV(sv),SvPVX_const(sv)));
8444         }
8445     }
8446     return SvPVX_mutable(sv);
8447 }
8448
8449 /*
8450 =for apidoc sv_pvbyten_force
8451
8452 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8453
8454 =cut
8455 */
8456
8457 char *
8458 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8459 {
8460     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8461
8462     sv_pvn_force(sv,lp);
8463     sv_utf8_downgrade(sv,0);
8464     *lp = SvCUR(sv);
8465     return SvPVX(sv);
8466 }
8467
8468 /*
8469 =for apidoc sv_pvutf8n_force
8470
8471 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8472
8473 =cut
8474 */
8475
8476 char *
8477 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8478 {
8479     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8480
8481     sv_pvn_force(sv,lp);
8482     sv_utf8_upgrade(sv);
8483     *lp = SvCUR(sv);
8484     return SvPVX(sv);
8485 }
8486
8487 /*
8488 =for apidoc sv_reftype
8489
8490 Returns a string describing what the SV is a reference to.
8491
8492 =cut
8493 */
8494
8495 const char *
8496 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8497 {
8498     PERL_ARGS_ASSERT_SV_REFTYPE;
8499
8500     /* The fact that I don't need to downcast to char * everywhere, only in ?:
8501        inside return suggests a const propagation bug in g++.  */
8502     if (ob && SvOBJECT(sv)) {
8503         char * const name = HvNAME_get(SvSTASH(sv));
8504         return name ? name : (char *) "__ANON__";
8505     }
8506     else {
8507         switch (SvTYPE(sv)) {
8508         case SVt_NULL:
8509         case SVt_IV:
8510         case SVt_NV:
8511         case SVt_PV:
8512         case SVt_PVIV:
8513         case SVt_PVNV:
8514         case SVt_PVMG:
8515                                 if (SvVOK(sv))
8516                                     return "VSTRING";
8517                                 if (SvROK(sv))
8518                                     return "REF";
8519                                 else
8520                                     return "SCALAR";
8521
8522         case SVt_PVLV:          return (char *)  (SvROK(sv) ? "REF"
8523                                 /* tied lvalues should appear to be
8524                                  * scalars for backwards compatitbility */
8525                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8526                                     ? "SCALAR" : "LVALUE");
8527         case SVt_PVAV:          return "ARRAY";
8528         case SVt_PVHV:          return "HASH";
8529         case SVt_PVCV:          return "CODE";
8530         case SVt_PVGV:          return (char *) (isGV_with_GP(sv)
8531                                     ? "GLOB" : "SCALAR");
8532         case SVt_PVFM:          return "FORMAT";
8533         case SVt_PVIO:          return "IO";
8534         case SVt_BIND:          return "BIND";
8535         case SVt_REGEXP:        return "REGEXP";
8536         default:                return "UNKNOWN";
8537         }
8538     }
8539 }
8540
8541 /*
8542 =for apidoc sv_isobject
8543
8544 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8545 object.  If the SV is not an RV, or if the object is not blessed, then this
8546 will return false.
8547
8548 =cut
8549 */
8550
8551 int
8552 Perl_sv_isobject(pTHX_ SV *sv)
8553 {
8554     if (!sv)
8555         return 0;
8556     SvGETMAGIC(sv);
8557     if (!SvROK(sv))
8558         return 0;
8559     sv = SvRV(sv);
8560     if (!SvOBJECT(sv))
8561         return 0;
8562     return 1;
8563 }
8564
8565 /*
8566 =for apidoc sv_isa
8567
8568 Returns a boolean indicating whether the SV is blessed into the specified
8569 class.  This does not check for subtypes; use C<sv_derived_from> to verify
8570 an inheritance relationship.
8571
8572 =cut
8573 */
8574
8575 int
8576 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8577 {
8578     const char *hvname;
8579
8580     PERL_ARGS_ASSERT_SV_ISA;
8581
8582     if (!sv)
8583         return 0;
8584     SvGETMAGIC(sv);
8585     if (!SvROK(sv))
8586         return 0;
8587     sv = SvRV(sv);
8588     if (!SvOBJECT(sv))
8589         return 0;
8590     hvname = HvNAME_get(SvSTASH(sv));
8591     if (!hvname)
8592         return 0;
8593
8594     return strEQ(hvname, name);
8595 }
8596
8597 /*
8598 =for apidoc newSVrv
8599
8600 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
8601 it will be upgraded to one.  If C<classname> is non-null then the new SV will
8602 be blessed in the specified package.  The new SV is returned and its
8603 reference count is 1.
8604
8605 =cut
8606 */
8607
8608 SV*
8609 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8610 {
8611     dVAR;
8612     SV *sv;
8613
8614     PERL_ARGS_ASSERT_NEWSVRV;
8615
8616     new_SV(sv);
8617
8618     SV_CHECK_THINKFIRST_COW_DROP(rv);
8619     (void)SvAMAGIC_off(rv);
8620
8621     if (SvTYPE(rv) >= SVt_PVMG) {
8622         const U32 refcnt = SvREFCNT(rv);
8623         SvREFCNT(rv) = 0;
8624         sv_clear(rv);
8625         SvFLAGS(rv) = 0;
8626         SvREFCNT(rv) = refcnt;
8627
8628         sv_upgrade(rv, SVt_IV);
8629     } else if (SvROK(rv)) {
8630         SvREFCNT_dec(SvRV(rv));
8631     } else {
8632         prepare_SV_for_RV(rv);
8633     }
8634
8635     SvOK_off(rv);
8636     SvRV_set(rv, sv);
8637     SvROK_on(rv);
8638
8639     if (classname) {
8640         HV* const stash = gv_stashpv(classname, GV_ADD);
8641         (void)sv_bless(rv, stash);
8642     }
8643     return sv;
8644 }
8645
8646 /*
8647 =for apidoc sv_setref_pv
8648
8649 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
8650 argument will be upgraded to an RV.  That RV will be modified to point to
8651 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8652 into the SV.  The C<classname> argument indicates the package for the
8653 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8654 will have a reference count of 1, and the RV will be returned.
8655
8656 Do not use with other Perl types such as HV, AV, SV, CV, because those
8657 objects will become corrupted by the pointer copy process.
8658
8659 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8660
8661 =cut
8662 */
8663
8664 SV*
8665 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8666 {
8667     dVAR;
8668
8669     PERL_ARGS_ASSERT_SV_SETREF_PV;
8670
8671     if (!pv) {
8672         sv_setsv(rv, &PL_sv_undef);
8673         SvSETMAGIC(rv);
8674     }
8675     else
8676         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8677     return rv;
8678 }
8679
8680 /*
8681 =for apidoc sv_setref_iv
8682
8683 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
8684 argument will be upgraded to an RV.  That RV will be modified to point to
8685 the new SV.  The C<classname> argument indicates the package for the
8686 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8687 will have a reference count of 1, and the RV will be returned.
8688
8689 =cut
8690 */
8691
8692 SV*
8693 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8694 {
8695     PERL_ARGS_ASSERT_SV_SETREF_IV;
8696
8697     sv_setiv(newSVrv(rv,classname), iv);
8698     return rv;
8699 }
8700
8701 /*
8702 =for apidoc sv_setref_uv
8703
8704 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
8705 argument will be upgraded to an RV.  That RV will be modified to point to
8706 the new SV.  The C<classname> argument indicates the package for the
8707 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8708 will have a reference count of 1, and the RV will be returned.
8709
8710 =cut
8711 */
8712
8713 SV*
8714 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8715 {
8716     PERL_ARGS_ASSERT_SV_SETREF_UV;
8717
8718     sv_setuv(newSVrv(rv,classname), uv);
8719     return rv;
8720 }
8721
8722 /*
8723 =for apidoc sv_setref_nv
8724
8725 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
8726 argument will be upgraded to an RV.  That RV will be modified to point to
8727 the new SV.  The C<classname> argument indicates the package for the
8728 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8729 will have a reference count of 1, and the RV will be returned.
8730
8731 =cut
8732 */
8733
8734 SV*
8735 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8736 {
8737     PERL_ARGS_ASSERT_SV_SETREF_NV;
8738
8739     sv_setnv(newSVrv(rv,classname), nv);
8740     return rv;
8741 }
8742
8743 /*
8744 =for apidoc sv_setref_pvn
8745
8746 Copies a string into a new SV, optionally blessing the SV.  The length of the
8747 string must be specified with C<n>.  The C<rv> argument will be upgraded to
8748 an RV.  That RV will be modified to point to the new SV.  The C<classname>
8749 argument indicates the package for the blessing.  Set C<classname> to
8750 C<NULL> to avoid the blessing.  The new SV will have a reference count
8751 of 1, and the RV will be returned.
8752
8753 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8754
8755 =cut
8756 */
8757
8758 SV*
8759 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8760                    const char *const pv, const STRLEN n)
8761 {
8762     PERL_ARGS_ASSERT_SV_SETREF_PVN;
8763
8764     sv_setpvn(newSVrv(rv,classname), pv, n);
8765     return rv;
8766 }
8767
8768 /*
8769 =for apidoc sv_bless
8770
8771 Blesses an SV into a specified package.  The SV must be an RV.  The package
8772 must be designated by its stash (see C<gv_stashpv()>).  The reference count
8773 of the SV is unaffected.
8774
8775 =cut
8776 */
8777
8778 SV*
8779 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8780 {
8781     dVAR;
8782     SV *tmpRef;
8783
8784     PERL_ARGS_ASSERT_SV_BLESS;
8785
8786     if (!SvROK(sv))
8787         Perl_croak(aTHX_ "Can't bless non-reference value");
8788     tmpRef = SvRV(sv);
8789     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8790         if (SvIsCOW(tmpRef))
8791             sv_force_normal_flags(tmpRef, 0);
8792         if (SvREADONLY(tmpRef))
8793             Perl_croak(aTHX_ "%s", PL_no_modify);
8794         if (SvOBJECT(tmpRef)) {
8795             if (SvTYPE(tmpRef) != SVt_PVIO)
8796                 --PL_sv_objcount;
8797             SvREFCNT_dec(SvSTASH(tmpRef));
8798         }
8799     }
8800     SvOBJECT_on(tmpRef);
8801     if (SvTYPE(tmpRef) != SVt_PVIO)
8802         ++PL_sv_objcount;
8803     SvUPGRADE(tmpRef, SVt_PVMG);
8804     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8805
8806     if (Gv_AMG(stash))
8807         SvAMAGIC_on(sv);
8808     else
8809         (void)SvAMAGIC_off(sv);
8810
8811     if(SvSMAGICAL(tmpRef))
8812         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8813             mg_set(tmpRef);
8814
8815
8816
8817     return sv;
8818 }
8819
8820 /* Downgrades a PVGV to a PVMG.
8821  */
8822
8823 STATIC void
8824 S_sv_unglob(pTHX_ SV *const sv)
8825 {
8826     dVAR;
8827     void *xpvmg;
8828     HV *stash;
8829     SV * const temp = sv_newmortal();
8830
8831     PERL_ARGS_ASSERT_SV_UNGLOB;
8832
8833     assert(SvTYPE(sv) == SVt_PVGV);
8834     SvFAKE_off(sv);
8835     gv_efullname3(temp, MUTABLE_GV(sv), "*");
8836
8837     if (GvGP(sv)) {
8838         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
8839            && HvNAME_get(stash))
8840             mro_method_changed_in(stash);
8841         gp_free(MUTABLE_GV(sv));
8842     }
8843     if (GvSTASH(sv)) {
8844         sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
8845         GvSTASH(sv) = NULL;
8846     }
8847     GvMULTI_off(sv);
8848     if (GvNAME_HEK(sv)) {
8849         unshare_hek(GvNAME_HEK(sv));
8850     }
8851     isGV_with_GP_off(sv);
8852
8853     /* need to keep SvANY(sv) in the right arena */
8854     xpvmg = new_XPVMG();
8855     StructCopy(SvANY(sv), xpvmg, XPVMG);
8856     del_XPVGV(SvANY(sv));
8857     SvANY(sv) = xpvmg;
8858
8859     SvFLAGS(sv) &= ~SVTYPEMASK;
8860     SvFLAGS(sv) |= SVt_PVMG;
8861
8862     /* Intentionally not calling any local SET magic, as this isn't so much a
8863        set operation as merely an internal storage change.  */
8864     sv_setsv_flags(sv, temp, 0);
8865 }
8866
8867 /*
8868 =for apidoc sv_unref_flags
8869
8870 Unsets the RV status of the SV, and decrements the reference count of
8871 whatever was being referenced by the RV.  This can almost be thought of
8872 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
8873 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8874 (otherwise the decrementing is conditional on the reference count being
8875 different from one or the reference being a readonly SV).
8876 See C<SvROK_off>.
8877
8878 =cut
8879 */
8880
8881 void
8882 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8883 {
8884     SV* const target = SvRV(ref);
8885
8886     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8887
8888     if (SvWEAKREF(ref)) {
8889         sv_del_backref(target, ref);
8890         SvWEAKREF_off(ref);
8891         SvRV_set(ref, NULL);
8892         return;
8893     }
8894     SvRV_set(ref, NULL);
8895     SvROK_off(ref);
8896     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8897        assigned to as BEGIN {$a = \"Foo"} will fail.  */
8898     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8899         SvREFCNT_dec(target);
8900     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8901         sv_2mortal(target);     /* Schedule for freeing later */
8902 }
8903
8904 /*
8905 =for apidoc sv_untaint
8906
8907 Untaint an SV. Use C<SvTAINTED_off> instead.
8908 =cut
8909 */
8910
8911 void
8912 Perl_sv_untaint(pTHX_ SV *const sv)
8913 {
8914     PERL_ARGS_ASSERT_SV_UNTAINT;
8915
8916     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8917         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8918         if (mg)
8919             mg->mg_len &= ~1;
8920     }
8921 }
8922
8923 /*
8924 =for apidoc sv_tainted
8925
8926 Test an SV for taintedness. Use C<SvTAINTED> instead.
8927 =cut
8928 */
8929
8930 bool
8931 Perl_sv_tainted(pTHX_ SV *const sv)
8932 {
8933     PERL_ARGS_ASSERT_SV_TAINTED;
8934
8935     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8936         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8937         if (mg && (mg->mg_len & 1) )
8938             return TRUE;
8939     }
8940     return FALSE;
8941 }
8942
8943 /*
8944 =for apidoc sv_setpviv
8945
8946 Copies an integer into the given SV, also updating its string value.
8947 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
8948
8949 =cut
8950 */
8951
8952 void
8953 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8954 {
8955     char buf[TYPE_CHARS(UV)];
8956     char *ebuf;
8957     char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8958
8959     PERL_ARGS_ASSERT_SV_SETPVIV;
8960
8961     sv_setpvn(sv, ptr, ebuf - ptr);
8962 }
8963
8964 /*
8965 =for apidoc sv_setpviv_mg
8966
8967 Like C<sv_setpviv>, but also handles 'set' magic.
8968
8969 =cut
8970 */
8971
8972 void
8973 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8974 {
8975     PERL_ARGS_ASSERT_SV_SETPVIV_MG;
8976
8977     sv_setpviv(sv, iv);
8978     SvSETMAGIC(sv);
8979 }
8980
8981 #if defined(PERL_IMPLICIT_CONTEXT)
8982
8983 /* pTHX_ magic can't cope with varargs, so this is a no-context
8984  * version of the main function, (which may itself be aliased to us).
8985  * Don't access this version directly.
8986  */
8987
8988 void
8989 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
8990 {
8991     dTHX;
8992     va_list args;
8993
8994     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
8995
8996     va_start(args, pat);
8997     sv_vsetpvf(sv, pat, &args);
8998     va_end(args);
8999 }
9000
9001 /* pTHX_ magic can't cope with varargs, so this is a no-context
9002  * version of the main function, (which may itself be aliased to us).
9003  * Don't access this version directly.
9004  */
9005
9006 void
9007 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9008 {
9009     dTHX;
9010     va_list args;
9011
9012     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9013
9014     va_start(args, pat);
9015     sv_vsetpvf_mg(sv, pat, &args);
9016     va_end(args);
9017 }
9018 #endif
9019
9020 /*
9021 =for apidoc sv_setpvf
9022
9023 Works like C<sv_catpvf> but copies the text into the SV instead of
9024 appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
9025
9026 =cut
9027 */
9028
9029 void
9030 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9031 {
9032     va_list args;
9033
9034     PERL_ARGS_ASSERT_SV_SETPVF;
9035
9036     va_start(args, pat);
9037     sv_vsetpvf(sv, pat, &args);
9038     va_end(args);
9039 }
9040
9041 /*
9042 =for apidoc sv_vsetpvf
9043
9044 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9045 appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
9046
9047 Usually used via its frontend C<sv_setpvf>.
9048
9049 =cut
9050 */
9051
9052 void
9053 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9054 {
9055     PERL_ARGS_ASSERT_SV_VSETPVF;
9056
9057     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9058 }
9059
9060 /*
9061 =for apidoc sv_setpvf_mg
9062
9063 Like C<sv_setpvf>, but also handles 'set' magic.
9064
9065 =cut
9066 */
9067
9068 void
9069 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9070 {
9071     va_list args;
9072
9073     PERL_ARGS_ASSERT_SV_SETPVF_MG;
9074
9075     va_start(args, pat);
9076     sv_vsetpvf_mg(sv, pat, &args);
9077     va_end(args);
9078 }
9079
9080 /*
9081 =for apidoc sv_vsetpvf_mg
9082
9083 Like C<sv_vsetpvf>, but also handles 'set' magic.
9084
9085 Usually used via its frontend C<sv_setpvf_mg>.
9086
9087 =cut
9088 */
9089
9090 void
9091 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9092 {
9093     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9094
9095     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9096     SvSETMAGIC(sv);
9097 }
9098
9099 #if defined(PERL_IMPLICIT_CONTEXT)
9100
9101 /* pTHX_ magic can't cope with varargs, so this is a no-context
9102  * version of the main function, (which may itself be aliased to us).
9103  * Don't access this version directly.
9104  */
9105
9106 void
9107 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9108 {
9109     dTHX;
9110     va_list args;
9111
9112     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9113
9114     va_start(args, pat);
9115     sv_vcatpvf(sv, pat, &args);
9116     va_end(args);
9117 }
9118
9119 /* pTHX_ magic can't cope with varargs, so this is a no-context
9120  * version of the main function, (which may itself be aliased to us).
9121  * Don't access this version directly.
9122  */
9123
9124 void
9125 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9126 {
9127     dTHX;
9128     va_list args;
9129
9130     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9131
9132     va_start(args, pat);
9133     sv_vcatpvf_mg(sv, pat, &args);
9134     va_end(args);
9135 }
9136 #endif
9137
9138 /*
9139 =for apidoc sv_catpvf
9140
9141 Processes its arguments like C<sprintf> and appends the formatted
9142 output to an SV.  If the appended data contains "wide" characters
9143 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9144 and characters >255 formatted with %c), the original SV might get
9145 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
9146 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9147 valid UTF-8; if the original SV was bytes, the pattern should be too.
9148
9149 =cut */
9150
9151 void
9152 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9153 {
9154     va_list args;
9155
9156     PERL_ARGS_ASSERT_SV_CATPVF;
9157
9158     va_start(args, pat);
9159     sv_vcatpvf(sv, pat, &args);
9160     va_end(args);
9161 }
9162
9163 /*
9164 =for apidoc sv_vcatpvf
9165
9166 Processes its arguments like C<vsprintf> and appends the formatted output
9167 to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
9168
9169 Usually used via its frontend C<sv_catpvf>.
9170
9171 =cut
9172 */
9173
9174 void
9175 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9176 {
9177     PERL_ARGS_ASSERT_SV_VCATPVF;
9178
9179     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9180 }
9181
9182 /*
9183 =for apidoc sv_catpvf_mg
9184
9185 Like C<sv_catpvf>, but also handles 'set' magic.
9186
9187 =cut
9188 */
9189
9190 void
9191 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9192 {
9193     va_list args;
9194
9195     PERL_ARGS_ASSERT_SV_CATPVF_MG;
9196
9197     va_start(args, pat);
9198     sv_vcatpvf_mg(sv, pat, &args);
9199     va_end(args);
9200 }
9201
9202 /*
9203 =for apidoc sv_vcatpvf_mg
9204
9205 Like C<sv_vcatpvf>, but also handles 'set' magic.
9206
9207 Usually used via its frontend C<sv_catpvf_mg>.
9208
9209 =cut
9210 */
9211
9212 void
9213 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9214 {
9215     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9216
9217     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9218     SvSETMAGIC(sv);
9219 }
9220
9221 /*
9222 =for apidoc sv_vsetpvfn
9223
9224 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9225 appending it.
9226
9227 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9228
9229 =cut
9230 */
9231
9232 void
9233 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9234                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9235 {
9236     PERL_ARGS_ASSERT_SV_VSETPVFN;
9237
9238     sv_setpvs(sv, "");
9239     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9240 }
9241
9242
9243 /*
9244  * Warn of missing argument to sprintf, and then return a defined value
9245  * to avoid inappropriate "use of uninit" warnings [perl #71000].
9246  */
9247 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9248 STATIC SV*
9249 S_vcatpvfn_missing_argument(pTHX) {
9250     if (ckWARN(WARN_MISSING)) {
9251         Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9252                 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9253     }
9254     return &PL_sv_no;
9255 }
9256
9257
9258 STATIC I32
9259 S_expect_number(pTHX_ char **const pattern)
9260 {
9261     dVAR;
9262     I32 var = 0;
9263
9264     PERL_ARGS_ASSERT_EXPECT_NUMBER;
9265
9266     switch (**pattern) {
9267     case '1': case '2': case '3':
9268     case '4': case '5': case '6':
9269     case '7': case '8': case '9':
9270         var = *(*pattern)++ - '0';
9271         while (isDIGIT(**pattern)) {
9272             const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9273             if (tmp < var)
9274                 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9275             var = tmp;
9276         }
9277     }
9278     return var;
9279 }
9280
9281 STATIC char *
9282 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9283 {
9284     const int neg = nv < 0;
9285     UV uv;
9286
9287     PERL_ARGS_ASSERT_F0CONVERT;
9288
9289     if (neg)
9290         nv = -nv;
9291     if (nv < UV_MAX) {
9292         char *p = endbuf;
9293         nv += 0.5;
9294         uv = (UV)nv;
9295         if (uv & 1 && uv == nv)
9296             uv--;                       /* Round to even */
9297         do {
9298             const unsigned dig = uv % 10;
9299             *--p = '0' + dig;
9300         } while (uv /= 10);
9301         if (neg)
9302             *--p = '-';
9303         *len = endbuf - p;
9304         return p;
9305     }
9306     return NULL;
9307 }
9308
9309
9310 /*
9311 =for apidoc sv_vcatpvfn
9312
9313 Processes its arguments like C<vsprintf> and appends the formatted output
9314 to an SV.  Uses an array of SVs if the C style variable argument list is
9315 missing (NULL).  When running with taint checks enabled, indicates via
9316 C<maybe_tainted> if results are untrustworthy (often due to the use of
9317 locales).
9318
9319 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9320
9321 =cut
9322 */
9323
9324
9325 #define VECTORIZE_ARGS  vecsv = va_arg(*args, SV*);\
9326                         vecstr = (U8*)SvPV_const(vecsv,veclen);\
9327                         vec_utf8 = DO_UTF8(vecsv);
9328
9329 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9330
9331 void
9332 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9333                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9334 {
9335     dVAR;
9336     char *p;
9337     char *q;
9338     const char *patend;
9339     STRLEN origlen;
9340     I32 svix = 0;
9341     static const char nullstr[] = "(null)";
9342     SV *argsv = NULL;
9343     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
9344     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9345     SV *nsv = NULL;
9346     /* Times 4: a decimal digit takes more than 3 binary digits.
9347      * NV_DIG: mantissa takes than many decimal digits.
9348      * Plus 32: Playing safe. */
9349     char ebuf[IV_DIG * 4 + NV_DIG + 32];
9350     /* large enough for "%#.#f" --chip */
9351     /* what about long double NVs? --jhi */
9352
9353     PERL_ARGS_ASSERT_SV_VCATPVFN;
9354     PERL_UNUSED_ARG(maybe_tainted);
9355
9356     /* no matter what, this is a string now */
9357     (void)SvPV_force(sv, origlen);
9358
9359     /* special-case "", "%s", and "%-p" (SVf - see below) */
9360     if (patlen == 0)
9361         return;
9362     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9363         if (args) {
9364             const char * const s = va_arg(*args, char*);
9365             sv_catpv(sv, s ? s : nullstr);
9366         }
9367         else if (svix < svmax) {
9368             sv_catsv(sv, *svargs);
9369         }
9370         return;
9371     }
9372     if (args && patlen == 3 && pat[0] == '%' &&
9373                 pat[1] == '-' && pat[2] == 'p') {
9374         argsv = MUTABLE_SV(va_arg(*args, void*));
9375         sv_catsv(sv, argsv);
9376         return;
9377     }
9378
9379 #ifndef USE_LONG_DOUBLE
9380     /* special-case "%.<number>[gf]" */
9381     if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9382          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9383         unsigned digits = 0;
9384         const char *pp;
9385
9386         pp = pat + 2;
9387         while (*pp >= '0' && *pp <= '9')
9388             digits = 10 * digits + (*pp++ - '0');
9389         if (pp - pat == (int)patlen - 1) {
9390             NV nv;
9391
9392             if (svix < svmax)
9393                 nv = SvNV(*svargs);
9394             else
9395                 return;
9396             if (*pp == 'g') {
9397                 /* Add check for digits != 0 because it seems that some
9398                    gconverts are buggy in this case, and we don't yet have
9399                    a Configure test for this.  */
9400                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9401                      /* 0, point, slack */
9402                     Gconvert(nv, (int)digits, 0, ebuf);
9403                     sv_catpv(sv, ebuf);
9404                     if (*ebuf)  /* May return an empty string for digits==0 */
9405                         return;
9406                 }
9407             } else if (!digits) {
9408                 STRLEN l;
9409
9410                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9411                     sv_catpvn(sv, p, l);
9412                     return;
9413                 }
9414             }
9415         }
9416     }
9417 #endif /* !USE_LONG_DOUBLE */
9418
9419     if (!args && svix < svmax && DO_UTF8(*svargs))
9420         has_utf8 = TRUE;
9421
9422     patend = (char*)pat + patlen;
9423     for (p = (char*)pat; p < patend; p = q) {
9424         bool alt = FALSE;
9425         bool left = FALSE;
9426         bool vectorize = FALSE;
9427         bool vectorarg = FALSE;
9428         bool vec_utf8 = FALSE;
9429         char fill = ' ';
9430         char plus = 0;
9431         char intsize = 0;
9432         STRLEN width = 0;
9433         STRLEN zeros = 0;
9434         bool has_precis = FALSE;
9435         STRLEN precis = 0;
9436         const I32 osvix = svix;
9437         bool is_utf8 = FALSE;  /* is this item utf8?   */
9438 #ifdef HAS_LDBL_SPRINTF_BUG
9439         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9440            with sfio - Allen <allens@cpan.org> */
9441         bool fix_ldbl_sprintf_bug = FALSE;
9442 #endif
9443
9444         char esignbuf[4];
9445         U8 utf8buf[UTF8_MAXBYTES+1];
9446         STRLEN esignlen = 0;
9447
9448         const char *eptr = NULL;
9449         const char *fmtstart;
9450         STRLEN elen = 0;
9451         SV *vecsv = NULL;
9452         const U8 *vecstr = NULL;
9453         STRLEN veclen = 0;
9454         char c = 0;
9455         int i;
9456         unsigned base = 0;
9457         IV iv = 0;
9458         UV uv = 0;
9459         /* we need a long double target in case HAS_LONG_DOUBLE but
9460            not USE_LONG_DOUBLE
9461         */
9462 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9463         long double nv;
9464 #else
9465         NV nv;
9466 #endif
9467         STRLEN have;
9468         STRLEN need;
9469         STRLEN gap;
9470         const char *dotstr = ".";
9471         STRLEN dotstrlen = 1;
9472         I32 efix = 0; /* explicit format parameter index */
9473         I32 ewix = 0; /* explicit width index */
9474         I32 epix = 0; /* explicit precision index */
9475         I32 evix = 0; /* explicit vector index */
9476         bool asterisk = FALSE;
9477
9478         /* echo everything up to the next format specification */
9479         for (q = p; q < patend && *q != '%'; ++q) ;
9480         if (q > p) {
9481             if (has_utf8 && !pat_utf8)
9482                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9483             else
9484                 sv_catpvn(sv, p, q - p);
9485             p = q;
9486         }
9487         if (q++ >= patend)
9488             break;
9489
9490         fmtstart = q;
9491
9492 /*
9493     We allow format specification elements in this order:
9494         \d+\$              explicit format parameter index
9495         [-+ 0#]+           flags
9496         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
9497         0                  flag (as above): repeated to allow "v02"
9498         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
9499         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9500         [hlqLV]            size
9501     [%bcdefginopsuxDFOUX] format (mandatory)
9502 */
9503
9504         if (args) {
9505 /*
9506         As of perl5.9.3, printf format checking is on by default.
9507         Internally, perl uses %p formats to provide an escape to
9508         some extended formatting.  This block deals with those
9509         extensions: if it does not match, (char*)q is reset and
9510         the normal format processing code is used.
9511
9512         Currently defined extensions are:
9513                 %p              include pointer address (standard)
9514                 %-p     (SVf)   include an SV (previously %_)
9515                 %-<num>p        include an SV with precision <num>
9516                 %<num>p         reserved for future extensions
9517
9518         Robin Barker 2005-07-14
9519
9520                 %1p     (VDf)   removed.  RMB 2007-10-19
9521 */
9522             char* r = q;
9523             bool sv = FALSE;
9524             STRLEN n = 0;
9525             if (*q == '-')
9526                 sv = *q++;
9527             n = expect_number(&q);
9528             if (*q++ == 'p') {
9529                 if (sv) {                       /* SVf */
9530                     if (n) {
9531                         precis = n;
9532                         has_precis = TRUE;
9533                     }
9534                     argsv = MUTABLE_SV(va_arg(*args, void*));
9535                     eptr = SvPV_const(argsv, elen);
9536                     if (DO_UTF8(argsv))
9537                         is_utf8 = TRUE;
9538                     goto string;
9539                 }
9540                 else if (n) {
9541                     Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
9542                                      "internal %%<num>p might conflict with future printf extensions");
9543                 }
9544             }
9545             q = r;
9546         }
9547
9548         if ( (width = expect_number(&q)) ) {
9549             if (*q == '$') {
9550                 ++q;
9551                 efix = width;
9552             } else {
9553                 goto gotwidth;
9554             }
9555         }
9556
9557         /* FLAGS */
9558
9559         while (*q) {
9560             switch (*q) {
9561             case ' ':
9562             case '+':
9563                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9564                     q++;
9565                 else
9566                     plus = *q++;
9567                 continue;
9568
9569             case '-':
9570                 left = TRUE;
9571                 q++;
9572                 continue;
9573
9574             case '0':
9575                 fill = *q++;
9576                 continue;
9577
9578             case '#':
9579                 alt = TRUE;
9580                 q++;
9581                 continue;
9582
9583             default:
9584                 break;
9585             }
9586             break;
9587         }
9588
9589       tryasterisk:
9590         if (*q == '*') {
9591             q++;
9592             if ( (ewix = expect_number(&q)) )
9593                 if (*q++ != '$')
9594                     goto unknown;
9595             asterisk = TRUE;
9596         }
9597         if (*q == 'v') {
9598             q++;
9599             if (vectorize)
9600                 goto unknown;
9601             if ((vectorarg = asterisk)) {
9602                 evix = ewix;
9603                 ewix = 0;
9604                 asterisk = FALSE;
9605             }
9606             vectorize = TRUE;
9607             goto tryasterisk;
9608         }
9609
9610         if (!asterisk)
9611         {
9612             if( *q == '0' )
9613                 fill = *q++;
9614             width = expect_number(&q);
9615         }
9616
9617         if (vectorize) {
9618             if (vectorarg) {
9619                 if (args)
9620                     vecsv = va_arg(*args, SV*);
9621                 else if (evix) {
9622                     vecsv = (evix > 0 && evix <= svmax)
9623                         ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
9624                 } else {
9625                     vecsv = svix < svmax
9626                         ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9627                 }
9628                 dotstr = SvPV_const(vecsv, dotstrlen);
9629                 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9630                    bad with tied or overloaded values that return UTF8.  */
9631                 if (DO_UTF8(vecsv))
9632                     is_utf8 = TRUE;
9633                 else if (has_utf8) {
9634                     vecsv = sv_mortalcopy(vecsv);
9635                     sv_utf8_upgrade(vecsv);
9636                     dotstr = SvPV_const(vecsv, dotstrlen);
9637                     is_utf8 = TRUE;
9638                 }
9639             }
9640             if (args) {
9641                 VECTORIZE_ARGS
9642             }
9643             else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9644                 vecsv = svargs[efix ? efix-1 : svix++];
9645                 vecstr = (U8*)SvPV_const(vecsv,veclen);
9646                 vec_utf8 = DO_UTF8(vecsv);
9647
9648                 /* if this is a version object, we need to convert
9649                  * back into v-string notation and then let the
9650                  * vectorize happen normally
9651                  */
9652                 if (sv_derived_from(vecsv, "version")) {
9653                     char *version = savesvpv(vecsv);
9654                     if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9655                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9656                         "vector argument not supported with alpha versions");
9657                         goto unknown;
9658                     }
9659                     vecsv = sv_newmortal();
9660                     scan_vstring(version, version + veclen, vecsv);
9661                     vecstr = (U8*)SvPV_const(vecsv, veclen);
9662                     vec_utf8 = DO_UTF8(vecsv);
9663                     Safefree(version);
9664                 }
9665             }
9666             else {
9667                 vecstr = (U8*)"";
9668                 veclen = 0;
9669             }
9670         }
9671
9672         if (asterisk) {
9673             if (args)
9674                 i = va_arg(*args, int);
9675             else
9676                 i = (ewix ? ewix <= svmax : svix < svmax) ?
9677                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9678             left |= (i < 0);
9679             width = (i < 0) ? -i : i;
9680         }
9681       gotwidth:
9682
9683         /* PRECISION */
9684
9685         if (*q == '.') {
9686             q++;
9687             if (*q == '*') {
9688                 q++;
9689                 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9690                     goto unknown;
9691                 /* XXX: todo, support specified precision parameter */
9692                 if (epix)
9693                     goto unknown;
9694                 if (args)
9695                     i = va_arg(*args, int);
9696                 else
9697                     i = (ewix ? ewix <= svmax : svix < svmax)
9698                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9699                 precis = i;
9700                 has_precis = !(i < 0);
9701             }
9702             else {
9703                 precis = 0;
9704                 while (isDIGIT(*q))
9705                     precis = precis * 10 + (*q++ - '0');
9706                 has_precis = TRUE;
9707             }
9708         }
9709
9710         /* SIZE */
9711
9712         switch (*q) {
9713 #ifdef WIN32
9714         case 'I':                       /* Ix, I32x, and I64x */
9715 #  ifdef WIN64
9716             if (q[1] == '6' && q[2] == '4') {
9717                 q += 3;
9718                 intsize = 'q';
9719                 break;
9720             }
9721 #  endif
9722             if (q[1] == '3' && q[2] == '2') {
9723                 q += 3;
9724                 break;
9725             }
9726 #  ifdef WIN64
9727             intsize = 'q';
9728 #  endif
9729             q++;
9730             break;
9731 #endif
9732 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9733         case 'L':                       /* Ld */
9734             /*FALLTHROUGH*/
9735 #ifdef HAS_QUAD
9736         case 'q':                       /* qd */
9737 #endif
9738             intsize = 'q';
9739             q++;
9740             break;
9741 #endif
9742         case 'l':
9743 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9744             if (*(q + 1) == 'l') {      /* lld, llf */
9745                 intsize = 'q';
9746                 q += 2;
9747                 break;
9748              }
9749 #endif
9750             /*FALLTHROUGH*/
9751         case 'h':
9752             /*FALLTHROUGH*/
9753         case 'V':
9754             intsize = *q++;
9755             break;
9756         }
9757
9758         /* CONVERSION */
9759
9760         if (*q == '%') {
9761             eptr = q++;
9762             elen = 1;
9763             if (vectorize) {
9764                 c = '%';
9765                 goto unknown;
9766             }
9767             goto string;
9768         }
9769
9770         if (!vectorize && !args) {
9771             if (efix) {
9772                 const I32 i = efix-1;
9773                 argsv = (i >= 0 && i < svmax)
9774                     ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
9775             } else {
9776                 argsv = (svix >= 0 && svix < svmax)
9777                     ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9778             }
9779         }
9780
9781         switch (c = *q++) {
9782
9783             /* STRINGS */
9784
9785         case 'c':
9786             if (vectorize)
9787                 goto unknown;
9788             uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9789             if ((uv > 255 ||
9790                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9791                 && !IN_BYTES) {
9792                 eptr = (char*)utf8buf;
9793                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9794                 is_utf8 = TRUE;
9795             }
9796             else {
9797                 c = (char)uv;
9798                 eptr = &c;
9799                 elen = 1;
9800             }
9801             goto string;
9802
9803         case 's':
9804             if (vectorize)
9805                 goto unknown;
9806             if (args) {
9807                 eptr = va_arg(*args, char*);
9808                 if (eptr)
9809                     elen = strlen(eptr);
9810                 else {
9811                     eptr = (char *)nullstr;
9812                     elen = sizeof nullstr - 1;
9813                 }
9814             }
9815             else {
9816                 eptr = SvPV_const(argsv, elen);
9817                 if (DO_UTF8(argsv)) {
9818                     STRLEN old_precis = precis;
9819                     if (has_precis && precis < elen) {
9820                         STRLEN ulen = sv_len_utf8(argsv);
9821                         I32 p = precis > ulen ? ulen : precis;
9822                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9823                         precis = p;
9824                     }
9825                     if (width) { /* fudge width (can't fudge elen) */
9826                         if (has_precis && precis < elen)
9827                             width += precis - old_precis;
9828                         else
9829                             width += elen - sv_len_utf8(argsv);
9830                     }
9831                     is_utf8 = TRUE;
9832                 }
9833             }
9834
9835         string:
9836             if (has_precis && precis < elen)
9837                 elen = precis;
9838             break;
9839
9840             /* INTEGERS */
9841
9842         case 'p':
9843             if (alt || vectorize)
9844                 goto unknown;
9845             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9846             base = 16;
9847             goto integer;
9848
9849         case 'D':
9850 #ifdef IV_IS_QUAD
9851             intsize = 'q';
9852 #else
9853             intsize = 'l';
9854 #endif
9855             /*FALLTHROUGH*/
9856         case 'd':
9857         case 'i':
9858 #if vdNUMBER
9859         format_vd:
9860 #endif
9861             if (vectorize) {
9862                 STRLEN ulen;
9863                 if (!veclen)
9864                     continue;
9865                 if (vec_utf8)
9866                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9867                                         UTF8_ALLOW_ANYUV);
9868                 else {
9869                     uv = *vecstr;
9870                     ulen = 1;
9871                 }
9872                 vecstr += ulen;
9873                 veclen -= ulen;
9874                 if (plus)
9875                      esignbuf[esignlen++] = plus;
9876             }
9877             else if (args) {
9878                 switch (intsize) {
9879                 case 'h':       iv = (short)va_arg(*args, int); break;
9880                 case 'l':       iv = va_arg(*args, long); break;
9881                 case 'V':       iv = va_arg(*args, IV); break;
9882                 default:        iv = va_arg(*args, int); break;
9883                 case 'q':
9884 #ifdef HAS_QUAD
9885                                 iv = va_arg(*args, Quad_t); break;
9886 #else
9887                                 goto unknown;
9888 #endif
9889                 }
9890             }
9891             else {
9892                 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9893                 switch (intsize) {
9894                 case 'h':       iv = (short)tiv; break;
9895                 case 'l':       iv = (long)tiv; break;
9896                 case 'V':
9897                 default:        iv = tiv; break;
9898                 case 'q':
9899 #ifdef HAS_QUAD
9900                                 iv = (Quad_t)tiv; break;
9901 #else
9902                                 goto unknown;
9903 #endif
9904                 }
9905             }
9906             if ( !vectorize )   /* we already set uv above */
9907             {
9908                 if (iv >= 0) {
9909                     uv = iv;
9910                     if (plus)
9911                         esignbuf[esignlen++] = plus;
9912                 }
9913                 else {
9914                     uv = -iv;
9915                     esignbuf[esignlen++] = '-';
9916                 }
9917             }
9918             base = 10;
9919             goto integer;
9920
9921         case 'U':
9922 #ifdef IV_IS_QUAD
9923             intsize = 'q';
9924 #else
9925             intsize = 'l';
9926 #endif
9927             /*FALLTHROUGH*/
9928         case 'u':
9929             base = 10;
9930             goto uns_integer;
9931
9932         case 'B':
9933         case 'b':
9934             base = 2;
9935             goto uns_integer;
9936
9937         case 'O':
9938 #ifdef IV_IS_QUAD
9939             intsize = 'q';
9940 #else
9941             intsize = 'l';
9942 #endif
9943             /*FALLTHROUGH*/
9944         case 'o':
9945             base = 8;
9946             goto uns_integer;
9947
9948         case 'X':
9949         case 'x':
9950             base = 16;
9951
9952         uns_integer:
9953             if (vectorize) {
9954                 STRLEN ulen;
9955         vector:
9956                 if (!veclen)
9957                     continue;
9958                 if (vec_utf8)
9959                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9960                                         UTF8_ALLOW_ANYUV);
9961                 else {
9962                     uv = *vecstr;
9963                     ulen = 1;
9964                 }
9965                 vecstr += ulen;
9966                 veclen -= ulen;
9967             }
9968             else if (args) {
9969                 switch (intsize) {
9970                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
9971                 case 'l':  uv = va_arg(*args, unsigned long); break;
9972                 case 'V':  uv = va_arg(*args, UV); break;
9973                 default:   uv = va_arg(*args, unsigned); break;
9974                 case 'q':
9975 #ifdef HAS_QUAD
9976                            uv = va_arg(*args, Uquad_t); break;
9977 #else
9978                            goto unknown;
9979 #endif
9980                 }
9981             }
9982             else {
9983                 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9984                 switch (intsize) {
9985                 case 'h':       uv = (unsigned short)tuv; break;
9986                 case 'l':       uv = (unsigned long)tuv; break;
9987                 case 'V':
9988                 default:        uv = tuv; break;
9989                 case 'q':
9990 #ifdef HAS_QUAD
9991                                 uv = (Uquad_t)tuv; break;
9992 #else
9993                                 goto unknown;
9994 #endif
9995                 }
9996             }
9997
9998         integer:
9999             {
10000                 char *ptr = ebuf + sizeof ebuf;
10001                 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10002                 zeros = 0;
10003
10004                 switch (base) {
10005                     unsigned dig;
10006                 case 16:
10007                     p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10008                     do {
10009                         dig = uv & 15;
10010                         *--ptr = p[dig];
10011                     } while (uv >>= 4);
10012                     if (tempalt) {
10013                         esignbuf[esignlen++] = '0';
10014                         esignbuf[esignlen++] = c;  /* 'x' or 'X' */
10015                     }
10016                     break;
10017                 case 8:
10018                     do {
10019                         dig = uv & 7;
10020                         *--ptr = '0' + dig;
10021                     } while (uv >>= 3);
10022                     if (alt && *ptr != '0')
10023                         *--ptr = '0';
10024                     break;
10025                 case 2:
10026                     do {
10027                         dig = uv & 1;
10028                         *--ptr = '0' + dig;
10029                     } while (uv >>= 1);
10030                     if (tempalt) {
10031                         esignbuf[esignlen++] = '0';
10032                         esignbuf[esignlen++] = c;
10033                     }
10034                     break;
10035                 default:                /* it had better be ten or less */
10036                     do {
10037                         dig = uv % base;
10038                         *--ptr = '0' + dig;
10039                     } while (uv /= base);
10040                     break;
10041                 }
10042                 elen = (ebuf + sizeof ebuf) - ptr;
10043                 eptr = ptr;
10044                 if (has_precis) {
10045                     if (precis > elen)
10046                         zeros = precis - elen;
10047                     else if (precis == 0 && elen == 1 && *eptr == '0'
10048                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10049                         elen = 0;
10050
10051                 /* a precision nullifies the 0 flag. */
10052                     if (fill == '0')
10053                         fill = ' ';
10054                 }
10055             }
10056             break;
10057
10058             /* FLOATING POINT */
10059
10060         case 'F':
10061             c = 'f';            /* maybe %F isn't supported here */
10062             /*FALLTHROUGH*/
10063         case 'e': case 'E':
10064         case 'f':
10065         case 'g': case 'G':
10066             if (vectorize)
10067                 goto unknown;
10068
10069             /* This is evil, but floating point is even more evil */
10070
10071             /* for SV-style calling, we can only get NV
10072                for C-style calling, we assume %f is double;
10073                for simplicity we allow any of %Lf, %llf, %qf for long double
10074             */
10075             switch (intsize) {
10076             case 'V':
10077 #if defined(USE_LONG_DOUBLE)
10078                 intsize = 'q';
10079 #endif
10080                 break;
10081 /* [perl #20339] - we should accept and ignore %lf rather than die */
10082             case 'l':
10083                 /*FALLTHROUGH*/
10084             default:
10085 #if defined(USE_LONG_DOUBLE)
10086                 intsize = args ? 0 : 'q';
10087 #endif
10088                 break;
10089             case 'q':
10090 #if defined(HAS_LONG_DOUBLE)
10091                 break;
10092 #else
10093                 /*FALLTHROUGH*/
10094 #endif
10095             case 'h':
10096                 goto unknown;
10097             }
10098
10099             /* now we need (long double) if intsize == 'q', else (double) */
10100             nv = (args) ?
10101 #if LONG_DOUBLESIZE > DOUBLESIZE
10102                 intsize == 'q' ?
10103                     va_arg(*args, long double) :
10104                     va_arg(*args, double)
10105 #else
10106                     va_arg(*args, double)
10107 #endif
10108                 : SvNV(argsv);
10109
10110             need = 0;
10111             /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10112                else. frexp() has some unspecified behaviour for those three */
10113             if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10114                 i = PERL_INT_MIN;
10115                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10116                    will cast our (long double) to (double) */
10117                 (void)Perl_frexp(nv, &i);
10118                 if (i == PERL_INT_MIN)
10119                     Perl_die(aTHX_ "panic: frexp");
10120                 if (i > 0)
10121                     need = BIT_DIGITS(i);
10122             }
10123             need += has_precis ? precis : 6; /* known default */
10124
10125             if (need < width)
10126                 need = width;
10127
10128 #ifdef HAS_LDBL_SPRINTF_BUG
10129             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10130                with sfio - Allen <allens@cpan.org> */
10131
10132 #  ifdef DBL_MAX
10133 #    define MY_DBL_MAX DBL_MAX
10134 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10135 #    if DOUBLESIZE >= 8
10136 #      define MY_DBL_MAX 1.7976931348623157E+308L
10137 #    else
10138 #      define MY_DBL_MAX 3.40282347E+38L
10139 #    endif
10140 #  endif
10141
10142 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10143 #    define MY_DBL_MAX_BUG 1L
10144 #  else
10145 #    define MY_DBL_MAX_BUG MY_DBL_MAX
10146 #  endif
10147
10148 #  ifdef DBL_MIN
10149 #    define MY_DBL_MIN DBL_MIN
10150 #  else  /* XXX guessing! -Allen */
10151 #    if DOUBLESIZE >= 8
10152 #      define MY_DBL_MIN 2.2250738585072014E-308L
10153 #    else
10154 #      define MY_DBL_MIN 1.17549435E-38L
10155 #    endif
10156 #  endif
10157
10158             if ((intsize == 'q') && (c == 'f') &&
10159                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10160                 (need < DBL_DIG)) {
10161                 /* it's going to be short enough that
10162                  * long double precision is not needed */
10163
10164                 if ((nv <= 0L) && (nv >= -0L))
10165                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10166                 else {
10167                     /* would use Perl_fp_class as a double-check but not
10168                      * functional on IRIX - see perl.h comments */
10169
10170                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10171                         /* It's within the range that a double can represent */
10172 #if defined(DBL_MAX) && !defined(DBL_MIN)
10173                         if ((nv >= ((long double)1/DBL_MAX)) ||
10174                             (nv <= (-(long double)1/DBL_MAX)))
10175 #endif
10176                         fix_ldbl_sprintf_bug = TRUE;
10177                     }
10178                 }
10179                 if (fix_ldbl_sprintf_bug == TRUE) {
10180                     double temp;
10181
10182                     intsize = 0;
10183                     temp = (double)nv;
10184                     nv = (NV)temp;
10185                 }
10186             }
10187
10188 #  undef MY_DBL_MAX
10189 #  undef MY_DBL_MAX_BUG
10190 #  undef MY_DBL_MIN
10191
10192 #endif /* HAS_LDBL_SPRINTF_BUG */
10193
10194             need += 20; /* fudge factor */
10195             if (PL_efloatsize < need) {
10196                 Safefree(PL_efloatbuf);
10197                 PL_efloatsize = need + 20; /* more fudge */
10198                 Newx(PL_efloatbuf, PL_efloatsize, char);
10199                 PL_efloatbuf[0] = '\0';
10200             }
10201
10202             if ( !(width || left || plus || alt) && fill != '0'
10203                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
10204                 /* See earlier comment about buggy Gconvert when digits,
10205                    aka precis is 0  */
10206                 if ( c == 'g' && precis) {
10207                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10208                     /* May return an empty string for digits==0 */
10209                     if (*PL_efloatbuf) {
10210                         elen = strlen(PL_efloatbuf);
10211                         goto float_converted;
10212                     }
10213                 } else if ( c == 'f' && !precis) {
10214                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10215                         break;
10216                 }
10217             }
10218             {
10219                 char *ptr = ebuf + sizeof ebuf;
10220                 *--ptr = '\0';
10221                 *--ptr = c;
10222                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10223 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10224                 if (intsize == 'q') {
10225                     /* Copy the one or more characters in a long double
10226                      * format before the 'base' ([efgEFG]) character to
10227                      * the format string. */
10228                     static char const prifldbl[] = PERL_PRIfldbl;
10229                     char const *p = prifldbl + sizeof(prifldbl) - 3;
10230                     while (p >= prifldbl) { *--ptr = *p--; }
10231                 }
10232 #endif
10233                 if (has_precis) {
10234                     base = precis;
10235                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10236                     *--ptr = '.';
10237                 }
10238                 if (width) {
10239                     base = width;
10240                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
10241                 }
10242                 if (fill == '0')
10243                     *--ptr = fill;
10244                 if (left)
10245                     *--ptr = '-';
10246                 if (plus)
10247                     *--ptr = plus;
10248                 if (alt)
10249                     *--ptr = '#';
10250                 *--ptr = '%';
10251
10252                 /* No taint.  Otherwise we are in the strange situation
10253                  * where printf() taints but print($float) doesn't.
10254                  * --jhi */
10255 #if defined(HAS_LONG_DOUBLE)
10256                 elen = ((intsize == 'q')
10257                         ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10258                         : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10259 #else
10260                 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10261 #endif
10262             }
10263         float_converted:
10264             eptr = PL_efloatbuf;
10265             break;
10266
10267             /* SPECIAL */
10268
10269         case 'n':
10270             if (vectorize)
10271                 goto unknown;
10272             i = SvCUR(sv) - origlen;
10273             if (args) {
10274                 switch (intsize) {
10275                 case 'h':       *(va_arg(*args, short*)) = i; break;
10276                 default:        *(va_arg(*args, int*)) = i; break;
10277                 case 'l':       *(va_arg(*args, long*)) = i; break;
10278                 case 'V':       *(va_arg(*args, IV*)) = i; break;
10279                 case 'q':
10280 #ifdef HAS_QUAD
10281                                 *(va_arg(*args, Quad_t*)) = i; break;
10282 #else
10283                                 goto unknown;
10284 #endif
10285                 }
10286             }
10287             else
10288                 sv_setuv_mg(argsv, (UV)i);
10289             continue;   /* not "break" */
10290
10291             /* UNKNOWN */
10292
10293         default:
10294       unknown:
10295             if (!args
10296                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10297                 && ckWARN(WARN_PRINTF))
10298             {
10299                 SV * const msg = sv_newmortal();
10300                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10301                           (PL_op->op_type == OP_PRTF) ? "" : "s");
10302                 if (fmtstart < patend) {
10303                     const char * const fmtend = q < patend ? q : patend;
10304                     const char * f;
10305                     sv_catpvs(msg, "\"%");
10306                     for (f = fmtstart; f < fmtend; f++) {
10307                         if (isPRINT(*f)) {
10308                             sv_catpvn(msg, f, 1);
10309                         } else {
10310                             Perl_sv_catpvf(aTHX_ msg,
10311                                            "\\%03"UVof, (UV)*f & 0xFF);
10312                         }
10313                     }
10314                     sv_catpvs(msg, "\"");
10315                 } else {
10316                     sv_catpvs(msg, "end of string");
10317                 }
10318                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10319             }
10320
10321             /* output mangled stuff ... */
10322             if (c == '\0')
10323                 --q;
10324             eptr = p;
10325             elen = q - p;
10326
10327             /* ... right here, because formatting flags should not apply */
10328             SvGROW(sv, SvCUR(sv) + elen + 1);
10329             p = SvEND(sv);
10330             Copy(eptr, p, elen, char);
10331             p += elen;
10332             *p = '\0';
10333             SvCUR_set(sv, p - SvPVX_const(sv));
10334             svix = osvix;
10335             continue;   /* not "break" */
10336         }
10337
10338         if (is_utf8 != has_utf8) {
10339             if (is_utf8) {
10340                 if (SvCUR(sv))
10341                     sv_utf8_upgrade(sv);
10342             }
10343             else {
10344                 const STRLEN old_elen = elen;
10345                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10346                 sv_utf8_upgrade(nsv);
10347                 eptr = SvPVX_const(nsv);
10348                 elen = SvCUR(nsv);
10349
10350                 if (width) { /* fudge width (can't fudge elen) */
10351                     width += elen - old_elen;
10352                 }
10353                 is_utf8 = TRUE;
10354             }
10355         }
10356
10357         have = esignlen + zeros + elen;
10358         if (have < zeros)
10359             Perl_croak_nocontext("%s", PL_memory_wrap);
10360
10361         need = (have > width ? have : width);
10362         gap = need - have;
10363
10364         if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10365             Perl_croak_nocontext("%s", PL_memory_wrap);
10366         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10367         p = SvEND(sv);
10368         if (esignlen && fill == '0') {
10369             int i;
10370             for (i = 0; i < (int)esignlen; i++)
10371                 *p++ = esignbuf[i];
10372         }
10373         if (gap && !left) {
10374             memset(p, fill, gap);
10375             p += gap;
10376         }
10377         if (esignlen && fill != '0') {
10378             int i;
10379             for (i = 0; i < (int)esignlen; i++)
10380                 *p++ = esignbuf[i];
10381         }
10382         if (zeros) {
10383             int i;
10384             for (i = zeros; i; i--)
10385                 *p++ = '0';
10386         }
10387         if (elen) {
10388             Copy(eptr, p, elen, char);
10389             p += elen;
10390         }
10391         if (gap && left) {
10392             memset(p, ' ', gap);
10393             p += gap;
10394         }
10395         if (vectorize) {
10396             if (veclen) {
10397                 Copy(dotstr, p, dotstrlen, char);
10398                 p += dotstrlen;
10399             }
10400             else
10401                 vectorize = FALSE;              /* done iterating over vecstr */
10402         }
10403         if (is_utf8)
10404             has_utf8 = TRUE;
10405         if (has_utf8)
10406             SvUTF8_on(sv);
10407         *p = '\0';
10408         SvCUR_set(sv, p - SvPVX_const(sv));
10409         if (vectorize) {
10410             esignlen = 0;
10411             goto vector;
10412         }
10413     }
10414     SvTAINT(sv);
10415 }
10416
10417 /* =========================================================================
10418
10419 =head1 Cloning an interpreter
10420
10421 All the macros and functions in this section are for the private use of
10422 the main function, perl_clone().
10423
10424 The foo_dup() functions make an exact copy of an existing foo thingy.
10425 During the course of a cloning, a hash table is used to map old addresses
10426 to new addresses. The table is created and manipulated with the
10427 ptr_table_* functions.
10428
10429 =cut
10430
10431  * =========================================================================*/
10432
10433
10434 #if defined(USE_ITHREADS)
10435
10436 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10437 #ifndef GpREFCNT_inc
10438 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10439 #endif
10440
10441
10442 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10443    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10444    If this changes, please unmerge ss_dup.
10445    Likewise, sv_dup_inc_multiple() relies on this fact.  */
10446 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10447 #define sv_dup_inc_NN(s,t)      SvREFCNT_inc_NN(sv_dup(s,t))
10448 #define av_dup(s,t)     MUTABLE_AV(sv_dup((const SV *)s,t))
10449 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10450 #define hv_dup(s,t)     MUTABLE_HV(sv_dup((const SV *)s,t))
10451 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10452 #define cv_dup(s,t)     MUTABLE_CV(sv_dup((const SV *)s,t))
10453 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10454 #define io_dup(s,t)     MUTABLE_IO(sv_dup((const SV *)s,t))
10455 #define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10456 #define gv_dup(s,t)     MUTABLE_GV(sv_dup((const SV *)s,t))
10457 #define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10458 #define SAVEPV(p)       ((p) ? savepv(p) : NULL)
10459 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
10460
10461 /* clone a parser */
10462
10463 yy_parser *
10464 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10465 {
10466     yy_parser *parser;
10467
10468     PERL_ARGS_ASSERT_PARSER_DUP;
10469
10470     if (!proto)
10471         return NULL;
10472
10473     /* look for it in the table first */
10474     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10475     if (parser)
10476         return parser;
10477
10478     /* create anew and remember what it is */
10479     Newxz(parser, 1, yy_parser);
10480     ptr_table_store(PL_ptr_table, proto, parser);
10481
10482     parser->yyerrstatus = 0;
10483     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
10484
10485     /* XXX these not yet duped */
10486     parser->old_parser = NULL;
10487     parser->stack = NULL;
10488     parser->ps = NULL;
10489     parser->stack_size = 0;
10490     /* XXX parser->stack->state = 0; */
10491
10492     /* XXX eventually, just Copy() most of the parser struct ? */
10493
10494     parser->lex_brackets = proto->lex_brackets;
10495     parser->lex_casemods = proto->lex_casemods;
10496     parser->lex_brackstack = savepvn(proto->lex_brackstack,
10497                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10498     parser->lex_casestack = savepvn(proto->lex_casestack,
10499                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10500     parser->lex_defer   = proto->lex_defer;
10501     parser->lex_dojoin  = proto->lex_dojoin;
10502     parser->lex_expect  = proto->lex_expect;
10503     parser->lex_formbrack = proto->lex_formbrack;
10504     parser->lex_inpat   = proto->lex_inpat;
10505     parser->lex_inwhat  = proto->lex_inwhat;
10506     parser->lex_op      = proto->lex_op;
10507     parser->lex_repl    = sv_dup_inc(proto->lex_repl, param);
10508     parser->lex_starts  = proto->lex_starts;
10509     parser->lex_stuff   = sv_dup_inc(proto->lex_stuff, param);
10510     parser->multi_close = proto->multi_close;
10511     parser->multi_open  = proto->multi_open;
10512     parser->multi_start = proto->multi_start;
10513     parser->multi_end   = proto->multi_end;
10514     parser->pending_ident = proto->pending_ident;
10515     parser->preambled   = proto->preambled;
10516     parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10517     parser->linestr     = sv_dup_inc(proto->linestr, param);
10518     parser->expect      = proto->expect;
10519     parser->copline     = proto->copline;
10520     parser->last_lop_op = proto->last_lop_op;
10521     parser->lex_state   = proto->lex_state;
10522     parser->rsfp        = fp_dup(proto->rsfp, '<', param);
10523     /* rsfp_filters entries have fake IoDIRP() */
10524     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10525     parser->in_my       = proto->in_my;
10526     parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10527     parser->error_count = proto->error_count;
10528
10529
10530     parser->linestr     = sv_dup_inc(proto->linestr, param);
10531
10532     {
10533         char * const ols = SvPVX(proto->linestr);
10534         char * const ls  = SvPVX(parser->linestr);
10535
10536         parser->bufptr      = ls + (proto->bufptr >= ols ?
10537                                     proto->bufptr -  ols : 0);
10538         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
10539                                     proto->oldbufptr -  ols : 0);
10540         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10541                                     proto->oldoldbufptr -  ols : 0);
10542         parser->linestart   = ls + (proto->linestart >= ols ?
10543                                     proto->linestart -  ols : 0);
10544         parser->last_uni    = ls + (proto->last_uni >= ols ?
10545                                     proto->last_uni -  ols : 0);
10546         parser->last_lop    = ls + (proto->last_lop >= ols ?
10547                                     proto->last_lop -  ols : 0);
10548
10549         parser->bufend      = ls + SvCUR(parser->linestr);
10550     }
10551
10552     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10553
10554
10555 #ifdef PERL_MAD
10556     parser->endwhite    = proto->endwhite;
10557     parser->faketokens  = proto->faketokens;
10558     parser->lasttoke    = proto->lasttoke;
10559     parser->nextwhite   = proto->nextwhite;
10560     parser->realtokenstart = proto->realtokenstart;
10561     parser->skipwhite   = proto->skipwhite;
10562     parser->thisclose   = proto->thisclose;
10563     parser->thismad     = proto->thismad;
10564     parser->thisopen    = proto->thisopen;
10565     parser->thisstuff   = proto->thisstuff;
10566     parser->thistoken   = proto->thistoken;
10567     parser->thiswhite   = proto->thiswhite;
10568
10569     Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10570     parser->curforce    = proto->curforce;
10571 #else
10572     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10573     Copy(proto->nexttype, parser->nexttype, 5,  I32);
10574     parser->nexttoke    = proto->nexttoke;
10575 #endif
10576
10577     /* XXX should clone saved_curcop here, but we aren't passed
10578      * proto_perl; so do it in perl_clone_using instead */
10579
10580     return parser;
10581 }
10582
10583
10584 /* duplicate a file handle */
10585
10586 PerlIO *
10587 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10588 {
10589     PerlIO *ret;
10590
10591     PERL_ARGS_ASSERT_FP_DUP;
10592     PERL_UNUSED_ARG(type);
10593
10594     if (!fp)
10595         return (PerlIO*)NULL;
10596
10597     /* look for it in the table first */
10598     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10599     if (ret)
10600         return ret;
10601
10602     /* create anew and remember what it is */
10603     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10604     ptr_table_store(PL_ptr_table, fp, ret);
10605     return ret;
10606 }
10607
10608 /* duplicate a directory handle */
10609
10610 DIR *
10611 Perl_dirp_dup(pTHX_ DIR *const dp)
10612 {
10613     PERL_UNUSED_CONTEXT;
10614     if (!dp)
10615         return (DIR*)NULL;
10616     /* XXX TODO */
10617     return dp;
10618 }
10619
10620 /* duplicate a typeglob */
10621
10622 GP *
10623 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10624 {
10625     GP *ret;
10626
10627     PERL_ARGS_ASSERT_GP_DUP;
10628
10629     if (!gp)
10630         return (GP*)NULL;
10631     /* look for it in the table first */
10632     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10633     if (ret)
10634         return ret;
10635
10636     /* create anew and remember what it is */
10637     Newxz(ret, 1, GP);
10638     ptr_table_store(PL_ptr_table, gp, ret);
10639
10640     /* clone */
10641     /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
10642        on Newxz() to do this for us.  */
10643     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
10644     ret->gp_io          = io_dup_inc(gp->gp_io, param);
10645     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
10646     ret->gp_av          = av_dup_inc(gp->gp_av, param);
10647     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
10648     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10649     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
10650     ret->gp_cvgen       = gp->gp_cvgen;
10651     ret->gp_line        = gp->gp_line;
10652     ret->gp_file_hek    = hek_dup(gp->gp_file_hek, param);
10653     return ret;
10654 }
10655
10656 /* duplicate a chain of magic */
10657
10658 MAGIC *
10659 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10660 {
10661     MAGIC *mgret = NULL;
10662     MAGIC **mgprev_p = &mgret;
10663
10664     PERL_ARGS_ASSERT_MG_DUP;
10665
10666     for (; mg; mg = mg->mg_moremagic) {
10667         MAGIC *nmg;
10668         Newx(nmg, 1, MAGIC);
10669         *mgprev_p = nmg;
10670         mgprev_p = &(nmg->mg_moremagic);
10671
10672         /* There was a comment "XXX copy dynamic vtable?" but as we don't have
10673            dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
10674            from the original commit adding Perl_mg_dup() - revision 4538.
10675            Similarly there is the annotation "XXX random ptr?" next to the
10676            assignment to nmg->mg_ptr.  */
10677         *nmg = *mg;
10678
10679         /* FIXME for plugins
10680         if (nmg->mg_type == PERL_MAGIC_qr) {
10681             nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
10682         }
10683         else
10684         */
10685         if(nmg->mg_type == PERL_MAGIC_backref) {
10686             /* The backref AV has its reference count deliberately bumped by
10687                1.  */
10688             nmg->mg_obj
10689                 = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param));
10690         }
10691         else {
10692             nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
10693                               ? sv_dup_inc(nmg->mg_obj, param)
10694                               : sv_dup(nmg->mg_obj, param);
10695         }
10696
10697         if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
10698             if (nmg->mg_len > 0) {
10699                 nmg->mg_ptr     = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
10700                 if (nmg->mg_type == PERL_MAGIC_overload_table &&
10701                         AMT_AMAGIC((AMT*)nmg->mg_ptr))
10702                 {
10703                     AMT * const namtp = (AMT*)nmg->mg_ptr;
10704                     sv_dup_inc_multiple((SV**)(namtp->table),
10705                                         (SV**)(namtp->table), NofAMmeth, param);
10706                 }
10707             }
10708             else if (nmg->mg_len == HEf_SVKEY)
10709                 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
10710         }
10711         if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
10712             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10713         }
10714     }
10715     return mgret;
10716 }
10717
10718 #endif /* USE_ITHREADS */
10719
10720 struct ptr_tbl_arena {
10721     struct ptr_tbl_arena *next;
10722     struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers.  */
10723 };
10724
10725 /* create a new pointer-mapping table */
10726
10727 PTR_TBL_t *
10728 Perl_ptr_table_new(pTHX)
10729 {
10730     PTR_TBL_t *tbl;
10731     PERL_UNUSED_CONTEXT;
10732
10733     Newx(tbl, 1, PTR_TBL_t);
10734     tbl->tbl_max        = 511;
10735     tbl->tbl_items      = 0;
10736     tbl->tbl_arena      = NULL;
10737     tbl->tbl_arena_next = NULL;
10738     tbl->tbl_arena_end  = NULL;
10739     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10740     return tbl;
10741 }
10742
10743 #define PTR_TABLE_HASH(ptr) \
10744   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10745
10746 /* map an existing pointer using a table */
10747
10748 STATIC PTR_TBL_ENT_t *
10749 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10750 {
10751     PTR_TBL_ENT_t *tblent;
10752     const UV hash = PTR_TABLE_HASH(sv);
10753
10754     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10755
10756     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10757     for (; tblent; tblent = tblent->next) {
10758         if (tblent->oldval == sv)
10759             return tblent;
10760     }
10761     return NULL;
10762 }
10763
10764 void *
10765 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10766 {
10767     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10768
10769     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10770     PERL_UNUSED_CONTEXT;
10771
10772     return tblent ? tblent->newval : NULL;
10773 }
10774
10775 /* add a new entry to a pointer-mapping table */
10776
10777 void
10778 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10779 {
10780     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10781
10782     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10783     PERL_UNUSED_CONTEXT;
10784
10785     if (tblent) {
10786         tblent->newval = newsv;
10787     } else {
10788         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10789
10790         if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
10791             struct ptr_tbl_arena *new_arena;
10792
10793             Newx(new_arena, 1, struct ptr_tbl_arena);
10794             new_arena->next = tbl->tbl_arena;
10795             tbl->tbl_arena = new_arena;
10796             tbl->tbl_arena_next = new_arena->array;
10797             tbl->tbl_arena_end = new_arena->array
10798                 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
10799         }
10800
10801         tblent = tbl->tbl_arena_next++;
10802
10803         tblent->oldval = oldsv;
10804         tblent->newval = newsv;
10805         tblent->next = tbl->tbl_ary[entry];
10806         tbl->tbl_ary[entry] = tblent;
10807         tbl->tbl_items++;
10808         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10809             ptr_table_split(tbl);
10810     }
10811 }
10812
10813 /* double the hash bucket size of an existing ptr table */
10814
10815 void
10816 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10817 {
10818     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10819     const UV oldsize = tbl->tbl_max + 1;
10820     UV newsize = oldsize * 2;
10821     UV i;
10822
10823     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10824     PERL_UNUSED_CONTEXT;
10825
10826     Renew(ary, newsize, PTR_TBL_ENT_t*);
10827     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10828     tbl->tbl_max = --newsize;
10829     tbl->tbl_ary = ary;
10830     for (i=0; i < oldsize; i++, ary++) {
10831         PTR_TBL_ENT_t **curentp, **entp, *ent;
10832         if (!*ary)
10833             continue;
10834         curentp = ary + oldsize;
10835         for (entp = ary, ent = *ary; ent; ent = *entp) {
10836             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10837                 *entp = ent->next;
10838                 ent->next = *curentp;
10839                 *curentp = ent;
10840                 continue;
10841             }
10842             else
10843                 entp = &ent->next;
10844         }
10845     }
10846 }
10847
10848 /* remove all the entries from a ptr table */
10849 /* Deprecated - will be removed post 5.14 */
10850
10851 void
10852 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10853 {
10854     if (tbl && tbl->tbl_items) {
10855         struct ptr_tbl_arena *arena = tbl->tbl_arena;
10856
10857         Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
10858
10859         while (arena) {
10860             struct ptr_tbl_arena *next = arena->next;
10861
10862             Safefree(arena);
10863             arena = next;
10864         };
10865
10866         tbl->tbl_items = 0;
10867         tbl->tbl_arena = NULL;
10868         tbl->tbl_arena_next = NULL;
10869         tbl->tbl_arena_end = NULL;
10870     }
10871 }
10872
10873 /* clear and free a ptr table */
10874
10875 void
10876 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10877 {
10878     struct ptr_tbl_arena *arena;
10879
10880     if (!tbl) {
10881         return;
10882     }
10883
10884     arena = tbl->tbl_arena;
10885
10886     while (arena) {
10887         struct ptr_tbl_arena *next = arena->next;
10888
10889         Safefree(arena);
10890         arena = next;
10891     }
10892
10893     Safefree(tbl->tbl_ary);
10894     Safefree(tbl);
10895 }
10896
10897 #if defined(USE_ITHREADS)
10898
10899 void
10900 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10901 {
10902     PERL_ARGS_ASSERT_RVPV_DUP;
10903
10904     if (SvROK(sstr)) {
10905         SvRV_set(dstr, SvWEAKREF(sstr)
10906                        ? sv_dup(SvRV_const(sstr), param)
10907                        : sv_dup_inc(SvRV_const(sstr), param));
10908
10909     }
10910     else if (SvPVX_const(sstr)) {
10911         /* Has something there */
10912         if (SvLEN(sstr)) {
10913             /* Normal PV - clone whole allocated space */
10914             SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10915             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10916                 /* Not that normal - actually sstr is copy on write.
10917                    But we are a true, independant SV, so:  */
10918                 SvREADONLY_off(dstr);
10919                 SvFAKE_off(dstr);
10920             }
10921         }
10922         else {
10923             /* Special case - not normally malloced for some reason */
10924             if (isGV_with_GP(sstr)) {
10925                 /* Don't need to do anything here.  */
10926             }
10927             else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10928                 /* A "shared" PV - clone it as "shared" PV */
10929                 SvPV_set(dstr,
10930                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10931                                          param)));
10932             }
10933             else {
10934                 /* Some other special case - random pointer */
10935                 SvPV_set(dstr, (char *) SvPVX_const(sstr));
10936             }
10937         }
10938     }
10939     else {
10940         /* Copy the NULL */
10941         SvPV_set(dstr, NULL);
10942     }
10943 }
10944
10945 /* duplicate a list of SVs. source and dest may point to the same memory.  */
10946 static SV **
10947 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
10948                       SSize_t items, CLONE_PARAMS *const param)
10949 {
10950     PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
10951
10952     while (items-- > 0) {
10953         *dest++ = sv_dup_inc(*source++, param);
10954     }
10955
10956     return dest;
10957 }
10958
10959 /* duplicate an SV of any type (including AV, HV etc) */
10960
10961 SV *
10962 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10963 {
10964     dVAR;
10965     SV *dstr;
10966
10967     PERL_ARGS_ASSERT_SV_DUP;
10968
10969     if (!sstr)
10970         return NULL;
10971     if (SvTYPE(sstr) == SVTYPEMASK) {
10972 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10973         abort();
10974 #endif
10975         return NULL;
10976     }
10977     /* look for it in the table first */
10978     dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
10979     if (dstr)
10980         return dstr;
10981
10982     if(param->flags & CLONEf_JOIN_IN) {
10983         /** We are joining here so we don't want do clone
10984             something that is bad **/
10985         if (SvTYPE(sstr) == SVt_PVHV) {
10986             const HEK * const hvname = HvNAME_HEK(sstr);
10987             if (hvname)
10988                 /** don't clone stashes if they already exist **/
10989                 return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
10990         }
10991     }
10992
10993     /* create anew and remember what it is */
10994     new_SV(dstr);
10995
10996 #ifdef DEBUG_LEAKING_SCALARS
10997     dstr->sv_debug_optype = sstr->sv_debug_optype;
10998     dstr->sv_debug_line = sstr->sv_debug_line;
10999     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11000     dstr->sv_debug_cloned = 1;
11001     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11002 #endif
11003
11004     ptr_table_store(PL_ptr_table, sstr, dstr);
11005
11006     /* clone */
11007     SvFLAGS(dstr)       = SvFLAGS(sstr);
11008     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
11009     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
11010
11011 #ifdef DEBUGGING
11012     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11013         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11014                       (void*)PL_watch_pvx, SvPVX_const(sstr));
11015 #endif
11016
11017     /* don't clone objects whose class has asked us not to */
11018     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11019         SvFLAGS(dstr) = 0;
11020         return dstr;
11021     }
11022
11023     switch (SvTYPE(sstr)) {
11024     case SVt_NULL:
11025         SvANY(dstr)     = NULL;
11026         break;
11027     case SVt_IV:
11028         SvANY(dstr)     = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11029         if(SvROK(sstr)) {
11030             Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11031         } else {
11032             SvIV_set(dstr, SvIVX(sstr));
11033         }
11034         break;
11035     case SVt_NV:
11036         SvANY(dstr)     = new_XNV();
11037         SvNV_set(dstr, SvNVX(sstr));
11038         break;
11039         /* case SVt_BIND: */
11040     default:
11041         {
11042             /* These are all the types that need complex bodies allocating.  */
11043             void *new_body;
11044             const svtype sv_type = SvTYPE(sstr);
11045             const struct body_details *const sv_type_details
11046                 = bodies_by_type + sv_type;
11047
11048             switch (sv_type) {
11049             default:
11050                 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11051                 break;
11052
11053             case SVt_PVGV:
11054             case SVt_PVIO:
11055             case SVt_PVFM:
11056             case SVt_PVHV:
11057             case SVt_PVAV:
11058             case SVt_PVCV:
11059             case SVt_PVLV:
11060             case SVt_REGEXP:
11061             case SVt_PVMG:
11062             case SVt_PVNV:
11063             case SVt_PVIV:
11064             case SVt_PV:
11065                 assert(sv_type_details->body_size);
11066                 if (sv_type_details->arena) {
11067                     new_body_inline(new_body, sv_type);
11068                     new_body
11069                         = (void*)((char*)new_body - sv_type_details->offset);
11070                 } else {
11071                     new_body = new_NOARENA(sv_type_details);
11072                 }
11073             }
11074             assert(new_body);
11075             SvANY(dstr) = new_body;
11076
11077 #ifndef PURIFY
11078             Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11079                  ((char*)SvANY(dstr)) + sv_type_details->offset,
11080                  sv_type_details->copy, char);
11081 #else
11082             Copy(((char*)SvANY(sstr)),
11083                  ((char*)SvANY(dstr)),
11084                  sv_type_details->body_size + sv_type_details->offset, char);
11085 #endif
11086
11087             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11088                 && !isGV_with_GP(dstr))
11089                 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11090
11091             /* The Copy above means that all the source (unduplicated) pointers
11092                are now in the destination.  We can check the flags and the
11093                pointers in either, but it's possible that there's less cache
11094                missing by always going for the destination.
11095                FIXME - instrument and check that assumption  */
11096             if (sv_type >= SVt_PVMG) {
11097                 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11098                     SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11099                 } else if (SvMAGIC(dstr))
11100                     SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11101                 if (SvSTASH(dstr))
11102                     SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11103             }
11104
11105             /* The cast silences a GCC warning about unhandled types.  */
11106             switch ((int)sv_type) {
11107             case SVt_PV:
11108                 break;
11109             case SVt_PVIV:
11110                 break;
11111             case SVt_PVNV:
11112                 break;
11113             case SVt_PVMG:
11114                 break;
11115             case SVt_REGEXP:
11116                 /* FIXME for plugins */
11117                 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11118                 break;
11119             case SVt_PVLV:
11120                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11121                 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11122                     LvTARG(dstr) = dstr;
11123                 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11124                     LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11125                 else
11126                     LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11127             case SVt_PVGV:
11128                 if(isGV_with_GP(sstr)) {
11129                     GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11130                     /* Don't call sv_add_backref here as it's going to be
11131                        created as part of the magic cloning of the symbol
11132                        table--unless this is during a join and the stash
11133                        is not actually being cloned.  */
11134                     /* Danger Will Robinson - GvGP(dstr) isn't initialised
11135                        at the point of this comment.  */
11136                     GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11137                     if(param->flags & CLONEf_JOIN_IN) {
11138                         const HEK * const hvname
11139                          = HvNAME_HEK(GvSTASH(dstr));
11140                         if( hvname
11141                          && GvSTASH(dstr) == gv_stashpvn(
11142                              HEK_KEY(hvname), HEK_LEN(hvname), 0
11143                             )
11144                           )
11145                             Perl_sv_add_backref(
11146                              aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr
11147                             );
11148                     }
11149                     GvGP(dstr)  = gp_dup(GvGP(sstr), param);
11150                     (void)GpREFCNT_inc(GvGP(dstr));
11151                 } else
11152                     Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11153                 break;
11154             case SVt_PVIO:
11155                 IoIFP(dstr)     = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
11156                 if (IoOFP(dstr) == IoIFP(sstr))
11157                     IoOFP(dstr) = IoIFP(dstr);
11158                 else
11159                     IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11160                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11161                 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11162                     /* I have no idea why fake dirp (rsfps)
11163                        should be treated differently but otherwise
11164                        we end up with leaks -- sky*/
11165                     IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
11166                     IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
11167                     IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11168                 } else {
11169                     IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
11170                     IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
11171                     IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
11172                     if (IoDIRP(dstr)) {
11173                         IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr));
11174                     } else {
11175                         NOOP;
11176                         /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
11177                     }
11178                 }
11179                 IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
11180                 IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
11181                 IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
11182                 break;
11183             case SVt_PVAV:
11184                 /* avoid cloning an empty array */
11185                 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11186                     SV **dst_ary, **src_ary;
11187                     SSize_t items = AvFILLp((const AV *)sstr) + 1;
11188
11189                     src_ary = AvARRAY((const AV *)sstr);
11190                     Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11191                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11192                     AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11193                     AvALLOC((const AV *)dstr) = dst_ary;
11194                     if (AvREAL((const AV *)sstr)) {
11195                         dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11196                                                       param);
11197                     }
11198                     else {
11199                         while (items-- > 0)
11200                             *dst_ary++ = sv_dup(*src_ary++, param);
11201                         if (!(param->flags & CLONEf_COPY_STACKS)
11202                              && AvREIFY(sstr))
11203                         {
11204                             av_reify(MUTABLE_AV(dstr)); /* #41138 */
11205                         }
11206                     }
11207                     items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11208                     while (items-- > 0) {
11209                         *dst_ary++ = &PL_sv_undef;
11210                     }
11211                 }
11212                 else {
11213                     AvARRAY(MUTABLE_AV(dstr))   = NULL;
11214                     AvALLOC((const AV *)dstr)   = (SV**)NULL;
11215                     AvMAX(  (const AV *)dstr)   = -1;
11216                     AvFILLp((const AV *)dstr)   = -1;
11217                 }
11218                 break;
11219             case SVt_PVHV:
11220                 if (HvARRAY((const HV *)sstr)) {
11221                     STRLEN i = 0;
11222                     const bool sharekeys = !!HvSHAREKEYS(sstr);
11223                     XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11224                     XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11225                     char *darray;
11226                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11227                         + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11228                         char);
11229                     HvARRAY(dstr) = (HE**)darray;
11230                     while (i <= sxhv->xhv_max) {
11231                         const HE * const source = HvARRAY(sstr)[i];
11232                         HvARRAY(dstr)[i] = source
11233                             ? he_dup(source, sharekeys, param) : 0;
11234                         ++i;
11235                     }
11236                     if (SvOOK(sstr)) {
11237                         HEK *hvname;
11238                         const struct xpvhv_aux * const saux = HvAUX(sstr);
11239                         struct xpvhv_aux * const daux = HvAUX(dstr);
11240                         /* This flag isn't copied.  */
11241                         /* SvOOK_on(hv) attacks the IV flags.  */
11242                         SvFLAGS(dstr) |= SVf_OOK;
11243
11244                         hvname = saux->xhv_name;
11245                         daux->xhv_name = hek_dup(hvname, param);
11246
11247                         daux->xhv_riter = saux->xhv_riter;
11248                         daux->xhv_eiter = saux->xhv_eiter
11249                             ? he_dup(saux->xhv_eiter,
11250                                         cBOOL(HvSHAREKEYS(sstr)), param) : 0;
11251                         /* backref array needs refcnt=2; see sv_add_backref */
11252                         daux->xhv_backreferences =
11253                             saux->xhv_backreferences
11254                             ? MUTABLE_AV(SvREFCNT_inc(
11255                                                       sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
11256                                 : 0;
11257
11258                         daux->xhv_mro_meta = saux->xhv_mro_meta
11259                             ? mro_meta_dup(saux->xhv_mro_meta, param)
11260                             : 0;
11261
11262                         /* Record stashes for possible cloning in Perl_clone(). */
11263                         if (hvname)
11264                             av_push(param->stashes, dstr);
11265                     }
11266                 }
11267                 else
11268                     HvARRAY(MUTABLE_HV(dstr)) = NULL;
11269                 break;
11270             case SVt_PVCV:
11271                 if (!(param->flags & CLONEf_COPY_STACKS)) {
11272                     CvDEPTH(dstr) = 0;
11273                 }
11274             case SVt_PVFM:
11275                 /* NOTE: not refcounted */
11276                 CvSTASH(dstr)   = hv_dup(CvSTASH(dstr), param);
11277                 OP_REFCNT_LOCK;
11278                 if (!CvISXSUB(dstr))
11279                     CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11280                 OP_REFCNT_UNLOCK;
11281                 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11282                     CvXSUBANY(dstr).any_ptr =
11283                         sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11284                 }
11285                 /* don't dup if copying back - CvGV isn't refcounted, so the
11286                  * duped GV may never be freed. A bit of a hack! DAPM */
11287                 CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
11288                     NULL : gv_dup(CvGV(dstr), param) ;
11289                 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11290                 CvOUTSIDE(dstr) =
11291                     CvWEAKOUTSIDE(sstr)
11292                     ? cv_dup(    CvOUTSIDE(dstr), param)
11293                     : cv_dup_inc(CvOUTSIDE(dstr), param);
11294                 if (!CvISXSUB(dstr))
11295                     CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11296                 break;
11297             }
11298         }
11299     }
11300
11301     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11302         ++PL_sv_objcount;
11303
11304     return dstr;
11305  }
11306
11307 /* duplicate a context */
11308
11309 PERL_CONTEXT *
11310 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11311 {
11312     PERL_CONTEXT *ncxs;
11313
11314     PERL_ARGS_ASSERT_CX_DUP;
11315
11316     if (!cxs)
11317         return (PERL_CONTEXT*)NULL;
11318
11319     /* look for it in the table first */
11320     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11321     if (ncxs)
11322         return ncxs;
11323
11324     /* create anew and remember what it is */
11325     Newx(ncxs, max + 1, PERL_CONTEXT);
11326     ptr_table_store(PL_ptr_table, cxs, ncxs);
11327     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11328
11329     while (ix >= 0) {
11330         PERL_CONTEXT * const ncx = &ncxs[ix];
11331         if (CxTYPE(ncx) == CXt_SUBST) {
11332             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11333         }
11334         else {
11335             switch (CxTYPE(ncx)) {
11336             case CXt_SUB:
11337                 ncx->blk_sub.cv         = (ncx->blk_sub.olddepth == 0
11338                                            ? cv_dup_inc(ncx->blk_sub.cv, param)
11339                                            : cv_dup(ncx->blk_sub.cv,param));
11340                 ncx->blk_sub.argarray   = (CxHASARGS(ncx)
11341                                            ? av_dup_inc(ncx->blk_sub.argarray,
11342                                                         param)
11343                                            : NULL);
11344                 ncx->blk_sub.savearray  = av_dup_inc(ncx->blk_sub.savearray,
11345                                                      param);
11346                 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11347                                            ncx->blk_sub.oldcomppad);
11348                 break;
11349             case CXt_EVAL:
11350                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11351                                                       param);
11352                 ncx->blk_eval.cur_text  = sv_dup(ncx->blk_eval.cur_text, param);
11353                 break;
11354             case CXt_LOOP_LAZYSV:
11355                 ncx->blk_loop.state_u.lazysv.end
11356                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11357                 /* We are taking advantage of av_dup_inc and sv_dup_inc
11358                    actually being the same function, and order equivalance of
11359                    the two unions.
11360                    We can assert the later [but only at run time :-(]  */
11361                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11362                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
11363             case CXt_LOOP_FOR:
11364                 ncx->blk_loop.state_u.ary.ary
11365                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11366             case CXt_LOOP_LAZYIV:
11367             case CXt_LOOP_PLAIN:
11368                 if (CxPADLOOP(ncx)) {
11369                     ncx->blk_loop.oldcomppad
11370                         = (PAD*)ptr_table_fetch(PL_ptr_table,
11371                                                 ncx->blk_loop.oldcomppad);
11372                 } else {
11373                     ncx->blk_loop.oldcomppad
11374                         = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
11375                                        param);
11376                 }
11377                 break;
11378             case CXt_FORMAT:
11379                 ncx->blk_format.cv      = cv_dup(ncx->blk_format.cv, param);
11380                 ncx->blk_format.gv      = gv_dup(ncx->blk_format.gv, param);
11381                 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11382                                                      param);
11383                 break;
11384             case CXt_BLOCK:
11385             case CXt_NULL:
11386                 break;
11387             }
11388         }
11389         --ix;
11390     }
11391     return ncxs;
11392 }
11393
11394 /* duplicate a stack info structure */
11395
11396 PERL_SI *
11397 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11398 {
11399     PERL_SI *nsi;
11400
11401     PERL_ARGS_ASSERT_SI_DUP;
11402
11403     if (!si)
11404         return (PERL_SI*)NULL;
11405
11406     /* look for it in the table first */
11407     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11408     if (nsi)
11409         return nsi;
11410
11411     /* create anew and remember what it is */
11412     Newxz(nsi, 1, PERL_SI);
11413     ptr_table_store(PL_ptr_table, si, nsi);
11414
11415     nsi->si_stack       = av_dup_inc(si->si_stack, param);
11416     nsi->si_cxix        = si->si_cxix;
11417     nsi->si_cxmax       = si->si_cxmax;
11418     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11419     nsi->si_type        = si->si_type;
11420     nsi->si_prev        = si_dup(si->si_prev, param);
11421     nsi->si_next        = si_dup(si->si_next, param);
11422     nsi->si_markoff     = si->si_markoff;
11423
11424     return nsi;
11425 }
11426
11427 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
11428 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
11429 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
11430 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
11431 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
11432 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
11433 #define POPUV(ss,ix)    ((ss)[--(ix)].any_uv)
11434 #define TOPUV(ss,ix)    ((ss)[ix].any_uv)
11435 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
11436 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
11437 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
11438 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
11439 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
11440 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
11441 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11442 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11443
11444 /* XXXXX todo */
11445 #define pv_dup_inc(p)   SAVEPV(p)
11446 #define pv_dup(p)       SAVEPV(p)
11447 #define svp_dup_inc(p,pp)       any_dup(p,pp)
11448
11449 /* map any object to the new equivent - either something in the
11450  * ptr table, or something in the interpreter structure
11451  */
11452
11453 void *
11454 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11455 {
11456     void *ret;
11457
11458     PERL_ARGS_ASSERT_ANY_DUP;
11459
11460     if (!v)
11461         return (void*)NULL;
11462
11463     /* look for it in the table first */
11464     ret = ptr_table_fetch(PL_ptr_table, v);
11465     if (ret)
11466         return ret;
11467
11468     /* see if it is part of the interpreter structure */
11469     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11470         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11471     else {
11472         ret = v;
11473     }
11474
11475     return ret;
11476 }
11477
11478 /* duplicate the save stack */
11479
11480 ANY *
11481 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11482 {
11483     dVAR;
11484     ANY * const ss      = proto_perl->Isavestack;
11485     const I32 max       = proto_perl->Isavestack_max;
11486     I32 ix              = proto_perl->Isavestack_ix;
11487     ANY *nss;
11488     const SV *sv;
11489     const GV *gv;
11490     const AV *av;
11491     const HV *hv;
11492     void* ptr;
11493     int intval;
11494     long longval;
11495     GP *gp;
11496     IV iv;
11497     I32 i;
11498     char *c = NULL;
11499     void (*dptr) (void*);
11500     void (*dxptr) (pTHX_ void*);
11501
11502     PERL_ARGS_ASSERT_SS_DUP;
11503
11504     Newxz(nss, max, ANY);
11505
11506     while (ix > 0) {
11507         const UV uv = POPUV(ss,ix);
11508         const U8 type = (U8)uv & SAVE_MASK;
11509
11510         TOPUV(nss,ix) = uv;
11511         switch (type) {
11512         case SAVEt_HELEM:               /* hash element */
11513             sv = (const SV *)POPPTR(ss,ix);
11514             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11515             /* fall through */
11516         case SAVEt_ITEM:                        /* normal string */
11517         case SAVEt_SV:                          /* scalar reference */
11518             sv = (const SV *)POPPTR(ss,ix);
11519             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11520             /* fall through */
11521         case SAVEt_FREESV:
11522         case SAVEt_MORTALIZESV:
11523             sv = (const SV *)POPPTR(ss,ix);
11524             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11525             break;
11526         case SAVEt_SHARED_PVREF:                /* char* in shared space */
11527             c = (char*)POPPTR(ss,ix);
11528             TOPPTR(nss,ix) = savesharedpv(c);
11529             ptr = POPPTR(ss,ix);
11530             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11531             break;
11532         case SAVEt_GENERIC_SVREF:               /* generic sv */
11533         case SAVEt_SVREF:                       /* scalar reference */
11534             sv = (const SV *)POPPTR(ss,ix);
11535             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11536             ptr = POPPTR(ss,ix);
11537             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11538             break;
11539         case SAVEt_HV:                          /* hash reference */
11540         case SAVEt_AV:                          /* array reference */
11541             sv = (const SV *) POPPTR(ss,ix);
11542             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11543             /* fall through */
11544         case SAVEt_COMPPAD:
11545         case SAVEt_NSTAB:
11546             sv = (const SV *) POPPTR(ss,ix);
11547             TOPPTR(nss,ix) = sv_dup(sv, param);
11548             break;
11549         case SAVEt_INT:                         /* int reference */
11550             ptr = POPPTR(ss,ix);
11551             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11552             intval = (int)POPINT(ss,ix);
11553             TOPINT(nss,ix) = intval;
11554             break;
11555         case SAVEt_LONG:                        /* long reference */
11556             ptr = POPPTR(ss,ix);
11557             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11558             /* fall through */
11559         case SAVEt_CLEARSV:
11560             longval = (long)POPLONG(ss,ix);
11561             TOPLONG(nss,ix) = longval;
11562             break;
11563         case SAVEt_I32:                         /* I32 reference */
11564         case SAVEt_I16:                         /* I16 reference */
11565         case SAVEt_I8:                          /* I8 reference */
11566         case SAVEt_COP_ARYBASE:                 /* call CopARYBASE_set */
11567             ptr = POPPTR(ss,ix);
11568             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11569             i = POPINT(ss,ix);
11570             TOPINT(nss,ix) = i;
11571             break;
11572         case SAVEt_IV:                          /* IV reference */
11573             ptr = POPPTR(ss,ix);
11574             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11575             iv = POPIV(ss,ix);
11576             TOPIV(nss,ix) = iv;
11577             break;
11578         case SAVEt_HPTR:                        /* HV* reference */
11579         case SAVEt_APTR:                        /* AV* reference */
11580         case SAVEt_SPTR:                        /* SV* reference */
11581             ptr = POPPTR(ss,ix);
11582             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11583             sv = (const SV *)POPPTR(ss,ix);
11584             TOPPTR(nss,ix) = sv_dup(sv, param);
11585             break;
11586         case SAVEt_VPTR:                        /* random* reference */
11587             ptr = POPPTR(ss,ix);
11588             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11589             ptr = POPPTR(ss,ix);
11590             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11591             break;
11592         case SAVEt_GENERIC_PVREF:               /* generic char* */
11593         case SAVEt_PPTR:                        /* char* reference */
11594             ptr = POPPTR(ss,ix);
11595             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11596             c = (char*)POPPTR(ss,ix);
11597             TOPPTR(nss,ix) = pv_dup(c);
11598             break;
11599         case SAVEt_GP:                          /* scalar reference */
11600             gv = (const GV *)POPPTR(ss,ix);
11601             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11602             gp = (GP*)POPPTR(ss,ix);
11603             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11604             (void)GpREFCNT_inc(gp);
11605             i = POPINT(ss,ix);
11606             TOPINT(nss,ix) = i;
11607             break;
11608         case SAVEt_FREEOP:
11609             ptr = POPPTR(ss,ix);
11610             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11611                 /* these are assumed to be refcounted properly */
11612                 OP *o;
11613                 switch (((OP*)ptr)->op_type) {
11614                 case OP_LEAVESUB:
11615                 case OP_LEAVESUBLV:
11616                 case OP_LEAVEEVAL:
11617                 case OP_LEAVE:
11618                 case OP_SCOPE:
11619                 case OP_LEAVEWRITE:
11620                     TOPPTR(nss,ix) = ptr;
11621                     o = (OP*)ptr;
11622                     OP_REFCNT_LOCK;
11623                     (void) OpREFCNT_inc(o);
11624                     OP_REFCNT_UNLOCK;
11625                     break;
11626                 default:
11627                     TOPPTR(nss,ix) = NULL;
11628                     break;
11629                 }
11630             }
11631             else
11632                 TOPPTR(nss,ix) = NULL;
11633             break;
11634         case SAVEt_DELETE:
11635             hv = (const HV *)POPPTR(ss,ix);
11636             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11637             i = POPINT(ss,ix);
11638             TOPINT(nss,ix) = i;
11639             /* Fall through */
11640         case SAVEt_FREEPV:
11641             c = (char*)POPPTR(ss,ix);
11642             TOPPTR(nss,ix) = pv_dup_inc(c);
11643             break;
11644         case SAVEt_STACK_POS:           /* Position on Perl stack */
11645             i = POPINT(ss,ix);
11646             TOPINT(nss,ix) = i;
11647             break;
11648         case SAVEt_DESTRUCTOR:
11649             ptr = POPPTR(ss,ix);
11650             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11651             dptr = POPDPTR(ss,ix);
11652             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11653                                         any_dup(FPTR2DPTR(void *, dptr),
11654                                                 proto_perl));
11655             break;
11656         case SAVEt_DESTRUCTOR_X:
11657             ptr = POPPTR(ss,ix);
11658             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11659             dxptr = POPDXPTR(ss,ix);
11660             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11661                                          any_dup(FPTR2DPTR(void *, dxptr),
11662                                                  proto_perl));
11663             break;
11664         case SAVEt_REGCONTEXT:
11665         case SAVEt_ALLOC:
11666             i = POPINT(ss,ix);
11667             TOPINT(nss,ix) = i;
11668             ix -= i;
11669             break;
11670         case SAVEt_AELEM:               /* array element */
11671             sv = (const SV *)POPPTR(ss,ix);
11672             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11673             i = POPINT(ss,ix);
11674             TOPINT(nss,ix) = i;
11675             av = (const AV *)POPPTR(ss,ix);
11676             TOPPTR(nss,ix) = av_dup_inc(av, param);
11677             break;
11678         case SAVEt_OP:
11679             ptr = POPPTR(ss,ix);
11680             TOPPTR(nss,ix) = ptr;
11681             break;
11682         case SAVEt_HINTS:
11683             ptr = POPPTR(ss,ix);
11684             if (ptr) {
11685                 HINTS_REFCNT_LOCK;
11686                 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11687                 HINTS_REFCNT_UNLOCK;
11688             }
11689             TOPPTR(nss,ix) = ptr;
11690             i = POPINT(ss,ix);
11691             TOPINT(nss,ix) = i;
11692             if (i & HINT_LOCALIZE_HH) {
11693                 hv = (const HV *)POPPTR(ss,ix);
11694                 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11695             }
11696             break;
11697         case SAVEt_PADSV_AND_MORTALIZE:
11698             longval = (long)POPLONG(ss,ix);
11699             TOPLONG(nss,ix) = longval;
11700             ptr = POPPTR(ss,ix);
11701             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11702             sv = (const SV *)POPPTR(ss,ix);
11703             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11704             break;
11705         case SAVEt_BOOL:
11706             ptr = POPPTR(ss,ix);
11707             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11708             longval = (long)POPBOOL(ss,ix);
11709             TOPBOOL(nss,ix) = cBOOL(longval);
11710             break;
11711         case SAVEt_SET_SVFLAGS:
11712             i = POPINT(ss,ix);
11713             TOPINT(nss,ix) = i;
11714             i = POPINT(ss,ix);
11715             TOPINT(nss,ix) = i;
11716             sv = (const SV *)POPPTR(ss,ix);
11717             TOPPTR(nss,ix) = sv_dup(sv, param);
11718             break;
11719         case SAVEt_RE_STATE:
11720             {
11721                 const struct re_save_state *const old_state
11722                     = (struct re_save_state *)
11723                     (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11724                 struct re_save_state *const new_state
11725                     = (struct re_save_state *)
11726                     (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11727
11728                 Copy(old_state, new_state, 1, struct re_save_state);
11729                 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11730
11731                 new_state->re_state_bostr
11732                     = pv_dup(old_state->re_state_bostr);
11733                 new_state->re_state_reginput
11734                     = pv_dup(old_state->re_state_reginput);
11735                 new_state->re_state_regeol
11736                     = pv_dup(old_state->re_state_regeol);
11737                 new_state->re_state_regoffs
11738                     = (regexp_paren_pair*)
11739                         any_dup(old_state->re_state_regoffs, proto_perl);
11740                 new_state->re_state_reglastparen
11741                     = (U32*) any_dup(old_state->re_state_reglastparen,
11742                               proto_perl);
11743                 new_state->re_state_reglastcloseparen
11744                     = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11745                               proto_perl);
11746                 /* XXX This just has to be broken. The old save_re_context
11747                    code did SAVEGENERICPV(PL_reg_start_tmp);
11748                    PL_reg_start_tmp is char **.
11749                    Look above to what the dup code does for
11750                    SAVEt_GENERIC_PVREF
11751                    It can never have worked.
11752                    So this is merely a faithful copy of the exiting bug:  */
11753                 new_state->re_state_reg_start_tmp
11754                     = (char **) pv_dup((char *)
11755                                       old_state->re_state_reg_start_tmp);
11756                 /* I assume that it only ever "worked" because no-one called
11757                    (pseudo)fork while the regexp engine had re-entered itself.
11758                 */
11759 #ifdef PERL_OLD_COPY_ON_WRITE
11760                 new_state->re_state_nrs
11761                     = sv_dup(old_state->re_state_nrs, param);
11762 #endif
11763                 new_state->re_state_reg_magic
11764                     = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11765                                proto_perl);
11766                 new_state->re_state_reg_oldcurpm
11767                     = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11768                               proto_perl);
11769                 new_state->re_state_reg_curpm
11770                     = (PMOP*)  any_dup(old_state->re_state_reg_curpm,
11771                                proto_perl);
11772                 new_state->re_state_reg_oldsaved
11773                     = pv_dup(old_state->re_state_reg_oldsaved);
11774                 new_state->re_state_reg_poscache
11775                     = pv_dup(old_state->re_state_reg_poscache);
11776                 new_state->re_state_reg_starttry
11777                     = pv_dup(old_state->re_state_reg_starttry);
11778                 break;
11779             }
11780         case SAVEt_COMPILE_WARNINGS:
11781             ptr = POPPTR(ss,ix);
11782             TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11783             break;
11784         case SAVEt_PARSER:
11785             ptr = POPPTR(ss,ix);
11786             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11787             break;
11788         default:
11789             Perl_croak(aTHX_
11790                        "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11791         }
11792     }
11793
11794     return nss;
11795 }
11796
11797
11798 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11799  * flag to the result. This is done for each stash before cloning starts,
11800  * so we know which stashes want their objects cloned */
11801
11802 static void
11803 do_mark_cloneable_stash(pTHX_ SV *const sv)
11804 {
11805     const HEK * const hvname = HvNAME_HEK((const HV *)sv);
11806     if (hvname) {
11807         GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
11808         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11809         if (cloner && GvCV(cloner)) {
11810             dSP;
11811             UV status;
11812
11813             ENTER;
11814             SAVETMPS;
11815             PUSHMARK(SP);
11816             mXPUSHs(newSVhek(hvname));
11817             PUTBACK;
11818             call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
11819             SPAGAIN;
11820             status = POPu;
11821             PUTBACK;
11822             FREETMPS;
11823             LEAVE;
11824             if (status)
11825                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11826         }
11827     }
11828 }
11829
11830
11831
11832 /*
11833 =for apidoc perl_clone
11834
11835 Create and return a new interpreter by cloning the current one.
11836
11837 perl_clone takes these flags as parameters:
11838
11839 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11840 without it we only clone the data and zero the stacks,
11841 with it we copy the stacks and the new perl interpreter is
11842 ready to run at the exact same point as the previous one.
11843 The pseudo-fork code uses COPY_STACKS while the
11844 threads->create doesn't.
11845
11846 CLONEf_KEEP_PTR_TABLE
11847 perl_clone keeps a ptr_table with the pointer of the old
11848 variable as a key and the new variable as a value,
11849 this allows it to check if something has been cloned and not
11850 clone it again but rather just use the value and increase the
11851 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11852 the ptr_table using the function
11853 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11854 reason to keep it around is if you want to dup some of your own
11855 variable who are outside the graph perl scans, example of this
11856 code is in threads.xs create
11857
11858 CLONEf_CLONE_HOST
11859 This is a win32 thing, it is ignored on unix, it tells perls
11860 win32host code (which is c++) to clone itself, this is needed on
11861 win32 if you want to run two threads at the same time,
11862 if you just want to do some stuff in a separate perl interpreter
11863 and then throw it away and return to the original one,
11864 you don't need to do anything.
11865
11866 =cut
11867 */
11868
11869 /* XXX the above needs expanding by someone who actually understands it ! */
11870 EXTERN_C PerlInterpreter *
11871 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11872
11873 PerlInterpreter *
11874 perl_clone(PerlInterpreter *proto_perl, UV flags)
11875 {
11876    dVAR;
11877 #ifdef PERL_IMPLICIT_SYS
11878
11879     PERL_ARGS_ASSERT_PERL_CLONE;
11880
11881    /* perlhost.h so we need to call into it
11882    to clone the host, CPerlHost should have a c interface, sky */
11883
11884    if (flags & CLONEf_CLONE_HOST) {
11885        return perl_clone_host(proto_perl,flags);
11886    }
11887    return perl_clone_using(proto_perl, flags,
11888                             proto_perl->IMem,
11889                             proto_perl->IMemShared,
11890                             proto_perl->IMemParse,
11891                             proto_perl->IEnv,
11892                             proto_perl->IStdIO,
11893                             proto_perl->ILIO,
11894                             proto_perl->IDir,
11895                             proto_perl->ISock,
11896                             proto_perl->IProc);
11897 }
11898
11899 PerlInterpreter *
11900 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11901                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
11902                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11903                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11904                  struct IPerlDir* ipD, struct IPerlSock* ipS,
11905                  struct IPerlProc* ipP)
11906 {
11907     /* XXX many of the string copies here can be optimized if they're
11908      * constants; they need to be allocated as common memory and just
11909      * their pointers copied. */
11910
11911     IV i;
11912     CLONE_PARAMS clone_params;
11913     CLONE_PARAMS* const param = &clone_params;
11914
11915     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11916
11917     PERL_ARGS_ASSERT_PERL_CLONE_USING;
11918 #else           /* !PERL_IMPLICIT_SYS */
11919     IV i;
11920     CLONE_PARAMS clone_params;
11921     CLONE_PARAMS* param = &clone_params;
11922     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11923
11924     PERL_ARGS_ASSERT_PERL_CLONE;
11925 #endif          /* PERL_IMPLICIT_SYS */
11926
11927     /* for each stash, determine whether its objects should be cloned */
11928     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11929     PERL_SET_THX(my_perl);
11930
11931 #ifdef DEBUGGING
11932     PoisonNew(my_perl, 1, PerlInterpreter);
11933     PL_op = NULL;
11934     PL_curcop = NULL;
11935     PL_markstack = 0;
11936     PL_scopestack = 0;
11937     PL_scopestack_name = 0;
11938     PL_savestack = 0;
11939     PL_savestack_ix = 0;
11940     PL_savestack_max = -1;
11941     PL_sig_pending = 0;
11942     PL_parser = NULL;
11943     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11944 #  ifdef DEBUG_LEAKING_SCALARS
11945     PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
11946 #  endif
11947 #else   /* !DEBUGGING */
11948     Zero(my_perl, 1, PerlInterpreter);
11949 #endif  /* DEBUGGING */
11950
11951 #ifdef PERL_IMPLICIT_SYS
11952     /* host pointers */
11953     PL_Mem              = ipM;
11954     PL_MemShared        = ipMS;
11955     PL_MemParse         = ipMP;
11956     PL_Env              = ipE;
11957     PL_StdIO            = ipStd;
11958     PL_LIO              = ipLIO;
11959     PL_Dir              = ipD;
11960     PL_Sock             = ipS;
11961     PL_Proc             = ipP;
11962 #endif          /* PERL_IMPLICIT_SYS */
11963
11964     param->flags = flags;
11965     param->proto_perl = proto_perl;
11966
11967     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11968
11969     PL_body_arenas = NULL;
11970     Zero(&PL_body_roots, 1, PL_body_roots);
11971
11972     PL_nice_chunk       = NULL;
11973     PL_nice_chunk_size  = 0;
11974     PL_sv_count         = 0;
11975     PL_sv_objcount      = 0;
11976     PL_sv_root          = NULL;
11977     PL_sv_arenaroot     = NULL;
11978
11979     PL_debug            = proto_perl->Idebug;
11980
11981     PL_hash_seed        = proto_perl->Ihash_seed;
11982     PL_rehash_seed      = proto_perl->Irehash_seed;
11983
11984 #ifdef USE_REENTRANT_API
11985     /* XXX: things like -Dm will segfault here in perlio, but doing
11986      *  PERL_SET_CONTEXT(proto_perl);
11987      * breaks too many other things
11988      */
11989     Perl_reentrant_init(aTHX);
11990 #endif
11991
11992     /* create SV map for pointer relocation */
11993     PL_ptr_table = ptr_table_new();
11994
11995     /* initialize these special pointers as early as possible */
11996     SvANY(&PL_sv_undef)         = NULL;
11997     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
11998     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
11999     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12000
12001     SvANY(&PL_sv_no)            = new_XPVNV();
12002     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
12003     SvFLAGS(&PL_sv_no)          = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12004                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12005     SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12006     SvCUR_set(&PL_sv_no, 0);
12007     SvLEN_set(&PL_sv_no, 1);
12008     SvIV_set(&PL_sv_no, 0);
12009     SvNV_set(&PL_sv_no, 0);
12010     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12011
12012     SvANY(&PL_sv_yes)           = new_XPVNV();
12013     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
12014     SvFLAGS(&PL_sv_yes)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12015                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12016     SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12017     SvCUR_set(&PL_sv_yes, 1);
12018     SvLEN_set(&PL_sv_yes, 2);
12019     SvIV_set(&PL_sv_yes, 1);
12020     SvNV_set(&PL_sv_yes, 1);
12021     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12022
12023     /* dbargs array probably holds garbage */
12024     PL_dbargs           = NULL;
12025
12026     /* create (a non-shared!) shared string table */
12027     PL_strtab           = newHV();
12028     HvSHAREKEYS_off(PL_strtab);
12029     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12030     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12031
12032     PL_compiling = proto_perl->Icompiling;
12033
12034     /* These two PVs will be free'd special way so must set them same way op.c does */
12035     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12036     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12037
12038     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
12039     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12040
12041     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12042     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12043     if (PL_compiling.cop_hints_hash) {
12044         HINTS_REFCNT_LOCK;
12045         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
12046         HINTS_REFCNT_UNLOCK;
12047     }
12048     PL_curcop           = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12049 #ifdef PERL_DEBUG_READONLY_OPS
12050     PL_slabs = NULL;
12051     PL_slab_count = 0;
12052 #endif
12053
12054     /* pseudo environmental stuff */
12055     PL_origargc         = proto_perl->Iorigargc;
12056     PL_origargv         = proto_perl->Iorigargv;
12057
12058     param->stashes      = newAV();  /* Setup array of objects to call clone on */
12059
12060     /* Set tainting stuff before PerlIO_debug can possibly get called */
12061     PL_tainting         = proto_perl->Itainting;
12062     PL_taint_warn       = proto_perl->Itaint_warn;
12063
12064 #ifdef PERLIO_LAYERS
12065     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12066     PerlIO_clone(aTHX_ proto_perl, param);
12067 #endif
12068
12069     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
12070     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
12071     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
12072     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
12073     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
12074     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
12075
12076     /* switches */
12077     PL_minus_c          = proto_perl->Iminus_c;
12078     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
12079     PL_localpatches     = proto_perl->Ilocalpatches;
12080     PL_splitstr         = proto_perl->Isplitstr;
12081     PL_minus_n          = proto_perl->Iminus_n;
12082     PL_minus_p          = proto_perl->Iminus_p;
12083     PL_minus_l          = proto_perl->Iminus_l;
12084     PL_minus_a          = proto_perl->Iminus_a;
12085     PL_minus_E          = proto_perl->Iminus_E;
12086     PL_minus_F          = proto_perl->Iminus_F;
12087     PL_doswitches       = proto_perl->Idoswitches;
12088     PL_dowarn           = proto_perl->Idowarn;
12089     PL_doextract        = proto_perl->Idoextract;
12090     PL_sawampersand     = proto_perl->Isawampersand;
12091     PL_unsafe           = proto_perl->Iunsafe;
12092     PL_inplace          = SAVEPV(proto_perl->Iinplace);
12093     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
12094     PL_perldb           = proto_perl->Iperldb;
12095     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12096     PL_exit_flags       = proto_perl->Iexit_flags;
12097
12098     /* magical thingies */
12099     /* XXX time(&PL_basetime) when asked for? */
12100     PL_basetime         = proto_perl->Ibasetime;
12101     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
12102
12103     PL_maxsysfd         = proto_perl->Imaxsysfd;
12104     PL_statusvalue      = proto_perl->Istatusvalue;
12105 #ifdef VMS
12106     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
12107 #else
12108     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12109 #endif
12110     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
12111
12112     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
12113     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
12114     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
12115
12116
12117     /* RE engine related */
12118     Zero(&PL_reg_state, 1, struct re_save_state);
12119     PL_reginterp_cnt    = 0;
12120     PL_regmatch_slab    = NULL;
12121
12122     /* Clone the regex array */
12123     /* ORANGE FIXME for plugins, probably in the SV dup code.
12124        newSViv(PTR2IV(CALLREGDUPE(
12125        INT2PTR(REGEXP *, SvIVX(regex)), param))))
12126     */
12127     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12128     PL_regex_pad = AvARRAY(PL_regex_padav);
12129
12130     /* shortcuts to various I/O objects */
12131     PL_ofsgv            = gv_dup(proto_perl->Iofsgv, param);
12132     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
12133     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
12134     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
12135     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
12136     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
12137     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
12138
12139     /* shortcuts to regexp stuff */
12140     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
12141
12142     /* shortcuts to misc objects */
12143     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
12144
12145     /* shortcuts to debugging objects */
12146     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
12147     PL_DBline           = gv_dup(proto_perl->IDBline, param);
12148     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
12149     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
12150     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
12151     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
12152
12153     /* symbol tables */
12154     PL_defstash         = hv_dup_inc(proto_perl->Idefstash, param);
12155     PL_curstash         = hv_dup(proto_perl->Icurstash, param);
12156     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
12157     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
12158     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
12159
12160     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
12161     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
12162     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
12163     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
12164     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12165     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
12166     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
12167     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
12168
12169     PL_sub_generation   = proto_perl->Isub_generation;
12170     PL_isarev           = hv_dup_inc(proto_perl->Iisarev, param);
12171
12172     /* funky return mechanisms */
12173     PL_forkprocess      = proto_perl->Iforkprocess;
12174
12175     /* subprocess state */
12176     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
12177
12178     /* internal state */
12179     PL_maxo             = proto_perl->Imaxo;
12180     if (proto_perl->Iop_mask)
12181         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12182     else
12183         PL_op_mask      = NULL;
12184     /* PL_asserting        = proto_perl->Iasserting; */
12185
12186     /* current interpreter roots */
12187     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
12188     OP_REFCNT_LOCK;
12189     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
12190     OP_REFCNT_UNLOCK;
12191     PL_main_start       = proto_perl->Imain_start;
12192     PL_eval_root        = proto_perl->Ieval_root;
12193     PL_eval_start       = proto_perl->Ieval_start;
12194
12195     /* runtime control stuff */
12196     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12197
12198     PL_filemode         = proto_perl->Ifilemode;
12199     PL_lastfd           = proto_perl->Ilastfd;
12200     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
12201     PL_Argv             = NULL;
12202     PL_Cmd              = NULL;
12203     PL_gensym           = proto_perl->Igensym;
12204     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
12205     PL_laststatval      = proto_perl->Ilaststatval;
12206     PL_laststype        = proto_perl->Ilaststype;
12207     PL_mess_sv          = NULL;
12208
12209     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
12210
12211     /* interpreter atexit processing */
12212     PL_exitlistlen      = proto_perl->Iexitlistlen;
12213     if (PL_exitlistlen) {
12214         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12215         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12216     }
12217     else
12218         PL_exitlist     = (PerlExitListEntry*)NULL;
12219
12220     PL_my_cxt_size = proto_perl->Imy_cxt_size;
12221     if (PL_my_cxt_size) {
12222         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12223         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12224 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12225         Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12226         Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12227 #endif
12228     }
12229     else {
12230         PL_my_cxt_list  = (void**)NULL;
12231 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12232         PL_my_cxt_keys  = (const char**)NULL;
12233 #endif
12234     }
12235     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
12236     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
12237     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12238
12239     PL_profiledata      = NULL;
12240
12241     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
12242
12243     PAD_CLONE_VARS(proto_perl, param);
12244
12245 #ifdef HAVE_INTERP_INTERN
12246     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12247 #endif
12248
12249     /* more statics moved here */
12250     PL_generation       = proto_perl->Igeneration;
12251     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
12252
12253     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
12254     PL_in_clean_all     = proto_perl->Iin_clean_all;
12255
12256     PL_uid              = proto_perl->Iuid;
12257     PL_euid             = proto_perl->Ieuid;
12258     PL_gid              = proto_perl->Igid;
12259     PL_egid             = proto_perl->Iegid;
12260     PL_nomemok          = proto_perl->Inomemok;
12261     PL_an               = proto_perl->Ian;
12262     PL_evalseq          = proto_perl->Ievalseq;
12263     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
12264     PL_origalen         = proto_perl->Iorigalen;
12265 #ifdef PERL_USES_PL_PIDSTATUS
12266     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
12267 #endif
12268     PL_osname           = SAVEPV(proto_perl->Iosname);
12269     PL_sighandlerp      = proto_perl->Isighandlerp;
12270
12271     PL_runops           = proto_perl->Irunops;
12272
12273     PL_parser           = parser_dup(proto_perl->Iparser, param);
12274
12275     /* XXX this only works if the saved cop has already been cloned */
12276     if (proto_perl->Iparser) {
12277         PL_parser->saved_curcop = (COP*)any_dup(
12278                                     proto_perl->Iparser->saved_curcop,
12279                                     proto_perl);
12280     }
12281
12282     PL_subline          = proto_perl->Isubline;
12283     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
12284
12285 #ifdef FCRYPT
12286     PL_cryptseen        = proto_perl->Icryptseen;
12287 #endif
12288
12289     PL_hints            = proto_perl->Ihints;
12290
12291     PL_amagic_generation        = proto_perl->Iamagic_generation;
12292
12293 #ifdef USE_LOCALE_COLLATE
12294     PL_collation_ix     = proto_perl->Icollation_ix;
12295     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
12296     PL_collation_standard       = proto_perl->Icollation_standard;
12297     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
12298     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
12299 #endif /* USE_LOCALE_COLLATE */
12300
12301 #ifdef USE_LOCALE_NUMERIC
12302     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
12303     PL_numeric_standard = proto_perl->Inumeric_standard;
12304     PL_numeric_local    = proto_perl->Inumeric_local;
12305     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12306 #endif /* !USE_LOCALE_NUMERIC */
12307
12308     /* utf8 character classes */
12309     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12310     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12311     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12312     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
12313     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12314     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
12315     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
12316     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
12317     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
12318     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
12319     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
12320     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12321     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
12322     PL_utf8_X_begin     = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
12323     PL_utf8_X_extend    = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
12324     PL_utf8_X_prepend   = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
12325     PL_utf8_X_non_hangul        = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
12326     PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
12327     PL_utf8_X_LV        = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
12328     PL_utf8_X_LVT       = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
12329     PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
12330     PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
12331     PL_utf8_X_LV_LVT_V  = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
12332     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12333     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12334     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12335     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12336     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12337     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12338
12339     /* Did the locale setup indicate UTF-8? */
12340     PL_utf8locale       = proto_perl->Iutf8locale;
12341     /* Unicode features (see perlrun/-C) */
12342     PL_unicode          = proto_perl->Iunicode;
12343
12344     /* Pre-5.8 signals control */
12345     PL_signals          = proto_perl->Isignals;
12346
12347     /* times() ticks per second */
12348     PL_clocktick        = proto_perl->Iclocktick;
12349
12350     /* Recursion stopper for PerlIO_find_layer */
12351     PL_in_load_module   = proto_perl->Iin_load_module;
12352
12353     /* sort() routine */
12354     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
12355
12356     /* Not really needed/useful since the reenrant_retint is "volatile",
12357      * but do it for consistency's sake. */
12358     PL_reentrant_retint = proto_perl->Ireentrant_retint;
12359
12360     /* Hooks to shared SVs and locks. */
12361     PL_sharehook        = proto_perl->Isharehook;
12362     PL_lockhook         = proto_perl->Ilockhook;
12363     PL_unlockhook       = proto_perl->Iunlockhook;
12364     PL_threadhook       = proto_perl->Ithreadhook;
12365     PL_destroyhook      = proto_perl->Idestroyhook;
12366
12367 #ifdef THREADS_HAVE_PIDS
12368     PL_ppid             = proto_perl->Ippid;
12369 #endif
12370
12371     /* swatch cache */
12372     PL_last_swash_hv    = NULL; /* reinits on demand */
12373     PL_last_swash_klen  = 0;
12374     PL_last_swash_key[0]= '\0';
12375     PL_last_swash_tmps  = (U8*)NULL;
12376     PL_last_swash_slen  = 0;
12377
12378     PL_glob_index       = proto_perl->Iglob_index;
12379     PL_srand_called     = proto_perl->Isrand_called;
12380
12381     if (proto_perl->Ipsig_pend) {
12382         Newxz(PL_psig_pend, SIG_SIZE, int);
12383     }
12384     else {
12385         PL_psig_pend    = (int*)NULL;
12386     }
12387
12388     if (proto_perl->Ipsig_name) {
12389         Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
12390         sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
12391                             param);
12392         PL_psig_ptr = PL_psig_name + SIG_SIZE;
12393     }
12394     else {
12395         PL_psig_ptr     = (SV**)NULL;
12396         PL_psig_name    = (SV**)NULL;
12397     }
12398
12399     /* intrpvar.h stuff */
12400
12401     if (flags & CLONEf_COPY_STACKS) {
12402         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12403         PL_tmps_ix              = proto_perl->Itmps_ix;
12404         PL_tmps_max             = proto_perl->Itmps_max;
12405         PL_tmps_floor           = proto_perl->Itmps_floor;
12406         Newx(PL_tmps_stack, PL_tmps_max, SV*);
12407         sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
12408                             PL_tmps_ix+1, param);
12409
12410         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12411         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12412         Newxz(PL_markstack, i, I32);
12413         PL_markstack_max        = PL_markstack + (proto_perl->Imarkstack_max
12414                                                   - proto_perl->Imarkstack);
12415         PL_markstack_ptr        = PL_markstack + (proto_perl->Imarkstack_ptr
12416                                                   - proto_perl->Imarkstack);
12417         Copy(proto_perl->Imarkstack, PL_markstack,
12418              PL_markstack_ptr - PL_markstack + 1, I32);
12419
12420         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12421          * NOTE: unlike the others! */
12422         PL_scopestack_ix        = proto_perl->Iscopestack_ix;
12423         PL_scopestack_max       = proto_perl->Iscopestack_max;
12424         Newxz(PL_scopestack, PL_scopestack_max, I32);
12425         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12426
12427 #ifdef DEBUGGING
12428         Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
12429         Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
12430 #endif
12431         /* NOTE: si_dup() looks at PL_markstack */
12432         PL_curstackinfo         = si_dup(proto_perl->Icurstackinfo, param);
12433
12434         /* PL_curstack          = PL_curstackinfo->si_stack; */
12435         PL_curstack             = av_dup(proto_perl->Icurstack, param);
12436         PL_mainstack            = av_dup(proto_perl->Imainstack, param);
12437
12438         /* next PUSHs() etc. set *(PL_stack_sp+1) */
12439         PL_stack_base           = AvARRAY(PL_curstack);
12440         PL_stack_sp             = PL_stack_base + (proto_perl->Istack_sp
12441                                                    - proto_perl->Istack_base);
12442         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
12443
12444         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12445          * NOTE: unlike the others! */
12446         PL_savestack_ix         = proto_perl->Isavestack_ix;
12447         PL_savestack_max        = proto_perl->Isavestack_max;
12448         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12449         PL_savestack            = ss_dup(proto_perl, param);
12450     }
12451     else {
12452         init_stacks();
12453         ENTER;                  /* perl_destruct() wants to LEAVE; */
12454
12455         /* although we're not duplicating the tmps stack, we should still
12456          * add entries for any SVs on the tmps stack that got cloned by a
12457          * non-refcount means (eg a temp in @_); otherwise they will be
12458          * orphaned
12459          */
12460         for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12461             SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
12462                     proto_perl->Itmps_stack[i]));
12463             if (nsv && !SvREFCNT(nsv)) {
12464                 PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv));
12465             }
12466         }
12467     }
12468
12469     PL_start_env        = proto_perl->Istart_env;       /* XXXXXX */
12470     PL_top_env          = &PL_start_env;
12471
12472     PL_op               = proto_perl->Iop;
12473
12474     PL_Sv               = NULL;
12475     PL_Xpv              = (XPV*)NULL;
12476     my_perl->Ina        = proto_perl->Ina;
12477
12478     PL_statbuf          = proto_perl->Istatbuf;
12479     PL_statcache        = proto_perl->Istatcache;
12480     PL_statgv           = gv_dup(proto_perl->Istatgv, param);
12481     PL_statname         = sv_dup_inc(proto_perl->Istatname, param);
12482 #ifdef HAS_TIMES
12483     PL_timesbuf         = proto_perl->Itimesbuf;
12484 #endif
12485
12486     PL_tainted          = proto_perl->Itainted;
12487     PL_curpm            = proto_perl->Icurpm;   /* XXX No PMOP ref count */
12488     PL_rs               = sv_dup_inc(proto_perl->Irs, param);
12489     PL_last_in_gv       = gv_dup(proto_perl->Ilast_in_gv, param);
12490     PL_defoutgv         = gv_dup_inc(proto_perl->Idefoutgv, param);
12491     PL_chopset          = proto_perl->Ichopset; /* XXX never deallocated */
12492     PL_toptarget        = sv_dup_inc(proto_perl->Itoptarget, param);
12493     PL_bodytarget       = sv_dup_inc(proto_perl->Ibodytarget, param);
12494     PL_formtarget       = sv_dup(proto_perl->Iformtarget, param);
12495
12496     PL_restartjmpenv    = proto_perl->Irestartjmpenv;
12497     PL_restartop        = proto_perl->Irestartop;
12498     PL_in_eval          = proto_perl->Iin_eval;
12499     PL_delaymagic       = proto_perl->Idelaymagic;
12500     PL_dirty            = proto_perl->Idirty;
12501     PL_localizing       = proto_perl->Ilocalizing;
12502
12503     PL_errors           = sv_dup_inc(proto_perl->Ierrors, param);
12504     PL_hv_fetch_ent_mh  = NULL;
12505     PL_modcount         = proto_perl->Imodcount;
12506     PL_lastgotoprobe    = NULL;
12507     PL_dumpindent       = proto_perl->Idumpindent;
12508
12509     PL_sortcop          = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12510     PL_sortstash        = hv_dup(proto_perl->Isortstash, param);
12511     PL_firstgv          = gv_dup(proto_perl->Ifirstgv, param);
12512     PL_secondgv         = gv_dup(proto_perl->Isecondgv, param);
12513     PL_efloatbuf        = NULL;         /* reinits on demand */
12514     PL_efloatsize       = 0;                    /* reinits on demand */
12515
12516     /* regex stuff */
12517
12518     PL_screamfirst      = NULL;
12519     PL_screamnext       = NULL;
12520     PL_maxscream        = -1;                   /* reinits on demand */
12521     PL_lastscream       = NULL;
12522
12523
12524     PL_regdummy         = proto_perl->Iregdummy;
12525     PL_colorset         = 0;            /* reinits PL_colors[] */
12526     /*PL_colors[6]      = {0,0,0,0,0,0};*/
12527
12528
12529
12530     /* Pluggable optimizer */
12531     PL_peepp            = proto_perl->Ipeepp;
12532     /* op_free() hook */
12533     PL_opfreehook       = proto_perl->Iopfreehook;
12534
12535     PL_stashcache       = newHV();
12536
12537     PL_watchaddr        = (char **) ptr_table_fetch(PL_ptr_table,
12538                                             proto_perl->Iwatchaddr);
12539     PL_watchok          = PL_watchaddr ? * PL_watchaddr : NULL;
12540     if (PL_debug && PL_watchaddr) {
12541         PerlIO_printf(Perl_debug_log,
12542           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12543           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12544           PTR2UV(PL_watchok));
12545     }
12546
12547     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
12548
12549     /* Call the ->CLONE method, if it exists, for each of the stashes
12550        identified by sv_dup() above.
12551     */
12552     while(av_len(param->stashes) != -1) {
12553         HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12554         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12555         if (cloner && GvCV(cloner)) {
12556             dSP;
12557             ENTER;
12558             SAVETMPS;
12559             PUSHMARK(SP);
12560             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12561             PUTBACK;
12562             call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
12563             FREETMPS;
12564             LEAVE;
12565         }
12566     }
12567
12568     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12569         ptr_table_free(PL_ptr_table);
12570         PL_ptr_table = NULL;
12571     }
12572
12573
12574     SvREFCNT_dec(param->stashes);
12575
12576     /* orphaned? eg threads->new inside BEGIN or use */
12577     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12578         SvREFCNT_inc_simple_void(PL_compcv);
12579         SAVEFREESV(PL_compcv);
12580     }
12581
12582     return my_perl;
12583 }
12584
12585 #endif /* USE_ITHREADS */
12586
12587 /*
12588 =head1 Unicode Support
12589
12590 =for apidoc sv_recode_to_utf8
12591
12592 The encoding is assumed to be an Encode object, on entry the PV
12593 of the sv is assumed to be octets in that encoding, and the sv
12594 will be converted into Unicode (and UTF-8).
12595
12596 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12597 is not a reference, nothing is done to the sv.  If the encoding is not
12598 an C<Encode::XS> Encoding object, bad things will happen.
12599 (See F<lib/encoding.pm> and L<Encode>).
12600
12601 The PV of the sv is returned.
12602
12603 =cut */
12604
12605 char *
12606 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12607 {
12608     dVAR;
12609
12610     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12611
12612     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12613         SV *uni;
12614         STRLEN len;
12615         const char *s;
12616         dSP;
12617         ENTER;
12618         SAVETMPS;
12619         save_re_context();
12620         PUSHMARK(sp);
12621         EXTEND(SP, 3);
12622         XPUSHs(encoding);
12623         XPUSHs(sv);
12624 /*
12625   NI-S 2002/07/09
12626   Passing sv_yes is wrong - it needs to be or'ed set of constants
12627   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12628   remove converted chars from source.
12629
12630   Both will default the value - let them.
12631
12632         XPUSHs(&PL_sv_yes);
12633 */
12634         PUTBACK;
12635         call_method("decode", G_SCALAR);
12636         SPAGAIN;
12637         uni = POPs;
12638         PUTBACK;
12639         s = SvPV_const(uni, len);
12640         if (s != SvPVX_const(sv)) {
12641             SvGROW(sv, len + 1);
12642             Move(s, SvPVX(sv), len + 1, char);
12643             SvCUR_set(sv, len);
12644         }
12645         FREETMPS;
12646         LEAVE;
12647         SvUTF8_on(sv);
12648         return SvPVX(sv);
12649     }
12650     return SvPOKp(sv) ? SvPVX(sv) : NULL;
12651 }
12652
12653 /*
12654 =for apidoc sv_cat_decode
12655
12656 The encoding is assumed to be an Encode object, the PV of the ssv is
12657 assumed to be octets in that encoding and decoding the input starts
12658 from the position which (PV + *offset) pointed to.  The dsv will be
12659 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
12660 when the string tstr appears in decoding output or the input ends on
12661 the PV of the ssv. The value which the offset points will be modified
12662 to the last input position on the ssv.
12663
12664 Returns TRUE if the terminator was found, else returns FALSE.
12665
12666 =cut */
12667
12668 bool
12669 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12670                    SV *ssv, int *offset, char *tstr, int tlen)
12671 {
12672     dVAR;
12673     bool ret = FALSE;
12674
12675     PERL_ARGS_ASSERT_SV_CAT_DECODE;
12676
12677     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12678         SV *offsv;
12679         dSP;
12680         ENTER;
12681         SAVETMPS;
12682         save_re_context();
12683         PUSHMARK(sp);
12684         EXTEND(SP, 6);
12685         XPUSHs(encoding);
12686         XPUSHs(dsv);
12687         XPUSHs(ssv);
12688         offsv = newSViv(*offset);
12689         mXPUSHs(offsv);
12690         mXPUSHp(tstr, tlen);
12691         PUTBACK;
12692         call_method("cat_decode", G_SCALAR);
12693         SPAGAIN;
12694         ret = SvTRUE(TOPs);
12695         *offset = SvIV(offsv);
12696         PUTBACK;
12697         FREETMPS;
12698         LEAVE;
12699     }
12700     else
12701         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12702     return ret;
12703
12704 }
12705
12706 /* ---------------------------------------------------------------------
12707  *
12708  * support functions for report_uninit()
12709  */
12710
12711 /* the maxiumum size of array or hash where we will scan looking
12712  * for the undefined element that triggered the warning */
12713
12714 #define FUV_MAX_SEARCH_SIZE 1000
12715
12716 /* Look for an entry in the hash whose value has the same SV as val;
12717  * If so, return a mortal copy of the key. */
12718
12719 STATIC SV*
12720 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
12721 {
12722     dVAR;
12723     register HE **array;
12724     I32 i;
12725
12726     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12727
12728     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12729                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12730         return NULL;
12731
12732     array = HvARRAY(hv);
12733
12734     for (i=HvMAX(hv); i>0; i--) {
12735         register HE *entry;
12736         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12737             if (HeVAL(entry) != val)
12738                 continue;
12739             if (    HeVAL(entry) == &PL_sv_undef ||
12740                     HeVAL(entry) == &PL_sv_placeholder)
12741                 continue;
12742             if (!HeKEY(entry))
12743                 return NULL;
12744             if (HeKLEN(entry) == HEf_SVKEY)
12745                 return sv_mortalcopy(HeKEY_sv(entry));
12746             return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12747         }
12748     }
12749     return NULL;
12750 }
12751
12752 /* Look for an entry in the array whose value has the same SV as val;
12753  * If so, return the index, otherwise return -1. */
12754
12755 STATIC I32
12756 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
12757 {
12758     dVAR;
12759
12760     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12761
12762     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12763                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12764         return -1;
12765
12766     if (val != &PL_sv_undef) {
12767         SV ** const svp = AvARRAY(av);
12768         I32 i;
12769
12770         for (i=AvFILLp(av); i>=0; i--)
12771             if (svp[i] == val)
12772                 return i;
12773     }
12774     return -1;
12775 }
12776
12777 /* S_varname(): return the name of a variable, optionally with a subscript.
12778  * If gv is non-zero, use the name of that global, along with gvtype (one
12779  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12780  * targ.  Depending on the value of the subscript_type flag, return:
12781  */
12782
12783 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
12784 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
12785 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
12786 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
12787
12788 STATIC SV*
12789 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
12790         const SV *const keyname, I32 aindex, int subscript_type)
12791 {
12792
12793     SV * const name = sv_newmortal();
12794     if (gv) {
12795         char buffer[2];
12796         buffer[0] = gvtype;
12797         buffer[1] = 0;
12798
12799         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
12800
12801         gv_fullname4(name, gv, buffer, 0);
12802
12803         if ((unsigned int)SvPVX(name)[1] <= 26) {
12804             buffer[0] = '^';
12805             buffer[1] = SvPVX(name)[1] + 'A' - 1;
12806
12807             /* Swap the 1 unprintable control character for the 2 byte pretty
12808                version - ie substr($name, 1, 1) = $buffer; */
12809             sv_insert(name, 1, 1, buffer, 2);
12810         }
12811     }
12812     else {
12813         CV * const cv = find_runcv(NULL);
12814         SV *sv;
12815         AV *av;
12816
12817         if (!cv || !CvPADLIST(cv))
12818             return NULL;
12819         av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
12820         sv = *av_fetch(av, targ, FALSE);
12821         sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12822     }
12823
12824     if (subscript_type == FUV_SUBSCRIPT_HASH) {
12825         SV * const sv = newSV(0);
12826         *SvPVX(name) = '$';
12827         Perl_sv_catpvf(aTHX_ name, "{%s}",
12828             pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12829         SvREFCNT_dec(sv);
12830     }
12831     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12832         *SvPVX(name) = '$';
12833         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12834     }
12835     else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12836         /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12837         Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
12838     }
12839
12840     return name;
12841 }
12842
12843
12844 /*
12845 =for apidoc find_uninit_var
12846
12847 Find the name of the undefined variable (if any) that caused the operator o
12848 to issue a "Use of uninitialized value" warning.
12849 If match is true, only return a name if it's value matches uninit_sv.
12850 So roughly speaking, if a unary operator (such as OP_COS) generates a
12851 warning, then following the direct child of the op may yield an
12852 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12853 other hand, with OP_ADD there are two branches to follow, so we only print
12854 the variable name if we get an exact match.
12855
12856 The name is returned as a mortal SV.
12857
12858 Assumes that PL_op is the op that originally triggered the error, and that
12859 PL_comppad/PL_curpad points to the currently executing pad.
12860
12861 =cut
12862 */
12863
12864 STATIC SV *
12865 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
12866                   bool match)
12867 {
12868     dVAR;
12869     SV *sv;
12870     const GV *gv;
12871     const OP *o, *o2, *kid;
12872
12873     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12874                             uninit_sv == &PL_sv_placeholder)))
12875         return NULL;
12876
12877     switch (obase->op_type) {
12878
12879     case OP_RV2AV:
12880     case OP_RV2HV:
12881     case OP_PADAV:
12882     case OP_PADHV:
12883       {
12884         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12885         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12886         I32 index = 0;
12887         SV *keysv = NULL;
12888         int subscript_type = FUV_SUBSCRIPT_WITHIN;
12889
12890         if (pad) { /* @lex, %lex */
12891             sv = PAD_SVl(obase->op_targ);
12892             gv = NULL;
12893         }
12894         else {
12895             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12896             /* @global, %global */
12897                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12898                 if (!gv)
12899                     break;
12900                 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
12901             }
12902             else /* @{expr}, %{expr} */
12903                 return find_uninit_var(cUNOPx(obase)->op_first,
12904                                                     uninit_sv, match);
12905         }
12906
12907         /* attempt to find a match within the aggregate */
12908         if (hash) {
12909             keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12910             if (keysv)
12911                 subscript_type = FUV_SUBSCRIPT_HASH;
12912         }
12913         else {
12914             index = find_array_subscript((const AV *)sv, uninit_sv);
12915             if (index >= 0)
12916                 subscript_type = FUV_SUBSCRIPT_ARRAY;
12917         }
12918
12919         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12920             break;
12921
12922         return varname(gv, hash ? '%' : '@', obase->op_targ,
12923                                     keysv, index, subscript_type);
12924       }
12925
12926     case OP_PADSV:
12927         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12928             break;
12929         return varname(NULL, '$', obase->op_targ,
12930                                     NULL, 0, FUV_SUBSCRIPT_NONE);
12931
12932     case OP_GVSV:
12933         gv = cGVOPx_gv(obase);
12934         if (!gv || (match && GvSV(gv) != uninit_sv))
12935             break;
12936         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12937
12938     case OP_AELEMFAST:
12939         if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12940             if (match) {
12941                 SV **svp;
12942                 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
12943                 if (!av || SvRMAGICAL(av))
12944                     break;
12945                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12946                 if (!svp || *svp != uninit_sv)
12947                     break;
12948             }
12949             return varname(NULL, '$', obase->op_targ,
12950                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12951         }
12952         else {
12953             gv = cGVOPx_gv(obase);
12954             if (!gv)
12955                 break;
12956             if (match) {
12957                 SV **svp;
12958                 AV *const av = GvAV(gv);
12959                 if (!av || SvRMAGICAL(av))
12960                     break;
12961                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12962                 if (!svp || *svp != uninit_sv)
12963                     break;
12964             }
12965             return varname(gv, '$', 0,
12966                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12967         }
12968         break;
12969
12970     case OP_EXISTS:
12971         o = cUNOPx(obase)->op_first;
12972         if (!o || o->op_type != OP_NULL ||
12973                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12974             break;
12975         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12976
12977     case OP_AELEM:
12978     case OP_HELEM:
12979         if (PL_op == obase)
12980             /* $a[uninit_expr] or $h{uninit_expr} */
12981             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12982
12983         gv = NULL;
12984         o = cBINOPx(obase)->op_first;
12985         kid = cBINOPx(obase)->op_last;
12986
12987         /* get the av or hv, and optionally the gv */
12988         sv = NULL;
12989         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12990             sv = PAD_SV(o->op_targ);
12991         }
12992         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12993                 && cUNOPo->op_first->op_type == OP_GV)
12994         {
12995             gv = cGVOPx_gv(cUNOPo->op_first);
12996             if (!gv)
12997                 break;
12998             sv = o->op_type
12999                 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13000         }
13001         if (!sv)
13002             break;
13003
13004         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13005             /* index is constant */
13006             if (match) {
13007                 if (SvMAGICAL(sv))
13008                     break;
13009                 if (obase->op_type == OP_HELEM) {
13010                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13011                     if (!he || HeVAL(he) != uninit_sv)
13012                         break;
13013                 }
13014                 else {
13015                     SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13016                     if (!svp || *svp != uninit_sv)
13017                         break;
13018                 }
13019             }
13020             if (obase->op_type == OP_HELEM)
13021                 return varname(gv, '%', o->op_targ,
13022                             cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13023             else
13024                 return varname(gv, '@', o->op_targ, NULL,
13025                             SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13026         }
13027         else  {
13028             /* index is an expression;
13029              * attempt to find a match within the aggregate */
13030             if (obase->op_type == OP_HELEM) {
13031                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13032                 if (keysv)
13033                     return varname(gv, '%', o->op_targ,
13034                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
13035             }
13036             else {
13037                 const I32 index
13038                     = find_array_subscript((const AV *)sv, uninit_sv);
13039                 if (index >= 0)
13040                     return varname(gv, '@', o->op_targ,
13041                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
13042             }
13043             if (match)
13044                 break;
13045             return varname(gv,
13046                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13047                 ? '@' : '%',
13048                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13049         }
13050         break;
13051
13052     case OP_AASSIGN:
13053         /* only examine RHS */
13054         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13055
13056     case OP_OPEN:
13057         o = cUNOPx(obase)->op_first;
13058         if (o->op_type == OP_PUSHMARK)
13059             o = o->op_sibling;
13060
13061         if (!o->op_sibling) {
13062             /* one-arg version of open is highly magical */
13063
13064             if (o->op_type == OP_GV) { /* open FOO; */
13065                 gv = cGVOPx_gv(o);
13066                 if (match && GvSV(gv) != uninit_sv)
13067                     break;
13068                 return varname(gv, '$', 0,
13069                             NULL, 0, FUV_SUBSCRIPT_NONE);
13070             }
13071             /* other possibilities not handled are:
13072              * open $x; or open my $x;  should return '${*$x}'
13073              * open expr;               should return '$'.expr ideally
13074              */
13075              break;
13076         }
13077         goto do_op;
13078
13079     /* ops where $_ may be an implicit arg */
13080     case OP_TRANS:
13081     case OP_SUBST:
13082     case OP_MATCH:
13083         if ( !(obase->op_flags & OPf_STACKED)) {
13084             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13085                                  ? PAD_SVl(obase->op_targ)
13086                                  : DEFSV))
13087             {
13088                 sv = sv_newmortal();
13089                 sv_setpvs(sv, "$_");
13090                 return sv;
13091             }
13092         }
13093         goto do_op;
13094
13095     case OP_PRTF:
13096     case OP_PRINT:
13097     case OP_SAY:
13098         match = 1; /* print etc can return undef on defined args */
13099         /* skip filehandle as it can't produce 'undef' warning  */
13100         o = cUNOPx(obase)->op_first;
13101         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13102             o = o->op_sibling->op_sibling;
13103         goto do_op2;
13104
13105
13106     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13107     case OP_RV2SV:
13108     case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13109
13110         /* the following ops are capable of returning PL_sv_undef even for
13111          * defined arg(s) */
13112
13113     case OP_BACKTICK:
13114     case OP_PIPE_OP:
13115     case OP_FILENO:
13116     case OP_BINMODE:
13117     case OP_TIED:
13118     case OP_GETC:
13119     case OP_SYSREAD:
13120     case OP_SEND:
13121     case OP_IOCTL:
13122     case OP_SOCKET:
13123     case OP_SOCKPAIR:
13124     case OP_BIND:
13125     case OP_CONNECT:
13126     case OP_LISTEN:
13127     case OP_ACCEPT:
13128     case OP_SHUTDOWN:
13129     case OP_SSOCKOPT:
13130     case OP_GETPEERNAME:
13131     case OP_FTRREAD:
13132     case OP_FTRWRITE:
13133     case OP_FTREXEC:
13134     case OP_FTROWNED:
13135     case OP_FTEREAD:
13136     case OP_FTEWRITE:
13137     case OP_FTEEXEC:
13138     case OP_FTEOWNED:
13139     case OP_FTIS:
13140     case OP_FTZERO:
13141     case OP_FTSIZE:
13142     case OP_FTFILE:
13143     case OP_FTDIR:
13144     case OP_FTLINK:
13145     case OP_FTPIPE:
13146     case OP_FTSOCK:
13147     case OP_FTBLK:
13148     case OP_FTCHR:
13149     case OP_FTTTY:
13150     case OP_FTSUID:
13151     case OP_FTSGID:
13152     case OP_FTSVTX:
13153     case OP_FTTEXT:
13154     case OP_FTBINARY:
13155     case OP_FTMTIME:
13156     case OP_FTATIME:
13157     case OP_FTCTIME:
13158     case OP_READLINK:
13159     case OP_OPEN_DIR:
13160     case OP_READDIR:
13161     case OP_TELLDIR:
13162     case OP_SEEKDIR:
13163     case OP_REWINDDIR:
13164     case OP_CLOSEDIR:
13165     case OP_GMTIME:
13166     case OP_ALARM:
13167     case OP_SEMGET:
13168     case OP_GETLOGIN:
13169     case OP_UNDEF:
13170     case OP_SUBSTR:
13171     case OP_AEACH:
13172     case OP_EACH:
13173     case OP_SORT:
13174     case OP_CALLER:
13175     case OP_DOFILE:
13176     case OP_PROTOTYPE:
13177     case OP_NCMP:
13178     case OP_SMARTMATCH:
13179     case OP_UNPACK:
13180     case OP_SYSOPEN:
13181     case OP_SYSSEEK:
13182         match = 1;
13183         goto do_op;
13184
13185     case OP_ENTERSUB:
13186     case OP_GOTO:
13187         /* XXX tmp hack: these two may call an XS sub, and currently
13188           XS subs don't have a SUB entry on the context stack, so CV and
13189           pad determination goes wrong, and BAD things happen. So, just
13190           don't try to determine the value under those circumstances.
13191           Need a better fix at dome point. DAPM 11/2007 */
13192         break;
13193
13194     case OP_FLIP:
13195     case OP_FLOP:
13196     {
13197         GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
13198         if (gv && GvSV(gv) == uninit_sv)
13199             return newSVpvs_flags("$.", SVs_TEMP);
13200         goto do_op;
13201     }
13202
13203     case OP_POS:
13204         /* def-ness of rval pos() is independent of the def-ness of its arg */
13205         if ( !(obase->op_flags & OPf_MOD))
13206             break;
13207
13208     case OP_SCHOMP:
13209     case OP_CHOMP:
13210         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13211             return newSVpvs_flags("${$/}", SVs_TEMP);
13212         /*FALLTHROUGH*/
13213
13214     default:
13215     do_op:
13216         if (!(obase->op_flags & OPf_KIDS))
13217             break;
13218         o = cUNOPx(obase)->op_first;
13219
13220     do_op2:
13221         if (!o)
13222             break;
13223
13224         /* if all except one arg are constant, or have no side-effects,
13225          * or are optimized away, then it's unambiguous */
13226         o2 = NULL;
13227         for (kid=o; kid; kid = kid->op_sibling) {
13228             if (kid) {
13229                 const OPCODE type = kid->op_type;
13230                 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13231                   || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
13232                   || (type == OP_PUSHMARK)
13233                 )
13234                 continue;
13235             }
13236             if (o2) { /* more than one found */
13237                 o2 = NULL;
13238                 break;
13239             }
13240             o2 = kid;
13241         }
13242         if (o2)
13243             return find_uninit_var(o2, uninit_sv, match);
13244
13245         /* scan all args */
13246         while (o) {
13247             sv = find_uninit_var(o, uninit_sv, 1);
13248             if (sv)
13249                 return sv;
13250             o = o->op_sibling;
13251         }
13252         break;
13253     }
13254     return NULL;
13255 }
13256
13257
13258 /*
13259 =for apidoc report_uninit
13260
13261 Print appropriate "Use of uninitialized variable" warning
13262
13263 =cut
13264 */
13265
13266 void
13267 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13268 {
13269     dVAR;
13270     if (PL_op) {
13271         SV* varname = NULL;
13272         if (uninit_sv) {
13273             varname = find_uninit_var(PL_op, uninit_sv,0);
13274             if (varname)
13275                 sv_insert(varname, 0, 0, " ", 1);
13276         }
13277         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13278                 varname ? SvPV_nolen_const(varname) : "",
13279                 " in ", OP_DESC(PL_op));
13280     }
13281     else
13282         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13283                     "", "", "");
13284 }
13285
13286 /*
13287  * Local variables:
13288  * c-indentation-style: bsd
13289  * c-basic-offset: 4
13290  * indent-tabs-mode: t
13291  * End:
13292  *
13293  * ex: set ts=8 sts=4 sw=4 noet:
13294  */