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