sv.c

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