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