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