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