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