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