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