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