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