sv.c

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