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