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