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