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