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