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