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