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