sv.c

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