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 pessimistic 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                 (!SvROK(tmpstr) || (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                 (!SvROK(tmpstr) || (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                 (!SvROK(tmpstr) || (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, *origsv;
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                 (!SvROK(tmpstr) || (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             origsv = sv;
2943             sv = (SV*)SvRV(sv);
2944             if (!sv)
2945                 s = "NULLREF";
2946             else {
2947                 MAGIC *mg;
2948
2949                 switch (SvTYPE(sv)) {
2950                 case SVt_PVMG:
2951                     if ( ((SvFLAGS(sv) &
2952                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2953                           == (SVs_OBJECT|SVs_RMG))
2954                          && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2955                         regexp *re = (regexp *)mg->mg_obj;
2956
2957                         if (!mg->mg_ptr) {
2958                             char *fptr = "msix";
2959                             char reflags[6];
2960                             char ch;
2961                             int left = 0;
2962                             int right = 4;
2963                             char need_newline = 0;
2964                             U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2965
2966                             while((ch = *fptr++)) {
2967                                 if(reganch & 1) {
2968                                     reflags[left++] = ch;
2969                                 }
2970                                 else {
2971                                     reflags[right--] = ch;
2972                                 }
2973                                 reganch >>= 1;
2974                             }
2975                             if(left != 4) {
2976                                 reflags[left] = '-';
2977                                 left = 5;
2978                             }
2979
2980                             mg->mg_len = re->prelen + 4 + left;
2981                             /*
2982                              * If /x was used, we have to worry about a regex
2983                              * ending with a comment later being embedded
2984                              * within another regex. If so, we don't want this
2985                              * regex's "commentization" to leak out to the
2986                              * right part of the enclosing regex, we must cap
2987                              * it with a newline.
2988                              *
2989                              * So, if /x was used, we scan backwards from the
2990                              * end of the regex. If we find a '#' before we
2991                              * find a newline, we need to add a newline
2992                              * ourself. If we find a '\n' first (or if we
2993                              * don't find '#' or '\n'), we don't need to add
2994                              * anything.  -jfriedl
2995                              */
2996                             if (PMf_EXTENDED & re->reganch)
2997                             {
2998                                 char *endptr = re->precomp + re->prelen;
2999                                 while (endptr >= re->precomp)
3000                                 {
3001                                     char c = *(endptr--);
3002                                     if (c == '\n')
3003                                         break; /* don't need another */
3004                                     if (c == '#') {
3005                                         /* we end while in a comment, so we
3006                                            need a newline */
3007                                         mg->mg_len++; /* save space for it */
3008                                         need_newline = 1; /* note to add it */
3009                                         break;
3010                                     }
3011                                 }
3012                             }
3013
3014                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3015                             Copy("(?", mg->mg_ptr, 2, char);
3016                             Copy(reflags, mg->mg_ptr+2, left, char);
3017                             Copy(":", mg->mg_ptr+left+2, 1, char);
3018                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3019                             if (need_newline)
3020                                 mg->mg_ptr[mg->mg_len - 2] = '\n';
3021                             mg->mg_ptr[mg->mg_len - 1] = ')';
3022                             mg->mg_ptr[mg->mg_len] = 0;
3023                         }
3024                         PL_reginterp_cnt += re->program[0].next_off;
3025
3026                         if (re->reganch & ROPT_UTF8)
3027                             SvUTF8_on(origsv);
3028                         else
3029                             SvUTF8_off(origsv);
3030                         *lp = mg->mg_len;
3031                         return mg->mg_ptr;
3032                     }
3033                                         /* Fall through */
3034                 case SVt_NULL:
3035                 case SVt_IV:
3036                 case SVt_NV:
3037                 case SVt_RV:
3038                 case SVt_PV:
3039                 case SVt_PVIV:
3040                 case SVt_PVNV:
3041                 case SVt_PVBM:  if (SvROK(sv))
3042                                     s = "REF";
3043                                 else
3044                                     s = "SCALAR";               break;
3045                 case SVt_PVLV:  s = "LVALUE";                   break;
3046                 case SVt_PVAV:  s = "ARRAY";                    break;
3047                 case SVt_PVHV:  s = "HASH";                     break;
3048                 case SVt_PVCV:  s = "CODE";                     break;
3049                 case SVt_PVGV:  s = "GLOB";                     break;
3050                 case SVt_PVFM:  s = "FORMAT";                   break;
3051                 case SVt_PVIO:  s = "IO";                       break;
3052                 default:        s = "UNKNOWN";                  break;
3053                 }
3054                 tsv = NEWSV(0,0);
3055                 if (SvOBJECT(sv))
3056                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
3057                 else
3058                     sv_setpv(tsv, s);
3059                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3060                 goto tokensaveref;
3061             }
3062             *lp = strlen(s);
3063             return s;
3064         }
3065         if (SvREADONLY(sv) && !SvOK(sv)) {
3066             if (ckWARN(WARN_UNINITIALIZED))
3067                 report_uninit();
3068             *lp = 0;
3069             return "";
3070         }
3071     }
3072     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3073         /* I'm assuming that if both IV and NV are equally valid then
3074            converting the IV is going to be more efficient */
3075         U32 isIOK = SvIOK(sv);
3076         U32 isUIOK = SvIsUV(sv);
3077         char buf[TYPE_CHARS(UV)];
3078         char *ebuf, *ptr;
3079
3080         if (SvTYPE(sv) < SVt_PVIV)
3081             sv_upgrade(sv, SVt_PVIV);
3082         if (isUIOK)
3083             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3084         else
3085             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3086         SvGROW(sv, (STRLEN)(ebuf - ptr + 1));   /* inlined from sv_setpvn */
3087         Move(ptr,SvPVX(sv),ebuf - ptr,char);
3088         SvCUR_set(sv, ebuf - ptr);
3089         s = SvEND(sv);
3090         *s = '\0';
3091         if (isIOK)
3092             SvIOK_on(sv);
3093         else
3094             SvIOKp_on(sv);
3095         if (isUIOK)
3096             SvIsUV_on(sv);
3097     }
3098     else if (SvNOKp(sv)) {
3099         if (SvTYPE(sv) < SVt_PVNV)
3100             sv_upgrade(sv, SVt_PVNV);
3101         /* The +20 is pure guesswork.  Configure test needed. --jhi */
3102         SvGROW(sv, NV_DIG + 20);
3103         s = SvPVX(sv);
3104         olderrno = errno;       /* some Xenix systems wipe out errno here */
3105 #ifdef apollo
3106         if (SvNVX(sv) == 0.0)
3107             (void)strcpy(s,"0");
3108         else
3109 #endif /*apollo*/
3110         {
3111             Gconvert(SvNVX(sv), NV_DIG, 0, s);
3112         }
3113         errno = olderrno;
3114 #ifdef FIXNEGATIVEZERO
3115         if (*s == '-' && s[1] == '0' && !s[2])
3116             strcpy(s,"0");
3117 #endif
3118         while (*s) s++;
3119 #ifdef hcx
3120         if (s[-1] == '.')
3121             *--s = '\0';
3122 #endif
3123     }
3124     else {
3125         if (ckWARN(WARN_UNINITIALIZED)
3126             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3127             report_uninit();
3128         *lp = 0;
3129         if (SvTYPE(sv) < SVt_PV)
3130             /* Typically the caller expects that sv_any is not NULL now.  */
3131             sv_upgrade(sv, SVt_PV);
3132         return "";
3133     }
3134     *lp = s - SvPVX(sv);
3135     SvCUR_set(sv, *lp);
3136     SvPOK_on(sv);
3137     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3138                           PTR2UV(sv),SvPVX(sv)));
3139     return SvPVX(sv);
3140
3141   tokensave:
3142     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
3143         /* Sneaky stuff here */
3144
3145       tokensaveref:
3146         if (!tsv)
3147             tsv = newSVpv(tmpbuf, 0);
3148         sv_2mortal(tsv);
3149         *lp = SvCUR(tsv);
3150         return SvPVX(tsv);
3151     }
3152     else {
3153         STRLEN len;
3154         char *t;
3155
3156         if (tsv) {
3157             sv_2mortal(tsv);
3158             t = SvPVX(tsv);
3159             len = SvCUR(tsv);
3160         }
3161         else {
3162             t = tmpbuf;
3163             len = strlen(tmpbuf);
3164         }
3165 #ifdef FIXNEGATIVEZERO
3166         if (len == 2 && t[0] == '-' && t[1] == '0') {
3167             t = "0";
3168             len = 1;
3169         }
3170 #endif
3171         (void)SvUPGRADE(sv, SVt_PV);
3172         *lp = len;
3173         s = SvGROW(sv, len + 1);
3174         SvCUR_set(sv, len);
3175         (void)strcpy(s, t);
3176         SvPOKp_on(sv);
3177         return s;
3178     }
3179 }
3180
3181 /*
3182 =for apidoc sv_copypv
3183
3184 Copies a stringified representation of the source SV into the
3185 destination SV.  Automatically performs any necessary mg_get and
3186 coercion of numeric values into strings.  Guaranteed to preserve
3187 UTF-8 flag even from overloaded objects.  Similar in nature to
3188 sv_2pv[_flags] but operates directly on an SV instead of just the
3189 string.  Mostly uses sv_2pv_flags to do its work, except when that
3190 would lose the UTF-8'ness of the PV.
3191
3192 =cut
3193 */
3194
3195 void
3196 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3197 {
3198     STRLEN len;
3199     char *s;
3200     s = SvPV(ssv,len);
3201     sv_setpvn(dsv,s,len);
3202     if (SvUTF8(ssv))
3203         SvUTF8_on(dsv);
3204     else
3205         SvUTF8_off(dsv);
3206 }
3207
3208 /*
3209 =for apidoc sv_2pvbyte_nolen
3210
3211 Return a pointer to the byte-encoded representation of the SV.
3212 May cause the SV to be downgraded from UTF8 as a side-effect.
3213
3214 Usually accessed via the C<SvPVbyte_nolen> macro.
3215
3216 =cut
3217 */
3218
3219 char *
3220 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3221 {
3222     STRLEN n_a;
3223     return sv_2pvbyte(sv, &n_a);
3224 }
3225
3226 /*
3227 =for apidoc sv_2pvbyte
3228
3229 Return a pointer to the byte-encoded representation of the SV, and set *lp
3230 to its length.  May cause the SV to be downgraded from UTF8 as a
3231 side-effect.
3232
3233 Usually accessed via the C<SvPVbyte> macro.
3234
3235 =cut
3236 */
3237
3238 char *
3239 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3240 {
3241     sv_utf8_downgrade(sv,0);
3242     return SvPV(sv,*lp);
3243 }
3244
3245 /*
3246 =for apidoc sv_2pvutf8_nolen
3247
3248 Return a pointer to the UTF8-encoded representation of the SV.
3249 May cause the SV to be upgraded to UTF8 as a side-effect.
3250
3251 Usually accessed via the C<SvPVutf8_nolen> macro.
3252
3253 =cut
3254 */
3255
3256 char *
3257 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3258 {
3259     STRLEN n_a;
3260     return sv_2pvutf8(sv, &n_a);
3261 }
3262
3263 /*
3264 =for apidoc sv_2pvutf8
3265
3266 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3267 to its length.  May cause the SV to be upgraded to UTF8 as a side-effect.
3268
3269 Usually accessed via the C<SvPVutf8> macro.
3270
3271 =cut
3272 */
3273
3274 char *
3275 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3276 {
3277     sv_utf8_upgrade(sv);
3278     return SvPV(sv,*lp);
3279 }
3280
3281 /*
3282 =for apidoc sv_2bool
3283
3284 This function is only called on magical items, and is only used by
3285 sv_true() or its macro equivalent.
3286
3287 =cut
3288 */
3289
3290 bool
3291 Perl_sv_2bool(pTHX_ register SV *sv)
3292 {
3293     if (SvGMAGICAL(sv))
3294         mg_get(sv);
3295
3296     if (!SvOK(sv))
3297         return 0;
3298     if (SvROK(sv)) {
3299         SV* tmpsv;
3300         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3301                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3302             return (bool)SvTRUE(tmpsv);
3303       return SvRV(sv) != 0;
3304     }
3305     if (SvPOKp(sv)) {
3306         register XPV* Xpvtmp;
3307         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3308                 (*Xpvtmp->xpv_pv > '0' ||
3309                 Xpvtmp->xpv_cur > 1 ||
3310                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3311             return 1;
3312         else
3313             return 0;
3314     }
3315     else {
3316         if (SvIOKp(sv))
3317             return SvIVX(sv) != 0;
3318         else {
3319             if (SvNOKp(sv))
3320                 return SvNVX(sv) != 0.0;
3321             else
3322                 return FALSE;
3323         }
3324     }
3325 }
3326
3327 /*
3328 =for apidoc sv_utf8_upgrade
3329
3330 Convert the PV of an SV to its UTF8-encoded form.
3331 Forces the SV to string form if it is not already.
3332 Always sets the SvUTF8 flag to avoid future validity checks even
3333 if all the bytes have hibit clear.
3334
3335 This is not as a general purpose byte encoding to Unicode interface:
3336 use the Encode extension for that.
3337
3338 =for apidoc sv_utf8_upgrade_flags
3339
3340 Convert the PV of an SV to its UTF8-encoded form.
3341 Forces the SV to string form if it is not already.
3342 Always sets the SvUTF8 flag to avoid future validity checks even
3343 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3344 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3345 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3346
3347 This is not as a general purpose byte encoding to Unicode interface:
3348 use the Encode extension for that.
3349
3350 =cut
3351 */
3352
3353 STRLEN
3354 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3355 {
3356     U8 *s, *t, *e;
3357     int  hibit = 0;
3358
3359     if (!sv)
3360         return 0;
3361
3362     if (!SvPOK(sv)) {
3363         STRLEN len = 0;
3364         (void) sv_2pv_flags(sv,&len, flags);
3365         if (!SvPOK(sv))
3366              return len;
3367     }
3368
3369     if (SvUTF8(sv))
3370         return SvCUR(sv);
3371
3372     if (SvIsCOW(sv)) {
3373         sv_force_normal_flags(sv, 0);
3374     }
3375
3376     if (PL_encoding)
3377         sv_recode_to_utf8(sv, PL_encoding);
3378     else { /* Assume Latin-1/EBCDIC */
3379          /* This function could be much more efficient if we
3380           * had a FLAG in SVs to signal if there are any hibit
3381           * chars in the PV.  Given that there isn't such a flag
3382           * make the loop as fast as possible. */
3383          s = (U8 *) SvPVX(sv);
3384          e = (U8 *) SvEND(sv);
3385          t = s;
3386          while (t < e) {
3387               U8 ch = *t++;
3388               if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3389                    break;
3390          }
3391          if (hibit) {
3392               STRLEN len;
3393
3394               len = SvCUR(sv) + 1; /* Plus the \0 */
3395               SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3396               SvCUR(sv) = len - 1;
3397               if (SvLEN(sv) != 0)
3398                    Safefree(s); /* No longer using what was there before. */
3399               SvLEN(sv) = len; /* No longer know the real size. */
3400          }
3401          /* Mark as UTF-8 even if no hibit - saves scanning loop */
3402          SvUTF8_on(sv);
3403     }
3404     return SvCUR(sv);
3405 }
3406
3407 /*
3408 =for apidoc sv_utf8_downgrade
3409
3410 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3411 This may not be possible if the PV contains non-byte encoding characters;
3412 if this is the case, either returns false or, if C<fail_ok> is not
3413 true, croaks.
3414
3415 This is not as a general purpose Unicode to byte encoding interface:
3416 use the Encode extension for that.
3417
3418 =cut
3419 */
3420
3421 bool
3422 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3423 {
3424     if (SvPOK(sv) && SvUTF8(sv)) {
3425         if (SvCUR(sv)) {
3426             U8 *s;
3427             STRLEN len;
3428
3429             if (SvIsCOW(sv)) {
3430                 sv_force_normal_flags(sv, 0);
3431             }
3432             s = (U8 *) SvPV(sv, len);
3433             if (!utf8_to_bytes(s, &len)) {
3434                 if (fail_ok)
3435                     return FALSE;
3436                 else {
3437                     if (PL_op)
3438                         Perl_croak(aTHX_ "Wide character in %s",
3439                                    OP_DESC(PL_op));
3440                     else
3441                         Perl_croak(aTHX_ "Wide character");
3442                 }
3443             }
3444             SvCUR(sv) = len;
3445         }
3446     }
3447     SvUTF8_off(sv);
3448     return TRUE;
3449 }
3450
3451 /*
3452 =for apidoc sv_utf8_encode
3453
3454 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3455 flag so that it looks like octets again. Used as a building block
3456 for encode_utf8 in Encode.xs
3457
3458 =cut
3459 */
3460
3461 void
3462 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3463 {
3464     (void) sv_utf8_upgrade(sv);
3465     SvUTF8_off(sv);
3466 }
3467
3468 /*
3469 =for apidoc sv_utf8_decode
3470
3471 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3472 turn off SvUTF8 if needed so that we see characters. Used as a building block
3473 for decode_utf8 in Encode.xs
3474
3475 =cut
3476 */
3477
3478 bool
3479 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3480 {
3481     if (SvPOK(sv)) {
3482         U8 *c;
3483         U8 *e;
3484
3485         /* The octets may have got themselves encoded - get them back as
3486          * bytes
3487          */
3488         if (!sv_utf8_downgrade(sv, TRUE))
3489             return FALSE;
3490
3491         /* it is actually just a matter of turning the utf8 flag on, but
3492          * we want to make sure everything inside is valid utf8 first.
3493          */
3494         c = (U8 *) SvPVX(sv);
3495         if (!is_utf8_string(c, SvCUR(sv)+1))
3496             return FALSE;
3497         e = (U8 *) SvEND(sv);
3498         while (c < e) {
3499             U8 ch = *c++;
3500             if (!UTF8_IS_INVARIANT(ch)) {
3501                 SvUTF8_on(sv);
3502                 break;
3503             }
3504         }
3505     }
3506     return TRUE;
3507 }
3508
3509 /*
3510 =for apidoc sv_setsv
3511
3512 Copies the contents of the source SV C<ssv> into the destination SV
3513 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3514 function if the source SV needs to be reused. Does not handle 'set' magic.
3515 Loosely speaking, it performs a copy-by-value, obliterating any previous
3516 content of the destination.
3517
3518 You probably want to use one of the assortment of wrappers, such as
3519 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3520 C<SvSetMagicSV_nosteal>.
3521
3522 =for apidoc sv_setsv_flags
3523
3524 Copies the contents of the source SV C<ssv> into the destination SV
3525 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3526 function if the source SV needs to be reused. Does not handle 'set' magic.
3527 Loosely speaking, it performs a copy-by-value, obliterating any previous
3528 content of the destination.
3529 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3530 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3531 implemented in terms of this function.
3532
3533 You probably want to use one of the assortment of wrappers, such as
3534 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3535 C<SvSetMagicSV_nosteal>.
3536
3537 This is the primary function for copying scalars, and most other
3538 copy-ish functions and macros use this underneath.
3539
3540 =cut
3541 */
3542
3543 void
3544 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3545 {
3546     register U32 sflags;
3547     register int dtype;
3548     register int stype;
3549
3550     if (sstr == dstr)
3551         return;
3552     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3553     if (!sstr)
3554         sstr = &PL_sv_undef;
3555     stype = SvTYPE(sstr);
3556     dtype = SvTYPE(dstr);
3557
3558     SvAMAGIC_off(dstr);
3559     if ( SvVOK(dstr) )
3560     {
3561         /* need to nuke the magic */
3562         mg_free(dstr);
3563         SvRMAGICAL_off(dstr);
3564     }
3565
3566     /* There's a lot of redundancy below but we're going for speed here */
3567
3568     switch (stype) {
3569     case SVt_NULL:
3570       undef_sstr:
3571         if (dtype != SVt_PVGV) {
3572             (void)SvOK_off(dstr);
3573             return;
3574         }
3575         break;
3576     case SVt_IV:
3577         if (SvIOK(sstr)) {
3578             switch (dtype) {
3579             case SVt_NULL:
3580                 sv_upgrade(dstr, SVt_IV);
3581                 break;
3582             case SVt_NV:
3583                 sv_upgrade(dstr, SVt_PVNV);
3584                 break;
3585             case SVt_RV:
3586             case SVt_PV:
3587                 sv_upgrade(dstr, SVt_PVIV);
3588                 break;
3589             }
3590             (void)SvIOK_only(dstr);
3591             SvIVX(dstr) = SvIVX(sstr);
3592             if (SvIsUV(sstr))
3593                 SvIsUV_on(dstr);
3594             if (SvTAINTED(sstr))
3595                 SvTAINT(dstr);
3596             return;
3597         }
3598         goto undef_sstr;
3599
3600     case SVt_NV:
3601         if (SvNOK(sstr)) {
3602             switch (dtype) {
3603             case SVt_NULL:
3604             case SVt_IV:
3605                 sv_upgrade(dstr, SVt_NV);
3606                 break;
3607             case SVt_RV:
3608             case SVt_PV:
3609             case SVt_PVIV:
3610                 sv_upgrade(dstr, SVt_PVNV);
3611                 break;
3612             }
3613             SvNVX(dstr) = SvNVX(sstr);
3614             (void)SvNOK_only(dstr);
3615             if (SvTAINTED(sstr))
3616                 SvTAINT(dstr);
3617             return;
3618         }
3619         goto undef_sstr;
3620
3621     case SVt_RV:
3622         if (dtype < SVt_RV)
3623             sv_upgrade(dstr, SVt_RV);
3624         else if (dtype == SVt_PVGV &&
3625                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3626             sstr = SvRV(sstr);
3627             if (sstr == dstr) {
3628                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3629                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3630                 {
3631                     GvIMPORTED_on(dstr);
3632                 }
3633                 GvMULTI_on(dstr);
3634                 return;
3635             }
3636             goto glob_assign;
3637         }
3638         break;
3639     case SVt_PV:
3640     case SVt_PVFM:
3641         if (dtype < SVt_PV)
3642             sv_upgrade(dstr, SVt_PV);
3643         break;
3644     case SVt_PVIV:
3645         if (dtype < SVt_PVIV)
3646             sv_upgrade(dstr, SVt_PVIV);
3647         break;
3648     case SVt_PVNV:
3649         if (dtype < SVt_PVNV)
3650             sv_upgrade(dstr, SVt_PVNV);
3651         break;
3652     case SVt_PVAV:
3653     case SVt_PVHV:
3654     case SVt_PVCV:
3655     case SVt_PVIO:
3656         if (PL_op)
3657             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3658                 OP_NAME(PL_op));
3659         else
3660             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3661         break;
3662
3663     case SVt_PVGV:
3664         if (dtype <= SVt_PVGV) {
3665   glob_assign:
3666             if (dtype != SVt_PVGV) {
3667                 char *name = GvNAME(sstr);
3668                 STRLEN len = GvNAMELEN(sstr);
3669                 sv_upgrade(dstr, SVt_PVGV);
3670                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3671                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3672                 GvNAME(dstr) = savepvn(name, len);
3673                 GvNAMELEN(dstr) = len;
3674                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3675             }
3676             /* ahem, death to those who redefine active sort subs */
3677             else if (PL_curstackinfo->si_type == PERLSI_SORT
3678                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3679                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3680                       GvNAME(dstr));
3681
3682 #ifdef GV_UNIQUE_CHECK
3683                 if (GvUNIQUE((GV*)dstr)) {
3684                     Perl_croak(aTHX_ PL_no_modify);
3685                 }
3686 #endif
3687
3688             (void)SvOK_off(dstr);
3689             GvINTRO_off(dstr);          /* one-shot flag */
3690             gp_free((GV*)dstr);
3691             GvGP(dstr) = gp_ref(GvGP(sstr));
3692             if (SvTAINTED(sstr))
3693                 SvTAINT(dstr);
3694             if (GvIMPORTED(dstr) != GVf_IMPORTED
3695                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3696             {
3697                 GvIMPORTED_on(dstr);
3698             }
3699             GvMULTI_on(dstr);
3700             return;
3701         }
3702         /* FALL THROUGH */
3703
3704     default:
3705         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3706             mg_get(sstr);
3707             if ((int)SvTYPE(sstr) != stype) {
3708                 stype = SvTYPE(sstr);
3709                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3710                     goto glob_assign;
3711             }
3712         }
3713         if (stype == SVt_PVLV)
3714             (void)SvUPGRADE(dstr, SVt_PVNV);
3715         else
3716             (void)SvUPGRADE(dstr, (U32)stype);
3717     }
3718
3719     sflags = SvFLAGS(sstr);
3720
3721     if (sflags & SVf_ROK) {
3722         if (dtype >= SVt_PV) {
3723             if (dtype == SVt_PVGV) {
3724                 SV *sref = SvREFCNT_inc(SvRV(sstr));
3725                 SV *dref = 0;
3726                 int intro = GvINTRO(dstr);
3727
3728 #ifdef GV_UNIQUE_CHECK
3729                 if (GvUNIQUE((GV*)dstr)) {
3730                     Perl_croak(aTHX_ PL_no_modify);
3731                 }
3732 #endif
3733
3734                 if (intro) {
3735                     GvINTRO_off(dstr);  /* one-shot flag */
3736                     GvLINE(dstr) = CopLINE(PL_curcop);
3737                     GvEGV(dstr) = (GV*)dstr;
3738                 }
3739                 GvMULTI_on(dstr);
3740                 switch (SvTYPE(sref)) {
3741                 case SVt_PVAV:
3742                     if (intro)
3743                         SAVESPTR(GvAV(dstr));
3744                     else
3745                         dref = (SV*)GvAV(dstr);
3746                     GvAV(dstr) = (AV*)sref;
3747                     if (!GvIMPORTED_AV(dstr)
3748                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3749                     {
3750                         GvIMPORTED_AV_on(dstr);
3751                     }
3752                     break;
3753                 case SVt_PVHV:
3754                     if (intro)
3755                         SAVESPTR(GvHV(dstr));
3756                     else
3757                         dref = (SV*)GvHV(dstr);
3758                     GvHV(dstr) = (HV*)sref;
3759                     if (!GvIMPORTED_HV(dstr)
3760                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3761                     {
3762                         GvIMPORTED_HV_on(dstr);
3763                     }
3764                     break;
3765                 case SVt_PVCV:
3766                     if (intro) {
3767                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3768                             SvREFCNT_dec(GvCV(dstr));
3769                             GvCV(dstr) = Nullcv;
3770                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3771                             PL_sub_generation++;
3772                         }
3773                         SAVESPTR(GvCV(dstr));
3774                     }
3775                     else
3776                         dref = (SV*)GvCV(dstr);
3777                     if (GvCV(dstr) != (CV*)sref) {
3778                         CV* cv = GvCV(dstr);
3779                         if (cv) {
3780                             if (!GvCVGEN((GV*)dstr) &&
3781                                 (CvROOT(cv) || CvXSUB(cv)))
3782                             {
3783                                 /* ahem, death to those who redefine
3784                                  * active sort subs */
3785                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3786                                       PL_sortcop == CvSTART(cv))
3787                                     Perl_croak(aTHX_
3788                                     "Can't redefine active sort subroutine %s",
3789                                           GvENAME((GV*)dstr));
3790                                 /* Redefining a sub - warning is mandatory if
3791                                    it was a const and its value changed. */
3792                                 if (ckWARN(WARN_REDEFINE)
3793                                     || (CvCONST(cv)
3794                                         && (!CvCONST((CV*)sref)
3795                                             || sv_cmp(cv_const_sv(cv),
3796                                                       cv_const_sv((CV*)sref)))))
3797                                 {
3798                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3799                                         CvCONST(cv)
3800                                         ? "Constant subroutine %s::%s redefined"
3801                                         : "Subroutine %s::%s redefined",
3802                                         HvNAME(GvSTASH((GV*)dstr)),
3803                                         GvENAME((GV*)dstr));
3804                                 }
3805                             }
3806                             if (!intro)
3807                                 cv_ckproto(cv, (GV*)dstr,
3808                                         SvPOK(sref) ? SvPVX(sref) : Nullch);
3809                         }
3810                         GvCV(dstr) = (CV*)sref;
3811                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3812                         GvASSUMECV_on(dstr);
3813                         PL_sub_generation++;
3814                     }
3815                     if (!GvIMPORTED_CV(dstr)
3816                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3817                     {
3818                         GvIMPORTED_CV_on(dstr);
3819                     }
3820                     break;
3821                 case SVt_PVIO:
3822                     if (intro)
3823                         SAVESPTR(GvIOp(dstr));
3824                     else
3825                         dref = (SV*)GvIOp(dstr);
3826                     GvIOp(dstr) = (IO*)sref;
3827                     break;
3828                 case SVt_PVFM:
3829                     if (intro)
3830                         SAVESPTR(GvFORM(dstr));
3831                     else
3832                         dref = (SV*)GvFORM(dstr);
3833                     GvFORM(dstr) = (CV*)sref;
3834                     break;
3835                 default:
3836                     if (intro)
3837                         SAVESPTR(GvSV(dstr));
3838                     else
3839                         dref = (SV*)GvSV(dstr);
3840                     GvSV(dstr) = sref;
3841                     if (!GvIMPORTED_SV(dstr)
3842                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3843                     {
3844                         GvIMPORTED_SV_on(dstr);
3845                     }
3846                     break;
3847                 }
3848                 if (dref)
3849                     SvREFCNT_dec(dref);
3850                 if (intro)
3851                     SAVEFREESV(sref);
3852                 if (SvTAINTED(sstr))
3853                     SvTAINT(dstr);
3854                 return;
3855             }
3856             if (SvPVX(dstr)) {
3857                 (void)SvOOK_off(dstr);          /* backoff */
3858                 if (SvLEN(dstr))
3859                     Safefree(SvPVX(dstr));
3860                 SvLEN(dstr)=SvCUR(dstr)=0;
3861             }
3862         }
3863         (void)SvOK_off(dstr);
3864         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3865         SvROK_on(dstr);
3866         if (sflags & SVp_NOK) {
3867             SvNOKp_on(dstr);
3868             /* Only set the public OK flag if the source has public OK.  */
3869             if (sflags & SVf_NOK)
3870                 SvFLAGS(dstr) |= SVf_NOK;
3871             SvNVX(dstr) = SvNVX(sstr);
3872         }
3873         if (sflags & SVp_IOK) {
3874             (void)SvIOKp_on(dstr);
3875             if (sflags & SVf_IOK)
3876                 SvFLAGS(dstr) |= SVf_IOK;
3877             if (sflags & SVf_IVisUV)
3878                 SvIsUV_on(dstr);
3879             SvIVX(dstr) = SvIVX(sstr);
3880         }
3881         if (SvAMAGIC(sstr)) {
3882             SvAMAGIC_on(dstr);
3883         }
3884     }
3885     else if (sflags & SVp_POK) {
3886         bool isSwipe = 0;
3887
3888         /*
3889          * Check to see if we can just swipe the string.  If so, it's a
3890          * possible small lose on short strings, but a big win on long ones.
3891          * It might even be a win on short strings if SvPVX(dstr)
3892          * has to be allocated and SvPVX(sstr) has to be freed.
3893          */
3894
3895         if (
3896 #ifdef PERL_COPY_ON_WRITE
3897             (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3898             &&
3899 #endif
3900             !(isSwipe =
3901                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
3902                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
3903                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
3904                  SvLEN(sstr)    &&        /* and really is a string */
3905                                 /* and won't be needed again, potentially */
3906               !(PL_op && PL_op->op_type == OP_AASSIGN))
3907 #ifdef PERL_COPY_ON_WRITE
3908             && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3909                  && SvTYPE(sstr) >= SVt_PVIV)
3910 #endif
3911             ) {
3912             /* Failed the swipe test, and it's not a shared hash key either.
3913                Have to copy the string.  */
3914             STRLEN len = SvCUR(sstr);
3915             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3916             Move(SvPVX(sstr),SvPVX(dstr),len,char);
3917             SvCUR_set(dstr, len);
3918             *SvEND(dstr) = '\0';
3919             (void)SvPOK_only(dstr);
3920         } else {
3921             /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
3922                be true in here.  */
3923 #ifdef PERL_COPY_ON_WRITE
3924             /* Either it's a shared hash key, or it's suitable for
3925                copy-on-write or we can swipe the string.  */
3926             if (DEBUG_C_TEST) {
3927                 PerlIO_printf(Perl_debug_log,
3928                               "Copy on write: sstr --> dstr\n");
3929                 sv_dump(sstr);
3930                 sv_dump(dstr);
3931             }
3932             if (!isSwipe) {
3933                 /* I believe I should acquire a global SV mutex if
3934                    it's a COW sv (not a shared hash key) to stop
3935                    it going un copy-on-write.
3936                    If the source SV has gone un copy on write between up there
3937                    and down here, then (assert() that) it is of the correct
3938                    form to make it copy on write again */
3939                 if ((sflags & (SVf_FAKE | SVf_READONLY))
3940                     != (SVf_FAKE | SVf_READONLY)) {
3941                     SvREADONLY_on(sstr);
3942                     SvFAKE_on(sstr);
3943                     /* Make the source SV into a loop of 1.
3944                        (about to become 2) */
3945                     SV_COW_NEXT_SV_SET(sstr, sstr);
3946                 }
3947             }
3948 #endif
3949             /* Initial code is common.  */
3950             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
3951                 if (SvOOK(dstr)) {
3952                     SvFLAGS(dstr) &= ~SVf_OOK;
3953                     Safefree(SvPVX(dstr) - SvIVX(dstr));
3954                 }
3955                 else if (SvLEN(dstr))
3956                     Safefree(SvPVX(dstr));
3957             }
3958             (void)SvPOK_only(dstr);
3959
3960 #ifdef PERL_COPY_ON_WRITE
3961             if (!isSwipe) {
3962                 /* making another shared SV.  */
3963                 STRLEN cur = SvCUR(sstr);
3964                 STRLEN len = SvLEN(sstr);
3965                 if (len) {
3966                     /* SvIsCOW_normal */
3967                     /* splice us in between source and next-after-source.  */
3968                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3969                     SV_COW_NEXT_SV_SET(sstr, dstr);
3970                     SvPV_set(dstr, SvPVX(sstr));
3971                 } else {
3972                     /* SvIsCOW_shared_hash */
3973                     UV hash = SvUVX(sstr);
3974                     DEBUG_C(PerlIO_printf(Perl_debug_log,
3975                                           "Copy on write: Sharing hash\n"));
3976                     SvPV_set(dstr,
3977                              sharepvn(SvPVX(sstr),
3978                                       (sflags & SVf_UTF8?-cur:cur), hash));
3979                     SvUVX(dstr) = hash;
3980                 }
3981                 SvLEN(dstr) = len;
3982                 SvCUR(dstr) = cur;
3983                 SvREADONLY_on(dstr);
3984                 SvFAKE_on(dstr);
3985                 /* Relesase a global SV mutex.  */
3986             }
3987             else
3988 #endif
3989                 {       /* Passes the swipe test.  */
3990                 SvPV_set(dstr, SvPVX(sstr));
3991                 SvLEN_set(dstr, SvLEN(sstr));
3992                 SvCUR_set(dstr, SvCUR(sstr));
3993
3994                 SvTEMP_off(dstr);
3995                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
3996                 SvPV_set(sstr, Nullch);
3997                 SvLEN_set(sstr, 0);
3998                 SvCUR_set(sstr, 0);
3999                 SvTEMP_off(sstr);
4000             }
4001         }
4002         if (sflags & SVf_UTF8)
4003             SvUTF8_on(dstr);
4004         /*SUPPRESS 560*/
4005         if (sflags & SVp_NOK) {
4006             SvNOKp_on(dstr);
4007             if (sflags & SVf_NOK)
4008                 SvFLAGS(dstr) |= SVf_NOK;
4009             SvNVX(dstr) = SvNVX(sstr);
4010         }
4011         if (sflags & SVp_IOK) {
4012             (void)SvIOKp_on(dstr);
4013             if (sflags & SVf_IOK)
4014                 SvFLAGS(dstr) |= SVf_IOK;
4015             if (sflags & SVf_IVisUV)
4016                 SvIsUV_on(dstr);
4017             SvIVX(dstr) = SvIVX(sstr);
4018         }
4019         if (SvVOK(sstr)) {
4020             MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4021             sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4022                         smg->mg_ptr, smg->mg_len);
4023             SvRMAGICAL_on(dstr);
4024         }
4025     }
4026     else if (sflags & SVp_IOK) {
4027         if (sflags & SVf_IOK)
4028             (void)SvIOK_only(dstr);
4029         else {
4030             (void)SvOK_off(dstr);
4031             (void)SvIOKp_on(dstr);
4032         }
4033         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4034         if (sflags & SVf_IVisUV)
4035             SvIsUV_on(dstr);
4036         SvIVX(dstr) = SvIVX(sstr);
4037         if (sflags & SVp_NOK) {
4038             if (sflags & SVf_NOK)
4039                 (void)SvNOK_on(dstr);
4040             else
4041                 (void)SvNOKp_on(dstr);
4042             SvNVX(dstr) = SvNVX(sstr);
4043         }
4044     }
4045     else if (sflags & SVp_NOK) {
4046         if (sflags & SVf_NOK)
4047             (void)SvNOK_only(dstr);
4048         else {
4049             (void)SvOK_off(dstr);
4050             SvNOKp_on(dstr);
4051         }
4052         SvNVX(dstr) = SvNVX(sstr);
4053     }
4054     else {
4055         if (dtype == SVt_PVGV) {
4056             if (ckWARN(WARN_MISC))
4057                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4058         }
4059         else
4060             (void)SvOK_off(dstr);
4061     }
4062     if (SvTAINTED(sstr))
4063         SvTAINT(dstr);
4064 }
4065
4066 /*
4067 =for apidoc sv_setsv_mg
4068
4069 Like C<sv_setsv>, but also handles 'set' magic.
4070
4071 =cut
4072 */
4073
4074 void
4075 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4076 {
4077     sv_setsv(dstr,sstr);
4078     SvSETMAGIC(dstr);
4079 }
4080
4081 /*
4082 =for apidoc sv_setpvn
4083
4084 Copies a string into an SV.  The C<len> parameter indicates the number of
4085 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4086
4087 =cut
4088 */
4089
4090 void
4091 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4092 {
4093     register char *dptr;
4094
4095     SV_CHECK_THINKFIRST_COW_DROP(sv);
4096     if (!ptr) {
4097         (void)SvOK_off(sv);
4098         return;
4099     }
4100     else {
4101         /* len is STRLEN which is unsigned, need to copy to signed */
4102         IV iv = len;
4103         if (iv < 0)
4104             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4105     }
4106     (void)SvUPGRADE(sv, SVt_PV);
4107
4108     SvGROW(sv, len + 1);
4109     dptr = SvPVX(sv);
4110     Move(ptr,dptr,len,char);
4111     dptr[len] = '\0';
4112     SvCUR_set(sv, len);
4113     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4114     SvTAINT(sv);
4115 }
4116
4117 /*
4118 =for apidoc sv_setpvn_mg
4119
4120 Like C<sv_setpvn>, but also handles 'set' magic.
4121
4122 =cut
4123 */
4124
4125 void
4126 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4127 {
4128     sv_setpvn(sv,ptr,len);
4129     SvSETMAGIC(sv);
4130 }
4131
4132 /*
4133 =for apidoc sv_setpv
4134
4135 Copies a string into an SV.  The string must be null-terminated.  Does not
4136 handle 'set' magic.  See C<sv_setpv_mg>.
4137
4138 =cut
4139 */
4140
4141 void
4142 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4143 {
4144     register STRLEN len;
4145
4146     SV_CHECK_THINKFIRST_COW_DROP(sv);
4147     if (!ptr) {
4148         (void)SvOK_off(sv);
4149         return;
4150     }
4151     len = strlen(ptr);
4152     (void)SvUPGRADE(sv, SVt_PV);
4153
4154     SvGROW(sv, len + 1);
4155     Move(ptr,SvPVX(sv),len+1,char);
4156     SvCUR_set(sv, len);
4157     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4158     SvTAINT(sv);
4159 }
4160
4161 /*
4162 =for apidoc sv_setpv_mg
4163
4164 Like C<sv_setpv>, but also handles 'set' magic.
4165
4166 =cut
4167 */
4168
4169 void
4170 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4171 {
4172     sv_setpv(sv,ptr);
4173     SvSETMAGIC(sv);
4174 }
4175
4176 /*
4177 =for apidoc sv_usepvn
4178
4179 Tells an SV to use C<ptr> to find its string value.  Normally the string is
4180 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4181 The C<ptr> should point to memory that was allocated by C<malloc>.  The
4182 string length, C<len>, must be supplied.  This function will realloc the
4183 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4184 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
4185 See C<sv_usepvn_mg>.
4186
4187 =cut
4188 */
4189
4190 void
4191 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4192 {
4193     SV_CHECK_THINKFIRST_COW_DROP(sv);
4194     (void)SvUPGRADE(sv, SVt_PV);
4195     if (!ptr) {
4196         (void)SvOK_off(sv);
4197         return;
4198     }
4199     (void)SvOOK_off(sv);
4200     if (SvPVX(sv) && SvLEN(sv))
4201         Safefree(SvPVX(sv));
4202     Renew(ptr, len+1, char);
4203     SvPVX(sv) = ptr;
4204     SvCUR_set(sv, len);
4205     SvLEN_set(sv, len+1);
4206     *SvEND(sv) = '\0';
4207     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4208     SvTAINT(sv);
4209 }
4210
4211 /*
4212 =for apidoc sv_usepvn_mg
4213
4214 Like C<sv_usepvn>, but also handles 'set' magic.
4215
4216 =cut
4217 */
4218
4219 void
4220 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4221 {
4222     sv_usepvn(sv,ptr,len);
4223     SvSETMAGIC(sv);
4224 }
4225
4226 #ifdef PERL_COPY_ON_WRITE
4227 /* Need to do this *after* making the SV normal, as we need the buffer
4228    pointer to remain valid until after we've copied it.  If we let go too early,
4229    another thread could invalidate it by unsharing last of the same hash key
4230    (which it can do by means other than releasing copy-on-write Svs)
4231    or by changing the other copy-on-write SVs in the loop.  */
4232 STATIC void
4233 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4234                  U32 hash, SV *after)
4235 {
4236     if (len) { /* this SV was SvIsCOW_normal(sv) */
4237          /* we need to find the SV pointing to us.  */
4238         SV *current = SV_COW_NEXT_SV(after);
4239
4240         if (current == sv) {
4241             /* The SV we point to points back to us (there were only two of us
4242                in the loop.)
4243                Hence other SV is no longer copy on write either.  */
4244             SvFAKE_off(after);
4245             SvREADONLY_off(after);
4246         } else {
4247             /* We need to follow the pointers around the loop.  */
4248             SV *next;
4249             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4250                 assert (next);
4251                 current = next;
4252                  /* don't loop forever if the structure is bust, and we have
4253                     a pointer into a closed loop.  */
4254                 assert (current != after);
4255                 assert (SvPVX(current) == pvx);
4256             }
4257             /* Make the SV before us point to the SV after us.  */
4258             SV_COW_NEXT_SV_SET(current, after);
4259         }
4260     } else {
4261         unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4262     }
4263 }
4264
4265 int
4266 Perl_sv_release_IVX(pTHX_ register SV *sv)
4267 {
4268     if (SvIsCOW(sv))
4269         sv_force_normal_flags(sv, 0);
4270     return SvOOK_off(sv);
4271 }
4272 #endif
4273 /*
4274 =for apidoc sv_force_normal_flags
4275
4276 Undo various types of fakery on an SV: if the PV is a shared string, make
4277 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4278 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4279 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4280 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4281 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4282 set to some other value. In addtion, the C<flags> parameter gets passed to
4283 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4284 with flags set to 0.
4285
4286 =cut
4287 */
4288
4289 void
4290 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4291 {
4292 #ifdef PERL_COPY_ON_WRITE
4293     if (SvREADONLY(sv)) {
4294         /* At this point I believe I should acquire a global SV mutex.  */
4295         if (SvFAKE(sv)) {
4296             char *pvx = SvPVX(sv);
4297             STRLEN len = SvLEN(sv);
4298             STRLEN cur = SvCUR(sv);
4299             U32 hash = SvUVX(sv);
4300             SV *next = SV_COW_NEXT_SV(sv);   /* next COW sv in the loop. */
4301             if (DEBUG_C_TEST) {
4302                 PerlIO_printf(Perl_debug_log,
4303                               "Copy on write: Force normal %ld\n",
4304                               (long) flags);
4305                 sv_dump(sv);
4306             }
4307             SvFAKE_off(sv);
4308             SvREADONLY_off(sv);
4309             /* This SV doesn't own the buffer, so need to New() a new one:  */
4310             SvPVX(sv) = 0;
4311             SvLEN(sv) = 0;
4312             if (flags & SV_COW_DROP_PV) {
4313                 /* OK, so we don't need to copy our buffer.  */
4314                 SvPOK_off(sv);
4315             } else {
4316                 SvGROW(sv, cur + 1);
4317                 Move(pvx,SvPVX(sv),cur,char);
4318                 SvCUR(sv) = cur;
4319                 *SvEND(sv) = '\0';
4320             }
4321             sv_release_COW(sv, pvx, cur, len, hash, next);
4322             if (DEBUG_C_TEST) {
4323                 sv_dump(sv);
4324             }
4325         }
4326         else if (PL_curcop != &PL_compiling)
4327             Perl_croak(aTHX_ PL_no_modify);
4328         /* At this point I believe that I can drop the global SV mutex.  */
4329     }
4330 #else
4331     if (SvREADONLY(sv)) {
4332         if (SvFAKE(sv)) {
4333             char *pvx = SvPVX(sv);
4334             STRLEN len = SvCUR(sv);
4335             U32 hash   = SvUVX(sv);
4336             SvGROW(sv, len + 1);
4337             Move(pvx,SvPVX(sv),len,char);
4338             *SvEND(sv) = '\0';
4339             SvFAKE_off(sv);
4340             SvREADONLY_off(sv);
4341             unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4342         }
4343         else if (PL_curcop != &PL_compiling)
4344             Perl_croak(aTHX_ PL_no_modify);
4345     }
4346 #endif
4347     if (SvROK(sv))
4348         sv_unref_flags(sv, flags);
4349     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4350         sv_unglob(sv);
4351 }
4352
4353 /*
4354 =for apidoc sv_force_normal
4355
4356 Undo various types of fakery on an SV: if the PV is a shared string, make
4357 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4358 an xpvmg. See also C<sv_force_normal_flags>.
4359
4360 =cut
4361 */
4362
4363 void
4364 Perl_sv_force_normal(pTHX_ register SV *sv)
4365 {
4366     sv_force_normal_flags(sv, 0);
4367 }
4368
4369 /*
4370 =for apidoc sv_chop
4371
4372 Efficient removal of characters from the beginning of the string buffer.
4373 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4374 the string buffer.  The C<ptr> becomes the first character of the adjusted
4375 string. Uses the "OOK hack".
4376
4377 =cut
4378 */
4379
4380 void
4381 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4382 {
4383     register STRLEN delta;
4384
4385     if (!ptr || !SvPOKp(sv))
4386         return;
4387     SV_CHECK_THINKFIRST(sv);
4388     if (SvTYPE(sv) < SVt_PVIV)
4389         sv_upgrade(sv,SVt_PVIV);
4390
4391     if (!SvOOK(sv)) {
4392         if (!SvLEN(sv)) { /* make copy of shared string */
4393             char *pvx = SvPVX(sv);
4394             STRLEN len = SvCUR(sv);
4395             SvGROW(sv, len + 1);
4396             Move(pvx,SvPVX(sv),len,char);
4397             *SvEND(sv) = '\0';
4398         }
4399         SvIVX(sv) = 0;
4400         SvFLAGS(sv) |= SVf_OOK;
4401     }
4402     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4403     delta = ptr - SvPVX(sv);
4404     SvLEN(sv) -= delta;
4405     SvCUR(sv) -= delta;
4406     SvPVX(sv) += delta;
4407     SvIVX(sv) += delta;
4408 }
4409
4410 /*
4411 =for apidoc sv_catpvn
4412
4413 Concatenates the string onto the end of the string which is in the SV.  The
4414 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4415 status set, then the bytes appended should be valid UTF8.
4416 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4417
4418 =for apidoc sv_catpvn_flags
4419
4420 Concatenates the string onto the end of the string which is in the SV.  The
4421 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4422 status set, then the bytes appended should be valid UTF8.
4423 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4424 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4425 in terms of this function.
4426
4427 =cut
4428 */
4429
4430 void
4431 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4432 {
4433     STRLEN dlen;
4434     char *dstr;
4435
4436     dstr = SvPV_force_flags(dsv, dlen, flags);
4437     SvGROW(dsv, dlen + slen + 1);
4438     if (sstr == dstr)
4439         sstr = SvPVX(dsv);
4440     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4441     SvCUR(dsv) += slen;
4442     *SvEND(dsv) = '\0';
4443     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4444     SvTAINT(dsv);
4445 }
4446
4447 /*
4448 =for apidoc sv_catpvn_mg
4449
4450 Like C<sv_catpvn>, but also handles 'set' magic.
4451
4452 =cut
4453 */
4454
4455 void
4456 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4457 {
4458     sv_catpvn(sv,ptr,len);
4459     SvSETMAGIC(sv);
4460 }
4461
4462 /*
4463 =for apidoc sv_catsv
4464
4465 Concatenates the string from SV C<ssv> onto the end of the string in
4466 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4467 not 'set' magic.  See C<sv_catsv_mg>.
4468
4469 =for apidoc sv_catsv_flags
4470
4471 Concatenates the string from SV C<ssv> onto the end of the string in
4472 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4473 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4474 and C<sv_catsv_nomg> are implemented in terms of this function.
4475
4476 =cut */
4477
4478 void
4479 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4480 {
4481     char *spv;
4482     STRLEN slen;
4483     if (!ssv)
4484         return;
4485     if ((spv = SvPV(ssv, slen))) {
4486         /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4487             gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4488             Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4489             get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4490             dsv->sv_flags doesn't have that bit set.
4491                 Andy Dougherty  12 Oct 2001
4492         */
4493         I32 sutf8 = DO_UTF8(ssv);
4494         I32 dutf8;
4495
4496         if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4497             mg_get(dsv);
4498         dutf8 = DO_UTF8(dsv);
4499
4500         if (dutf8 != sutf8) {
4501             if (dutf8) {
4502                 /* Not modifying source SV, so taking a temporary copy. */
4503                 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4504
4505                 sv_utf8_upgrade(csv);
4506                 spv = SvPV(csv, slen);
4507             }
4508             else
4509                 sv_utf8_upgrade_nomg(dsv);
4510         }
4511         sv_catpvn_nomg(dsv, spv, slen);
4512     }
4513 }
4514
4515 /*
4516 =for apidoc sv_catsv_mg
4517
4518 Like C<sv_catsv>, but also handles 'set' magic.
4519
4520 =cut
4521 */
4522
4523 void
4524 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4525 {
4526     sv_catsv(dsv,ssv);
4527     SvSETMAGIC(dsv);
4528 }
4529
4530 /*
4531 =for apidoc sv_catpv
4532
4533 Concatenates the string onto the end of the string which is in the SV.
4534 If the SV has the UTF8 status set, then the bytes appended should be
4535 valid UTF8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4536
4537 =cut */
4538
4539 void
4540 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4541 {
4542     register STRLEN len;
4543     STRLEN tlen;
4544     char *junk;
4545
4546     if (!ptr)
4547         return;
4548     junk = SvPV_force(sv, tlen);
4549     len = strlen(ptr);
4550     SvGROW(sv, tlen + len + 1);
4551     if (ptr == junk)
4552         ptr = SvPVX(sv);
4553     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4554     SvCUR(sv) += len;
4555     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4556     SvTAINT(sv);
4557 }
4558
4559 /*
4560 =for apidoc sv_catpv_mg
4561
4562 Like C<sv_catpv>, but also handles 'set' magic.
4563
4564 =cut
4565 */
4566
4567 void
4568 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4569 {
4570     sv_catpv(sv,ptr);
4571     SvSETMAGIC(sv);
4572 }
4573
4574 /*
4575 =for apidoc newSV
4576
4577 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4578 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4579 macro.
4580
4581 =cut
4582 */
4583
4584 SV *
4585 Perl_newSV(pTHX_ STRLEN len)
4586 {
4587     register SV *sv;
4588
4589     new_SV(sv);
4590     if (len) {
4591         sv_upgrade(sv, SVt_PV);
4592         SvGROW(sv, len + 1);
4593     }
4594     return sv;
4595 }
4596 /*
4597 =for apidoc sv_magicext
4598
4599 Adds magic to an SV, upgrading it if necessary. Applies the
4600 supplied vtable and returns pointer to the magic added.
4601
4602 Note that sv_magicext will allow things that sv_magic will not.
4603 In particular you can add magic to SvREADONLY SVs and and more than
4604 one instance of the same 'how'
4605
4606 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
4607 if C<namelen> is zero then C<name> is stored as-is and - as another special
4608 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
4609 an C<SV*> and has its REFCNT incremented
4610
4611 (This is now used as a subroutine by sv_magic.)
4612
4613 =cut
4614 */
4615 MAGIC *
4616 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4617                  const char* name, I32 namlen)
4618 {
4619     MAGIC* mg;
4620
4621     if (SvTYPE(sv) < SVt_PVMG) {
4622         (void)SvUPGRADE(sv, SVt_PVMG);
4623     }
4624     Newz(702,mg, 1, MAGIC);
4625     mg->mg_moremagic = SvMAGIC(sv);
4626     SvMAGIC(sv) = mg;
4627
4628     /* Some magic sontains a reference loop, where the sv and object refer to
4629        each other.  To prevent a reference loop that would prevent such
4630        objects being freed, we look for such loops and if we find one we
4631        avoid incrementing the object refcount.
4632
4633        Note we cannot do this to avoid self-tie loops as intervening RV must
4634        have its REFCNT incremented to keep it in existence.
4635
4636     */
4637     if (!obj || obj == sv ||
4638         how == PERL_MAGIC_arylen ||
4639         how == PERL_MAGIC_qr ||
4640         (SvTYPE(obj) == SVt_PVGV &&
4641             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4642             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4643             GvFORM(obj) == (CV*)sv)))
4644     {
4645         mg->mg_obj = obj;
4646     }
4647     else {
4648         mg->mg_obj = SvREFCNT_inc(obj);
4649         mg->mg_flags |= MGf_REFCOUNTED;
4650     }
4651
4652     /* Normal self-ties simply pass a null object, and instead of
4653        using mg_obj directly, use the SvTIED_obj macro to produce a
4654        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4655        with an RV obj pointing to the glob containing the PVIO.  In
4656        this case, to avoid a reference loop, we need to weaken the
4657        reference.
4658     */
4659
4660     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4661         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4662     {
4663       sv_rvweaken(obj);
4664     }
4665
4666     mg->mg_type = how;
4667     mg->mg_len = namlen;
4668     if (name) {
4669         if (namlen > 0)
4670             mg->mg_ptr = savepvn(name, namlen);
4671         else if (namlen == HEf_SVKEY)
4672             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4673         else
4674             mg->mg_ptr = (char *) name;
4675     }
4676     mg->mg_virtual = vtable;
4677
4678     mg_magical(sv);
4679     if (SvGMAGICAL(sv))
4680         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4681     return mg;
4682 }
4683
4684 /*
4685 =for apidoc sv_magic
4686
4687 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4688 then adds a new magic item of type C<how> to the head of the magic list.
4689
4690 =cut
4691 */
4692
4693 void
4694 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4695 {
4696     MAGIC* mg;
4697     MGVTBL *vtable = 0;
4698
4699 #ifdef PERL_COPY_ON_WRITE
4700     if (SvIsCOW(sv))
4701         sv_force_normal_flags(sv, 0);
4702 #endif
4703     if (SvREADONLY(sv)) {
4704         if (PL_curcop != &PL_compiling
4705             && how != PERL_MAGIC_regex_global
4706             && how != PERL_MAGIC_bm
4707             && how != PERL_MAGIC_fm
4708             && how != PERL_MAGIC_sv
4709            )
4710         {
4711             Perl_croak(aTHX_ PL_no_modify);
4712         }
4713     }
4714     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4715         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4716             /* sv_magic() refuses to add a magic of the same 'how' as an
4717                existing one
4718              */
4719             if (how == PERL_MAGIC_taint)
4720                 mg->mg_len |= 1;
4721             return;
4722         }
4723     }
4724
4725     switch (how) {
4726     case PERL_MAGIC_sv:
4727         vtable = &PL_vtbl_sv;
4728         break;
4729     case PERL_MAGIC_overload:
4730         vtable = &PL_vtbl_amagic;
4731         break;
4732     case PERL_MAGIC_overload_elem:
4733         vtable = &PL_vtbl_amagicelem;
4734         break;
4735     case PERL_MAGIC_overload_table:
4736         vtable = &PL_vtbl_ovrld;
4737         break;
4738     case PERL_MAGIC_bm:
4739         vtable = &PL_vtbl_bm;
4740         break;
4741     case PERL_MAGIC_regdata:
4742         vtable = &PL_vtbl_regdata;
4743         break;
4744     case PERL_MAGIC_regdatum:
4745         vtable = &PL_vtbl_regdatum;
4746         break;
4747     case PERL_MAGIC_env:
4748         vtable = &PL_vtbl_env;
4749         break;
4750     case PERL_MAGIC_fm:
4751         vtable = &PL_vtbl_fm;
4752         break;
4753     case PERL_MAGIC_envelem:
4754         vtable = &PL_vtbl_envelem;
4755         break;
4756     case PERL_MAGIC_regex_global:
4757         vtable = &PL_vtbl_mglob;
4758         break;
4759     case PERL_MAGIC_isa:
4760         vtable = &PL_vtbl_isa;
4761         break;
4762     case PERL_MAGIC_isaelem:
4763         vtable = &PL_vtbl_isaelem;
4764         break;
4765     case PERL_MAGIC_nkeys:
4766         vtable = &PL_vtbl_nkeys;
4767         break;
4768     case PERL_MAGIC_dbfile:
4769         vtable = 0;
4770         break;
4771     case PERL_MAGIC_dbline:
4772         vtable = &PL_vtbl_dbline;
4773         break;
4774 #ifdef USE_LOCALE_COLLATE
4775     case PERL_MAGIC_collxfrm:
4776         vtable = &PL_vtbl_collxfrm;
4777         break;
4778 #endif /* USE_LOCALE_COLLATE */
4779     case PERL_MAGIC_tied:
4780         vtable = &PL_vtbl_pack;
4781         break;
4782     case PERL_MAGIC_tiedelem:
4783     case PERL_MAGIC_tiedscalar:
4784         vtable = &PL_vtbl_packelem;
4785         break;
4786     case PERL_MAGIC_qr:
4787         vtable = &PL_vtbl_regexp;
4788         break;
4789     case PERL_MAGIC_sig:
4790         vtable = &PL_vtbl_sig;
4791         break;
4792     case PERL_MAGIC_sigelem:
4793         vtable = &PL_vtbl_sigelem;
4794         break;
4795     case PERL_MAGIC_taint:
4796         vtable = &PL_vtbl_taint;
4797         break;
4798     case PERL_MAGIC_uvar:
4799         vtable = &PL_vtbl_uvar;
4800         break;
4801     case PERL_MAGIC_vec:
4802         vtable = &PL_vtbl_vec;
4803         break;
4804     case PERL_MAGIC_vstring:
4805         vtable = 0;
4806         break;
4807     case PERL_MAGIC_substr:
4808         vtable = &PL_vtbl_substr;
4809         break;
4810     case PERL_MAGIC_defelem:
4811         vtable = &PL_vtbl_defelem;
4812         break;
4813     case PERL_MAGIC_glob:
4814         vtable = &PL_vtbl_glob;
4815         break;
4816     case PERL_MAGIC_arylen:
4817         vtable = &PL_vtbl_arylen;
4818         break;
4819     case PERL_MAGIC_pos:
4820         vtable = &PL_vtbl_pos;
4821         break;
4822     case PERL_MAGIC_backref:
4823         vtable = &PL_vtbl_backref;
4824         break;
4825     case PERL_MAGIC_ext:
4826         /* Reserved for use by extensions not perl internals.           */
4827         /* Useful for attaching extension internal data to perl vars.   */
4828         /* Note that multiple extensions may clash if magical scalars   */
4829         /* etc holding private data from one are passed to another.     */
4830         break;
4831     default:
4832         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4833     }
4834
4835     /* Rest of work is done else where */
4836     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4837
4838     switch (how) {
4839     case PERL_MAGIC_taint:
4840         mg->mg_len = 1;
4841         break;
4842     case PERL_MAGIC_ext:
4843     case PERL_MAGIC_dbfile:
4844         SvRMAGICAL_on(sv);
4845         break;
4846     }
4847 }
4848
4849 /*
4850 =for apidoc sv_unmagic
4851
4852 Removes all magic of type C<type> from an SV.
4853
4854 =cut
4855 */
4856
4857 int
4858 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4859 {
4860     MAGIC* mg;
4861     MAGIC** mgp;
4862     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4863         return 0;
4864     mgp = &SvMAGIC(sv);
4865     for (mg = *mgp; mg; mg = *mgp) {
4866         if (mg->mg_type == type) {
4867             MGVTBL* vtbl = mg->mg_virtual;
4868             *mgp = mg->mg_moremagic;
4869             if (vtbl && vtbl->svt_free)
4870                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4871             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4872                 if (mg->mg_len > 0)
4873                     Safefree(mg->mg_ptr);
4874                 else if (mg->mg_len == HEf_SVKEY)
4875                     SvREFCNT_dec((SV*)mg->mg_ptr);
4876             }
4877             if (mg->mg_flags & MGf_REFCOUNTED)
4878                 SvREFCNT_dec(mg->mg_obj);
4879             Safefree(mg);
4880         }
4881         else
4882             mgp = &mg->mg_moremagic;
4883     }
4884     if (!SvMAGIC(sv)) {
4885         SvMAGICAL_off(sv);
4886        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4887     }
4888
4889     return 0;
4890 }
4891
4892 /*
4893 =for apidoc sv_rvweaken
4894
4895 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4896 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4897 push a back-reference to this RV onto the array of backreferences
4898 associated with that magic.
4899
4900 =cut
4901 */
4902
4903 SV *
4904 Perl_sv_rvweaken(pTHX_ SV *sv)
4905 {
4906     SV *tsv;
4907     if (!SvOK(sv))  /* let undefs pass */
4908         return sv;
4909     if (!SvROK(sv))
4910         Perl_croak(aTHX_ "Can't weaken a nonreference");
4911     else if (SvWEAKREF(sv)) {
4912         if (ckWARN(WARN_MISC))
4913             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4914         return sv;
4915     }
4916     tsv = SvRV(sv);
4917     sv_add_backref(tsv, sv);
4918     SvWEAKREF_on(sv);
4919     SvREFCNT_dec(tsv);
4920     return sv;
4921 }
4922
4923 /* Give tsv backref magic if it hasn't already got it, then push a
4924  * back-reference to sv onto the array associated with the backref magic.
4925  */
4926
4927 STATIC void
4928 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4929 {
4930     AV *av;
4931     MAGIC *mg;
4932     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4933         av = (AV*)mg->mg_obj;
4934     else {
4935         av = newAV();
4936         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4937         SvREFCNT_dec(av);           /* for sv_magic */
4938     }
4939     av_push(av,sv);
4940 }
4941
4942 /* delete a back-reference to ourselves from the backref magic associated
4943  * with the SV we point to.
4944  */
4945
4946 STATIC void
4947 S_sv_del_backref(pTHX_ SV *sv)
4948 {
4949     AV *av;
4950     SV **svp;
4951     I32 i;
4952     SV *tsv = SvRV(sv);
4953     MAGIC *mg = NULL;
4954     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4955         Perl_croak(aTHX_ "panic: del_backref");
4956     av = (AV *)mg->mg_obj;
4957     svp = AvARRAY(av);
4958     i = AvFILLp(av);
4959     while (i >= 0) {
4960         if (svp[i] == sv) {
4961             svp[i] = &PL_sv_undef; /* XXX */
4962         }
4963         i--;
4964     }
4965 }
4966
4967 /*
4968 =for apidoc sv_insert
4969
4970 Inserts a string at the specified offset/length within the SV. Similar to
4971 the Perl substr() function.
4972
4973 =cut
4974 */
4975
4976 void
4977 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4978 {
4979     register char *big;
4980     register char *mid;
4981     register char *midend;
4982     register char *bigend;
4983     register I32 i;
4984     STRLEN curlen;
4985
4986
4987     if (!bigstr)
4988         Perl_croak(aTHX_ "Can't modify non-existent substring");
4989     SvPV_force(bigstr, curlen);
4990     (void)SvPOK_only_UTF8(bigstr);
4991     if (offset + len > curlen) {
4992         SvGROW(bigstr, offset+len+1);
4993         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4994         SvCUR_set(bigstr, offset+len);
4995     }
4996
4997     SvTAINT(bigstr);
4998     i = littlelen - len;
4999     if (i > 0) {                        /* string might grow */
5000         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5001         mid = big + offset + len;
5002         midend = bigend = big + SvCUR(bigstr);
5003         bigend += i;
5004         *bigend = '\0';
5005         while (midend > mid)            /* shove everything down */
5006             *--bigend = *--midend;
5007         Move(little,big+offset,littlelen,char);
5008         SvCUR(bigstr) += i;
5009         SvSETMAGIC(bigstr);
5010         return;
5011     }
5012     else if (i == 0) {
5013         Move(little,SvPVX(bigstr)+offset,len,char);
5014         SvSETMAGIC(bigstr);
5015         return;
5016     }
5017
5018     big = SvPVX(bigstr);
5019     mid = big + offset;
5020     midend = mid + len;
5021     bigend = big + SvCUR(bigstr);
5022
5023     if (midend > bigend)
5024         Perl_croak(aTHX_ "panic: sv_insert");
5025
5026     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5027         if (littlelen) {
5028             Move(little, mid, littlelen,char);
5029             mid += littlelen;
5030         }
5031         i = bigend - midend;
5032         if (i > 0) {
5033             Move(midend, mid, i,char);
5034             mid += i;
5035         }
5036         *mid = '\0';
5037         SvCUR_set(bigstr, mid - big);
5038     }
5039     /*SUPPRESS 560*/
5040     else if ((i = mid - big)) { /* faster from front */
5041         midend -= littlelen;
5042         mid = midend;
5043         sv_chop(bigstr,midend-i);
5044         big += i;
5045         while (i--)
5046             *--midend = *--big;
5047         if (littlelen)
5048             Move(little, mid, littlelen,char);
5049     }
5050     else if (littlelen) {
5051         midend -= littlelen;
5052         sv_chop(bigstr,midend);
5053         Move(little,midend,littlelen,char);
5054     }
5055     else {
5056         sv_chop(bigstr,midend);
5057     }
5058     SvSETMAGIC(bigstr);
5059 }
5060
5061 /*
5062 =for apidoc sv_replace
5063
5064 Make the first argument a copy of the second, then delete the original.
5065 The target SV physically takes over ownership of the body of the source SV
5066 and inherits its flags; however, the target keeps any magic it owns,
5067 and any magic in the source is discarded.
5068 Note that this is a rather specialist SV copying operation; most of the
5069 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5070
5071 =cut
5072 */
5073
5074 void
5075 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5076 {
5077     U32 refcnt = SvREFCNT(sv);
5078     SV_CHECK_THINKFIRST_COW_DROP(sv);
5079     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5080         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5081     if (SvMAGICAL(sv)) {
5082         if (SvMAGICAL(nsv))
5083             mg_free(nsv);
5084         else
5085             sv_upgrade(nsv, SVt_PVMG);
5086         SvMAGIC(nsv) = SvMAGIC(sv);
5087         SvFLAGS(nsv) |= SvMAGICAL(sv);
5088         SvMAGICAL_off(sv);
5089         SvMAGIC(sv) = 0;
5090     }
5091     SvREFCNT(sv) = 0;
5092     sv_clear(sv);
5093     assert(!SvREFCNT(sv));
5094     StructCopy(nsv,sv,SV);
5095 #ifdef PERL_COPY_ON_WRITE
5096     if (SvIsCOW_normal(nsv)) {
5097         /* We need to follow the pointers around the loop to make the
5098            previous SV point to sv, rather than nsv.  */
5099         SV *next;
5100         SV *current = nsv;
5101         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5102             assert(next);
5103             current = next;
5104             assert(SvPVX(current) == SvPVX(nsv));
5105         }
5106         /* Make the SV before us point to the SV after us.  */
5107         if (DEBUG_C_TEST) {
5108             PerlIO_printf(Perl_debug_log, "previous is\n");
5109             sv_dump(current);
5110             PerlIO_printf(Perl_debug_log,
5111                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5112                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5113         }
5114         SV_COW_NEXT_SV_SET(current, sv);
5115     }
5116 #endif
5117     SvREFCNT(sv) = refcnt;
5118     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5119     del_SV(nsv);
5120 }
5121
5122 /*
5123 =for apidoc sv_clear
5124
5125 Clear an SV: call any destructors, free up any memory used by the body,
5126 and free the body itself. The SV's head is I<not> freed, although
5127 its type is set to all 1's so that it won't inadvertently be assumed
5128 to be live during global destruction etc.
5129 This function should only be called when REFCNT is zero. Most of the time
5130 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5131 instead.
5132
5133 =cut
5134 */
5135
5136 void
5137 Perl_sv_clear(pTHX_ register SV *sv)
5138 {
5139     HV* stash;
5140     assert(sv);
5141     assert(SvREFCNT(sv) == 0);
5142
5143     if (SvOBJECT(sv)) {
5144         if (PL_defstash) {              /* Still have a symbol table? */
5145             dSP;
5146             CV* destructor;
5147             SV tmpref;
5148
5149             Zero(&tmpref, 1, SV);
5150             sv_upgrade(&tmpref, SVt_RV);
5151             SvROK_on(&tmpref);
5152             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
5153             SvREFCNT(&tmpref) = 1;
5154
5155             do {
5156                 stash = SvSTASH(sv);
5157                 destructor = StashHANDLER(stash,DESTROY);
5158                 if (destructor) {
5159                     ENTER;
5160                     PUSHSTACKi(PERLSI_DESTROY);
5161                     SvRV(&tmpref) = SvREFCNT_inc(sv);
5162                     EXTEND(SP, 2);
5163                     PUSHMARK(SP);
5164                     PUSHs(&tmpref);
5165                     PUTBACK;
5166                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
5167                     SvREFCNT(sv)--;
5168                     POPSTACK;
5169                     SPAGAIN;
5170                     LEAVE;
5171                 }
5172             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5173
5174             del_XRV(SvANY(&tmpref));
5175
5176             if (SvREFCNT(sv)) {
5177                 if (PL_in_clean_objs)
5178                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5179                           HvNAME(stash));
5180                 /* DESTROY gave object new lease on life */
5181                 return;
5182             }
5183         }
5184
5185         if (SvOBJECT(sv)) {
5186             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
5187             SvOBJECT_off(sv);   /* Curse the object. */
5188             if (SvTYPE(sv) != SVt_PVIO)
5189                 --PL_sv_objcount;       /* XXX Might want something more general */
5190         }
5191     }
5192     if (SvTYPE(sv) >= SVt_PVMG) {
5193         if (SvMAGIC(sv))
5194             mg_free(sv);
5195         if (SvFLAGS(sv) & SVpad_TYPED)
5196             SvREFCNT_dec(SvSTASH(sv));
5197     }
5198     stash = NULL;
5199     switch (SvTYPE(sv)) {
5200     case SVt_PVIO:
5201         if (IoIFP(sv) &&
5202             IoIFP(sv) != PerlIO_stdin() &&
5203             IoIFP(sv) != PerlIO_stdout() &&
5204             IoIFP(sv) != PerlIO_stderr())
5205         {
5206             io_close((IO*)sv, FALSE);
5207         }
5208         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5209             PerlDir_close(IoDIRP(sv));
5210         IoDIRP(sv) = (DIR*)NULL;
5211         Safefree(IoTOP_NAME(sv));
5212         Safefree(IoFMT_NAME(sv));
5213         Safefree(IoBOTTOM_NAME(sv));
5214         /* FALL THROUGH */
5215     case SVt_PVBM:
5216         goto freescalar;
5217     case SVt_PVCV:
5218     case SVt_PVFM:
5219         cv_undef((CV*)sv);
5220         goto freescalar;
5221     case SVt_PVHV:
5222         hv_undef((HV*)sv);
5223         break;
5224     case SVt_PVAV:
5225         av_undef((AV*)sv);
5226         break;
5227     case SVt_PVLV:
5228         SvREFCNT_dec(LvTARG(sv));
5229         goto freescalar;
5230     case SVt_PVGV:
5231         gp_free((GV*)sv);
5232         Safefree(GvNAME(sv));
5233         /* cannot decrease stash refcount yet, as we might recursively delete
5234            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5235            of stash until current sv is completely gone.
5236            -- JohnPC, 27 Mar 1998 */
5237         stash = GvSTASH(sv);
5238         /* FALL THROUGH */
5239     case SVt_PVMG:
5240     case SVt_PVNV:
5241     case SVt_PVIV:
5242       freescalar:
5243         (void)SvOOK_off(sv);
5244         /* FALL THROUGH */
5245     case SVt_PV:
5246     case SVt_RV:
5247         if (SvROK(sv)) {
5248             if (SvWEAKREF(sv))
5249                 sv_del_backref(sv);
5250             else
5251                 SvREFCNT_dec(SvRV(sv));
5252         }
5253 #ifdef PERL_COPY_ON_WRITE
5254         else if (SvPVX(sv)) {
5255             if (SvIsCOW(sv)) {
5256                 /* I believe I need to grab the global SV mutex here and
5257                    then recheck the COW status.  */
5258                 if (DEBUG_C_TEST) {
5259                     PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5260                     sv_dump(sv);
5261                 }
5262                 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
5263                                  SvUVX(sv), SV_COW_NEXT_SV(sv));
5264                 /* And drop it here.  */
5265                 SvFAKE_off(sv);
5266             } else if (SvLEN(sv)) {
5267                 Safefree(SvPVX(sv));
5268             }
5269         }
5270 #else
5271         else if (SvPVX(sv) && SvLEN(sv))
5272             Safefree(SvPVX(sv));
5273         else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5274             unsharepvn(SvPVX(sv),
5275                        SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5276                        SvUVX(sv));
5277             SvFAKE_off(sv);
5278         }
5279 #endif
5280         break;
5281 /*
5282     case SVt_NV:
5283     case SVt_IV:
5284     case SVt_NULL:
5285         break;
5286 */
5287     }
5288
5289     switch (SvTYPE(sv)) {
5290     case SVt_NULL:
5291         break;
5292     case SVt_IV:
5293         del_XIV(SvANY(sv));
5294         break;
5295     case SVt_NV:
5296         del_XNV(SvANY(sv));
5297         break;
5298     case SVt_RV:
5299         del_XRV(SvANY(sv));
5300         break;
5301     case SVt_PV:
5302         del_XPV(SvANY(sv));
5303         break;
5304     case SVt_PVIV:
5305         del_XPVIV(SvANY(sv));
5306         break;
5307     case SVt_PVNV:
5308         del_XPVNV(SvANY(sv));
5309         break;
5310     case SVt_PVMG:
5311         del_XPVMG(SvANY(sv));
5312         break;
5313     case SVt_PVLV:
5314         del_XPVLV(SvANY(sv));
5315         break;
5316     case SVt_PVAV:
5317         del_XPVAV(SvANY(sv));
5318         break;
5319     case SVt_PVHV:
5320         del_XPVHV(SvANY(sv));
5321         break;
5322     case SVt_PVCV:
5323         del_XPVCV(SvANY(sv));
5324         break;
5325     case SVt_PVGV:
5326         del_XPVGV(SvANY(sv));
5327         /* code duplication for increased performance. */
5328         SvFLAGS(sv) &= SVf_BREAK;
5329         SvFLAGS(sv) |= SVTYPEMASK;
5330         /* decrease refcount of the stash that owns this GV, if any */
5331         if (stash)
5332             SvREFCNT_dec(stash);
5333         return; /* not break, SvFLAGS reset already happened */
5334     case SVt_PVBM:
5335         del_XPVBM(SvANY(sv));
5336         break;
5337     case SVt_PVFM:
5338         del_XPVFM(SvANY(sv));
5339         break;
5340     case SVt_PVIO:
5341         del_XPVIO(SvANY(sv));
5342         break;
5343     }
5344     SvFLAGS(sv) &= SVf_BREAK;
5345     SvFLAGS(sv) |= SVTYPEMASK;
5346 }
5347
5348 /*
5349 =for apidoc sv_newref
5350
5351 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5352 instead.
5353
5354 =cut
5355 */
5356
5357 SV *
5358 Perl_sv_newref(pTHX_ SV *sv)
5359 {
5360     if (sv)
5361         ATOMIC_INC(SvREFCNT(sv));
5362     return sv;
5363 }
5364
5365 /*
5366 =for apidoc sv_free
5367
5368 Decrement an SV's reference count, and if it drops to zero, call
5369 C<sv_clear> to invoke destructors and free up any memory used by
5370 the body; finally, deallocate the SV's head itself.
5371 Normally called via a wrapper macro C<SvREFCNT_dec>.
5372
5373 =cut
5374 */
5375
5376 void
5377 Perl_sv_free(pTHX_ SV *sv)
5378 {
5379     int refcount_is_zero;
5380
5381     if (!sv)
5382         return;
5383     if (SvREFCNT(sv) == 0) {
5384         if (SvFLAGS(sv) & SVf_BREAK)
5385             /* this SV's refcnt has been artificially decremented to
5386              * trigger cleanup */
5387             return;
5388         if (PL_in_clean_all) /* All is fair */
5389             return;
5390         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5391             /* make sure SvREFCNT(sv)==0 happens very seldom */
5392             SvREFCNT(sv) = (~(U32)0)/2;
5393             return;
5394         }
5395         if (ckWARN_d(WARN_INTERNAL))
5396             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
5397         return;
5398     }
5399     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5400     if (!refcount_is_zero)
5401         return;
5402 #ifdef DEBUGGING
5403     if (SvTEMP(sv)) {
5404         if (ckWARN_d(WARN_DEBUGGING))
5405             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5406                         "Attempt to free temp prematurely: SV 0x%"UVxf,
5407                         PTR2UV(sv));
5408         return;
5409     }
5410 #endif
5411     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5412         /* make sure SvREFCNT(sv)==0 happens very seldom */
5413         SvREFCNT(sv) = (~(U32)0)/2;
5414         return;
5415     }
5416     sv_clear(sv);
5417     if (! SvREFCNT(sv))
5418         del_SV(sv);
5419 }
5420
5421 /*
5422 =for apidoc sv_len
5423
5424 Returns the length of the string in the SV. Handles magic and type
5425 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5426
5427 =cut
5428 */
5429
5430 STRLEN
5431 Perl_sv_len(pTHX_ register SV *sv)
5432 {
5433     STRLEN len;
5434
5435     if (!sv)
5436         return 0;
5437
5438     if (SvGMAGICAL(sv))
5439         len = mg_length(sv);
5440     else
5441         (void)SvPV(sv, len);
5442     return len;
5443 }
5444
5445 /*
5446 =for apidoc sv_len_utf8
5447
5448 Returns the number of characters in the string in an SV, counting wide
5449 UTF8 bytes as a single character. Handles magic and type coercion.
5450
5451 =cut
5452 */
5453
5454 STRLEN
5455 Perl_sv_len_utf8(pTHX_ register SV *sv)
5456 {
5457     if (!sv)
5458         return 0;
5459
5460     if (SvGMAGICAL(sv))
5461         return mg_length(sv);
5462     else
5463     {
5464         STRLEN len;
5465         U8 *s = (U8*)SvPV(sv, len);
5466
5467         return Perl_utf8_length(aTHX_ s, s + len);
5468     }
5469 }
5470
5471 /*
5472 =for apidoc sv_pos_u2b
5473
5474 Converts the value pointed to by offsetp from a count of UTF8 chars from
5475 the start of the string, to a count of the equivalent number of bytes; if
5476 lenp is non-zero, it does the same to lenp, but this time starting from
5477 the offset, rather than from the start of the string. Handles magic and
5478 type coercion.
5479
5480 =cut
5481 */
5482
5483 void
5484 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5485 {
5486     U8 *start;
5487     U8 *s;
5488     U8 *send;
5489     I32 uoffset = *offsetp;
5490     STRLEN len;
5491
5492     if (!sv)
5493         return;
5494
5495     start = s = (U8*)SvPV(sv, len);
5496     send = s + len;
5497     while (s < send && uoffset--)
5498         s += UTF8SKIP(s);
5499     if (s >= send)
5500         s = send;
5501     *offsetp = s - start;
5502     if (lenp) {
5503         I32 ulen = *lenp;
5504         start = s;
5505         while (s < send && ulen--)
5506             s += UTF8SKIP(s);
5507         if (s >= send)
5508             s = send;
5509         *lenp = s - start;
5510     }
5511     return;
5512 }
5513
5514 /*
5515 =for apidoc sv_pos_b2u
5516
5517 Converts the value pointed to by offsetp from a count of bytes from the
5518 start of the string, to a count of the equivalent number of UTF8 chars.
5519 Handles magic and type coercion.
5520
5521 =cut
5522 */
5523
5524 void
5525 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5526 {
5527     U8 *s;
5528     U8 *send;
5529     STRLEN len;
5530
5531     if (!sv)
5532         return;
5533
5534     s = (U8*)SvPV(sv, len);
5535     if ((I32)len < *offsetp)
5536         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5537     send = s + *offsetp;
5538     len = 0;
5539     while (s < send) {
5540         STRLEN n = 1;
5541         /* Call utf8n_to_uvchr() to validate the sequence
5542          * (unless a simple non-UTF character) */
5543         if (!UTF8_IS_INVARIANT(*s))
5544             utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5545         if (n > 0) {
5546             s += n;
5547             len++;
5548         }
5549         else
5550             break;
5551     }
5552     *offsetp = len;
5553     return;
5554 }
5555
5556 /*
5557 =for apidoc sv_eq
5558
5559 Returns a boolean indicating whether the strings in the two SVs are
5560 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5561 coerce its args to strings if necessary.
5562
5563 =cut
5564 */
5565
5566 I32
5567 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5568 {
5569     char *pv1;
5570     STRLEN cur1;
5571     char *pv2;
5572     STRLEN cur2;
5573     I32  eq     = 0;
5574     char *tpv   = Nullch;
5575     SV* svrecode = Nullsv;
5576
5577     if (!sv1) {
5578         pv1 = "";
5579         cur1 = 0;
5580     }
5581     else
5582         pv1 = SvPV(sv1, cur1);
5583
5584     if (!sv2){
5585         pv2 = "";
5586         cur2 = 0;
5587     }
5588     else
5589         pv2 = SvPV(sv2, cur2);
5590
5591     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5592         /* Differing utf8ness.
5593          * Do not UTF8size the comparands as a side-effect. */
5594          if (PL_encoding) {
5595               if (SvUTF8(sv1)) {
5596                    svrecode = newSVpvn(pv2, cur2);
5597                    sv_recode_to_utf8(svrecode, PL_encoding);
5598                    pv2 = SvPV(svrecode, cur2);
5599               }
5600               else {
5601                    svrecode = newSVpvn(pv1, cur1);
5602                    sv_recode_to_utf8(svrecode, PL_encoding);
5603                    pv1 = SvPV(svrecode, cur1);
5604               }
5605               /* Now both are in UTF-8. */
5606               if (cur1 != cur2)
5607                    return FALSE;
5608          }
5609          else {
5610               bool is_utf8 = TRUE;
5611
5612               if (SvUTF8(sv1)) {
5613                    /* sv1 is the UTF-8 one,
5614                     * if is equal it must be downgrade-able */
5615                    char *pv = (char*)bytes_from_utf8((U8*)pv1,
5616                                                      &cur1, &is_utf8);
5617                    if (pv != pv1)
5618                         pv1 = tpv = pv;
5619               }
5620               else {
5621                    /* sv2 is the UTF-8 one,
5622                     * if is equal it must be downgrade-able */
5623                    char *pv = (char *)bytes_from_utf8((U8*)pv2,
5624                                                       &cur2, &is_utf8);
5625                    if (pv != pv2)
5626                         pv2 = tpv = pv;
5627               }
5628               if (is_utf8) {
5629                    /* Downgrade not possible - cannot be eq */
5630                    return FALSE;
5631               }
5632          }
5633     }
5634
5635     if (cur1 == cur2)
5636         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
5637
5638     if (svrecode)
5639          SvREFCNT_dec(svrecode);
5640
5641     if (tpv)
5642         Safefree(tpv);
5643
5644     return eq;
5645 }
5646
5647 /*
5648 =for apidoc sv_cmp
5649
5650 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
5651 string in C<sv1> is less than, equal to, or greater than the string in
5652 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5653 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
5654
5655 =cut
5656 */
5657
5658 I32
5659 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5660 {
5661     STRLEN cur1, cur2;
5662     char *pv1, *pv2, *tpv = Nullch;
5663     I32  cmp;
5664     SV *svrecode = Nullsv;
5665
5666     if (!sv1) {
5667         pv1 = "";
5668         cur1 = 0;
5669     }
5670     else
5671         pv1 = SvPV(sv1, cur1);
5672
5673     if (!sv2) {
5674         pv2 = "";
5675         cur2 = 0;
5676     }
5677     else
5678         pv2 = SvPV(sv2, cur2);
5679
5680     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5681         /* Differing utf8ness.
5682          * Do not UTF8size the comparands as a side-effect. */
5683         if (SvUTF8(sv1)) {
5684             if (PL_encoding) {
5685                  svrecode = newSVpvn(pv2, cur2);
5686                  sv_recode_to_utf8(svrecode, PL_encoding);
5687                  pv2 = SvPV(svrecode, cur2);
5688             }
5689             else {
5690                  pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5691             }
5692         }
5693         else {
5694             if (PL_encoding) {
5695                  svrecode = newSVpvn(pv1, cur1);
5696                  sv_recode_to_utf8(svrecode, PL_encoding);
5697                  pv1 = SvPV(svrecode, cur1);
5698             }
5699             else {
5700                  pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5701             }
5702         }
5703     }
5704
5705     if (!cur1) {
5706         cmp = cur2 ? -1 : 0;
5707     } else if (!cur2) {
5708         cmp = 1;
5709     } else {
5710         I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5711
5712         if (retval) {
5713             cmp = retval < 0 ? -1 : 1;
5714         } else if (cur1 == cur2) {
5715             cmp = 0;
5716         } else {
5717             cmp = cur1 < cur2 ? -1 : 1;
5718         }
5719     }
5720
5721     if (svrecode)
5722          SvREFCNT_dec(svrecode);
5723
5724     if (tpv)
5725         Safefree(tpv);
5726
5727     return cmp;
5728 }
5729
5730 /*
5731 =for apidoc sv_cmp_locale
5732
5733 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5734 'use bytes' aware, handles get magic, and will coerce its args to strings
5735 if necessary.  See also C<sv_cmp_locale>.  See also C<sv_cmp>.
5736
5737 =cut
5738 */
5739
5740 I32
5741 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5742 {
5743 #ifdef USE_LOCALE_COLLATE
5744
5745     char *pv1, *pv2;
5746     STRLEN len1, len2;
5747     I32 retval;
5748
5749     if (PL_collation_standard)
5750         goto raw_compare;
5751
5752     len1 = 0;
5753     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5754     len2 = 0;
5755     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5756
5757     if (!pv1 || !len1) {
5758         if (pv2 && len2)
5759             return -1;
5760         else
5761             goto raw_compare;
5762     }
5763     else {
5764         if (!pv2 || !len2)
5765             return 1;
5766     }
5767
5768     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5769
5770     if (retval)
5771         return retval < 0 ? -1 : 1;
5772
5773     /*
5774      * When the result of collation is equality, that doesn't mean
5775      * that there are no differences -- some locales exclude some
5776      * characters from consideration.  So to avoid false equalities,
5777      * we use the raw string as a tiebreaker.
5778      */
5779
5780   raw_compare:
5781     /* FALL THROUGH */
5782
5783 #endif /* USE_LOCALE_COLLATE */
5784
5785     return sv_cmp(sv1, sv2);
5786 }
5787
5788
5789 #ifdef USE_LOCALE_COLLATE
5790
5791 /*
5792 =for apidoc sv_collxfrm
5793
5794 Add Collate Transform magic to an SV if it doesn't already have it.
5795
5796 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5797 scalar data of the variable, but transformed to such a format that a normal
5798 memory comparison can be used to compare the data according to the locale
5799 settings.
5800
5801 =cut
5802 */
5803
5804 char *
5805 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5806 {
5807     MAGIC *mg;
5808
5809     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5810     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5811         char *s, *xf;
5812         STRLEN len, xlen;
5813
5814         if (mg)
5815             Safefree(mg->mg_ptr);
5816         s = SvPV(sv, len);
5817         if ((xf = mem_collxfrm(s, len, &xlen))) {
5818             if (SvREADONLY(sv)) {
5819                 SAVEFREEPV(xf);
5820                 *nxp = xlen;
5821                 return xf + sizeof(PL_collation_ix);
5822             }
5823             if (! mg) {
5824                 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5825                 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5826                 assert(mg);
5827             }
5828             mg->mg_ptr = xf;
5829             mg->mg_len = xlen;
5830         }
5831         else {
5832             if (mg) {
5833                 mg->mg_ptr = NULL;
5834                 mg->mg_len = -1;
5835             }
5836         }
5837     }
5838     if (mg && mg->mg_ptr) {
5839         *nxp = mg->mg_len;
5840         return mg->mg_ptr + sizeof(PL_collation_ix);
5841     }
5842     else {
5843         *nxp = 0;
5844         return NULL;
5845     }
5846 }
5847
5848 #endif /* USE_LOCALE_COLLATE */
5849
5850 /*
5851 =for apidoc sv_gets
5852
5853 Get a line from the filehandle and store it into the SV, optionally
5854 appending to the currently-stored string.
5855
5856 =cut
5857 */
5858
5859 char *
5860 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5861 {
5862     char *rsptr;
5863     STRLEN rslen;
5864     register STDCHAR rslast;
5865     register STDCHAR *bp;
5866     register I32 cnt;
5867     I32 i = 0;
5868     I32 rspara = 0;
5869
5870     SV_CHECK_THINKFIRST_COW_DROP(sv);
5871     /* XXX. If you make this PVIV, then copy on write can copy scalars read
5872        from <>.
5873        However, perlbench says it's slower, because the existing swipe code
5874        is faster than copy on write.
5875        Swings and roundabouts.  */
5876     (void)SvUPGRADE(sv, SVt_PV);
5877
5878     SvSCREAM_off(sv);
5879
5880     if (PL_curcop == &PL_compiling) {
5881         /* we always read code in line mode */
5882         rsptr = "\n";
5883         rslen = 1;
5884     }
5885     else if (RsSNARF(PL_rs)) {
5886         rsptr = NULL;
5887         rslen = 0;
5888     }
5889     else if (RsRECORD(PL_rs)) {
5890       I32 recsize, bytesread;
5891       char *buffer;
5892
5893       /* Grab the size of the record we're getting */
5894       recsize = SvIV(SvRV(PL_rs));
5895       (void)SvPOK_only(sv);    /* Validate pointer */
5896       buffer = SvGROW(sv, (STRLEN)(recsize + 1));
5897       /* Go yank in */
5898 #ifdef VMS
5899       /* VMS wants read instead of fread, because fread doesn't respect */
5900       /* RMS record boundaries. This is not necessarily a good thing to be */
5901       /* doing, but we've got no other real choice */
5902       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5903 #else
5904       bytesread = PerlIO_read(fp, buffer, recsize);
5905 #endif
5906       SvCUR_set(sv, bytesread);
5907       buffer[bytesread] = '\0';
5908       if (PerlIO_isutf8(fp))
5909         SvUTF8_on(sv);
5910       else
5911         SvUTF8_off(sv);
5912       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5913     }
5914     else if (RsPARA(PL_rs)) {
5915         rsptr = "\n\n";
5916         rslen = 2;
5917         rspara = 1;
5918     }
5919     else {
5920         /* Get $/ i.e. PL_rs into same encoding as stream wants */
5921         if (PerlIO_isutf8(fp)) {
5922             rsptr = SvPVutf8(PL_rs, rslen);
5923         }
5924         else {
5925             if (SvUTF8(PL_rs)) {
5926                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5927                     Perl_croak(aTHX_ "Wide character in $/");
5928                 }
5929             }
5930             rsptr = SvPV(PL_rs, rslen);
5931         }
5932     }
5933
5934     rslast = rslen ? rsptr[rslen - 1] : '\0';
5935
5936     if (rspara) {               /* have to do this both before and after */
5937         do {                    /* to make sure file boundaries work right */
5938             if (PerlIO_eof(fp))
5939                 return 0;
5940             i = PerlIO_getc(fp);
5941             if (i != '\n') {
5942                 if (i == -1)
5943                     return 0;
5944                 PerlIO_ungetc(fp,i);
5945                 break;
5946             }
5947         } while (i != EOF);
5948     }
5949
5950     /* See if we know enough about I/O mechanism to cheat it ! */
5951
5952     /* This used to be #ifdef test - it is made run-time test for ease
5953        of abstracting out stdio interface. One call should be cheap
5954        enough here - and may even be a macro allowing compile
5955        time optimization.
5956      */
5957
5958     if (PerlIO_fast_gets(fp)) {
5959
5960     /*
5961      * We're going to steal some values from the stdio struct
5962      * and put EVERYTHING in the innermost loop into registers.
5963      */
5964     register STDCHAR *ptr;
5965     STRLEN bpx;
5966     I32 shortbuffered;
5967
5968 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5969     /* An ungetc()d char is handled separately from the regular
5970      * buffer, so we getc() it back out and stuff it in the buffer.
5971      */
5972     i = PerlIO_getc(fp);
5973     if (i == EOF) return 0;
5974     *(--((*fp)->_ptr)) = (unsigned char) i;
5975     (*fp)->_cnt++;
5976 #endif
5977
5978     /* Here is some breathtakingly efficient cheating */
5979
5980     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
5981     (void)SvPOK_only(sv);               /* validate pointer */
5982     if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */
5983         if (cnt > 80 && (I32)SvLEN(sv) > append) {
5984             shortbuffered = cnt - SvLEN(sv) + append + 1;
5985             cnt -= shortbuffered;
5986         }
5987         else {
5988             shortbuffered = 0;
5989             /* remember that cnt can be negative */
5990             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
5991         }
5992     }
5993     else
5994         shortbuffered = 0;
5995     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
5996     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5997     DEBUG_P(PerlIO_printf(Perl_debug_log,
5998         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5999     DEBUG_P(PerlIO_printf(Perl_debug_log,
6000         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6001                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6002                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6003     for (;;) {
6004       screamer:
6005         if (cnt > 0) {
6006             if (rslen) {
6007                 while (cnt > 0) {                    /* this     |  eat */
6008                     cnt--;
6009                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
6010                         goto thats_all_folks;        /* screams  |  sed :-) */
6011                 }
6012             }
6013             else {
6014                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
6015                 bp += cnt;                           /* screams  |  dust */
6016                 ptr += cnt;                          /* louder   |  sed :-) */
6017                 cnt = 0;
6018             }
6019         }
6020
6021         if (shortbuffered) {            /* oh well, must extend */
6022             cnt = shortbuffered;
6023             shortbuffered = 0;
6024             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6025             SvCUR_set(sv, bpx);
6026             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6027             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6028             continue;
6029         }
6030
6031         DEBUG_P(PerlIO_printf(Perl_debug_log,
6032                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6033                               PTR2UV(ptr),(long)cnt));
6034         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6035 #if 0
6036         DEBUG_P(PerlIO_printf(Perl_debug_log,
6037             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6038             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6039             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6040 #endif
6041         /* This used to call 'filbuf' in stdio form, but as that behaves like
6042            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6043            another abstraction.  */
6044         i   = PerlIO_getc(fp);          /* get more characters */
6045 #if 0
6046         DEBUG_P(PerlIO_printf(Perl_debug_log,
6047             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6048             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6049             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6050 #endif
6051         cnt = PerlIO_get_cnt(fp);
6052         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
6053         DEBUG_P(PerlIO_printf(Perl_debug_log,
6054             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6055
6056         if (i == EOF)                   /* all done for ever? */
6057             goto thats_really_all_folks;
6058
6059         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6060         SvCUR_set(sv, bpx);
6061         SvGROW(sv, bpx + cnt + 2);
6062         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6063
6064         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
6065
6066         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
6067             goto thats_all_folks;
6068     }
6069
6070 thats_all_folks:
6071     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
6072           memNE((char*)bp - rslen, rsptr, rslen))
6073         goto screamer;                          /* go back to the fray */
6074 thats_really_all_folks:
6075     if (shortbuffered)
6076         cnt += shortbuffered;
6077         DEBUG_P(PerlIO_printf(Perl_debug_log,
6078             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6079     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
6080     DEBUG_P(PerlIO_printf(Perl_debug_log,
6081         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6082         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6083         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6084     *bp = '\0';
6085     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
6086     DEBUG_P(PerlIO_printf(Perl_debug_log,
6087         "Screamer: done, len=%ld, string=|%.*s|\n",
6088         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
6089     }
6090    else
6091     {
6092 #ifndef EPOC
6093        /*The big, slow, and stupid way */
6094         STDCHAR buf[8192];
6095 #else
6096         /* Need to work around EPOC SDK features          */
6097         /* On WINS: MS VC5 generates calls to _chkstk,    */
6098         /* if a `large' stack frame is allocated          */
6099         /* gcc on MARM does not generate calls like these */
6100         STDCHAR buf[1024];
6101 #endif
6102
6103 screamer2:
6104         if (rslen) {
6105             register STDCHAR *bpe = buf + sizeof(buf);
6106             bp = buf;
6107             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6108                 ; /* keep reading */
6109             cnt = bp - buf;
6110         }
6111         else {
6112             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6113             /* Accomodate broken VAXC compiler, which applies U8 cast to
6114              * both args of ?: operator, causing EOF to change into 255
6115              */
6116             if (cnt > 0)
6117                  i = (U8)buf[cnt - 1];
6118             else
6119                  i = EOF;
6120         }
6121
6122         if (cnt < 0)
6123             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
6124         if (append)
6125              sv_catpvn(sv, (char *) buf, cnt);
6126         else
6127              sv_setpvn(sv, (char *) buf, cnt);
6128
6129         if (i != EOF &&                 /* joy */
6130             (!rslen ||
6131              SvCUR(sv) < rslen ||
6132              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6133         {
6134             append = -1;
6135             /*
6136              * If we're reading from a TTY and we get a short read,
6137              * indicating that the user hit his EOF character, we need
6138              * to notice it now, because if we try to read from the TTY
6139              * again, the EOF condition will disappear.
6140              *
6141              * The comparison of cnt to sizeof(buf) is an optimization
6142              * that prevents unnecessary calls to feof().
6143              *
6144              * - jik 9/25/96
6145              */
6146             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6147                 goto screamer2;
6148         }
6149     }
6150
6151     if (rspara) {               /* have to do this both before and after */
6152         while (i != EOF) {      /* to make sure file boundaries work right */
6153             i = PerlIO_getc(fp);
6154             if (i != '\n') {
6155                 PerlIO_ungetc(fp,i);
6156                 break;
6157             }
6158         }
6159     }
6160
6161     if (PerlIO_isutf8(fp))
6162         SvUTF8_on(sv);
6163     else
6164         SvUTF8_off(sv);
6165
6166     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6167 }
6168
6169 /*
6170 =for apidoc sv_inc
6171
6172 Auto-increment of the value in the SV, doing string to numeric conversion
6173 if necessary. Handles 'get' magic.
6174
6175 =cut
6176 */
6177
6178 void
6179 Perl_sv_inc(pTHX_ register SV *sv)
6180 {
6181     register char *d;
6182     int flags;
6183
6184     if (!sv)
6185         return;
6186     if (SvGMAGICAL(sv))
6187         mg_get(sv);
6188     if (SvTHINKFIRST(sv)) {
6189         if (SvIsCOW(sv))
6190             sv_force_normal_flags(sv, 0);
6191         if (SvREADONLY(sv)) {
6192             if (PL_curcop != &PL_compiling)
6193                 Perl_croak(aTHX_ PL_no_modify);
6194         }
6195         if (SvROK(sv)) {
6196             IV i;
6197             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6198                 return;
6199             i = PTR2IV(SvRV(sv));
6200             sv_unref(sv);
6201             sv_setiv(sv, i);
6202         }
6203     }
6204     flags = SvFLAGS(sv);
6205     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6206         /* It's (privately or publicly) a float, but not tested as an
6207            integer, so test it to see. */
6208         (void) SvIV(sv);
6209         flags = SvFLAGS(sv);
6210     }
6211     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6212         /* It's publicly an integer, or privately an integer-not-float */
6213 #ifdef PERL_PRESERVE_IVUV
6214       oops_its_int:
6215 #endif
6216         if (SvIsUV(sv)) {
6217             if (SvUVX(sv) == UV_MAX)
6218                 sv_setnv(sv, UV_MAX_P1);
6219             else
6220                 (void)SvIOK_only_UV(sv);
6221                 ++SvUVX(sv);
6222         } else {
6223             if (SvIVX(sv) == IV_MAX)
6224                 sv_setuv(sv, (UV)IV_MAX + 1);
6225             else {
6226                 (void)SvIOK_only(sv);
6227                 ++SvIVX(sv);
6228             }
6229         }
6230         return;
6231     }
6232     if (flags & SVp_NOK) {
6233         (void)SvNOK_only(sv);
6234         SvNVX(sv) += 1.0;
6235         return;
6236     }
6237
6238     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
6239         if ((flags & SVTYPEMASK) < SVt_PVIV)
6240             sv_upgrade(sv, SVt_IV);
6241         (void)SvIOK_only(sv);
6242         SvIVX(sv) = 1;
6243         return;
6244     }
6245     d = SvPVX(sv);
6246     while (isALPHA(*d)) d++;
6247     while (isDIGIT(*d)) d++;
6248     if (*d) {
6249 #ifdef PERL_PRESERVE_IVUV
6250         /* Got to punt this as an integer if needs be, but we don't issue
6251            warnings. Probably ought to make the sv_iv_please() that does
6252            the conversion if possible, and silently.  */
6253         int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6254         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6255             /* Need to try really hard to see if it's an integer.
6256                9.22337203685478e+18 is an integer.
6257                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6258                so $a="9.22337203685478e+18"; $a+0; $a++
6259                needs to be the same as $a="9.22337203685478e+18"; $a++
6260                or we go insane. */
6261
6262             (void) sv_2iv(sv);
6263             if (SvIOK(sv))
6264                 goto oops_its_int;
6265
6266             /* sv_2iv *should* have made this an NV */
6267             if (flags & SVp_NOK) {
6268                 (void)SvNOK_only(sv);
6269                 SvNVX(sv) += 1.0;
6270                 return;
6271             }
6272             /* I don't think we can get here. Maybe I should assert this
6273                And if we do get here I suspect that sv_setnv will croak. NWC
6274                Fall through. */
6275 #if defined(USE_LONG_DOUBLE)
6276             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",
6277                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6278 #else
6279             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6280                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6281 #endif
6282         }
6283 #endif /* PERL_PRESERVE_IVUV */
6284         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
6285         return;
6286     }
6287     d--;
6288     while (d >= SvPVX(sv)) {
6289         if (isDIGIT(*d)) {
6290             if (++*d <= '9')
6291                 return;
6292             *(d--) = '0';
6293         }
6294         else {
6295 #ifdef EBCDIC
6296             /* MKS: The original code here died if letters weren't consecutive.
6297              * at least it didn't have to worry about non-C locales.  The
6298              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6299              * arranged in order (although not consecutively) and that only
6300              * [A-Za-z] are accepted by isALPHA in the C locale.
6301              */
6302             if (*d != 'z' && *d != 'Z') {
6303                 do { ++*d; } while (!isALPHA(*d));
6304                 return;
6305             }
6306             *(d--) -= 'z' - 'a';
6307 #else
6308             ++*d;
6309             if (isALPHA(*d))
6310                 return;
6311             *(d--) -= 'z' - 'a' + 1;
6312 #endif
6313         }
6314     }
6315     /* oh,oh, the number grew */
6316     SvGROW(sv, SvCUR(sv) + 2);
6317     SvCUR(sv)++;
6318     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
6319         *d = d[-1];
6320     if (isDIGIT(d[1]))
6321         *d = '1';
6322     else
6323         *d = d[1];
6324 }
6325
6326 /*
6327 =for apidoc sv_dec
6328
6329 Auto-decrement of the value in the SV, doing string to numeric conversion
6330 if necessary. Handles 'get' magic.
6331
6332 =cut
6333 */
6334
6335 void
6336 Perl_sv_dec(pTHX_ register SV *sv)
6337 {
6338     int flags;
6339
6340     if (!sv)
6341         return;
6342     if (SvGMAGICAL(sv))
6343         mg_get(sv);
6344     if (SvTHINKFIRST(sv)) {
6345         if (SvIsCOW(sv))
6346             sv_force_normal_flags(sv, 0);
6347         if (SvREADONLY(sv)) {
6348             if (PL_curcop != &PL_compiling)
6349                 Perl_croak(aTHX_ PL_no_modify);
6350         }
6351         if (SvROK(sv)) {
6352             IV i;
6353             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6354                 return;
6355             i = PTR2IV(SvRV(sv));
6356             sv_unref(sv);
6357             sv_setiv(sv, i);
6358         }
6359     }
6360     /* Unlike sv_inc we don't have to worry about string-never-numbers
6361        and keeping them magic. But we mustn't warn on punting */
6362     flags = SvFLAGS(sv);
6363     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6364         /* It's publicly an integer, or privately an integer-not-float */
6365 #ifdef PERL_PRESERVE_IVUV
6366       oops_its_int:
6367 #endif
6368         if (SvIsUV(sv)) {
6369             if (SvUVX(sv) == 0) {
6370                 (void)SvIOK_only(sv);
6371                 SvIVX(sv) = -1;
6372             }
6373             else {
6374                 (void)SvIOK_only_UV(sv);
6375                 --SvUVX(sv);
6376             }
6377         } else {
6378             if (SvIVX(sv) == IV_MIN)
6379                 sv_setnv(sv, (NV)IV_MIN - 1.0);
6380             else {
6381                 (void)SvIOK_only(sv);
6382                 --SvIVX(sv);
6383             }
6384         }
6385         return;
6386     }
6387     if (flags & SVp_NOK) {
6388         SvNVX(sv) -= 1.0;
6389         (void)SvNOK_only(sv);
6390         return;
6391     }
6392     if (!(flags & SVp_POK)) {
6393         if ((flags & SVTYPEMASK) < SVt_PVNV)
6394             sv_upgrade(sv, SVt_NV);
6395         SvNVX(sv) = -1.0;
6396         (void)SvNOK_only(sv);
6397         return;
6398     }
6399 #ifdef PERL_PRESERVE_IVUV
6400     {
6401         int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6402         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6403             /* Need to try really hard to see if it's an integer.
6404                9.22337203685478e+18 is an integer.
6405                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6406                so $a="9.22337203685478e+18"; $a+0; $a--
6407                needs to be the same as $a="9.22337203685478e+18"; $a--
6408                or we go insane. */
6409
6410             (void) sv_2iv(sv);
6411             if (SvIOK(sv))
6412                 goto oops_its_int;
6413
6414             /* sv_2iv *should* have made this an NV */
6415             if (flags & SVp_NOK) {
6416                 (void)SvNOK_only(sv);
6417                 SvNVX(sv) -= 1.0;
6418                 return;
6419             }
6420             /* I don't think we can get here. Maybe I should assert this
6421                And if we do get here I suspect that sv_setnv will croak. NWC
6422                Fall through. */
6423 #if defined(USE_LONG_DOUBLE)
6424             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",
6425                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6426 #else
6427             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6428                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6429 #endif
6430         }
6431     }
6432 #endif /* PERL_PRESERVE_IVUV */
6433     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6434 }
6435
6436 /*
6437 =for apidoc sv_mortalcopy
6438
6439 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6440 The new SV is marked as mortal. It will be destroyed "soon", either by an
6441 explicit call to FREETMPS, or by an implicit call at places such as
6442 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
6443
6444 =cut
6445 */
6446
6447 /* Make a string that will exist for the duration of the expression
6448  * evaluation.  Actually, it may have to last longer than that, but
6449  * hopefully we won't free it until it has been assigned to a
6450  * permanent location. */
6451
6452 SV *
6453 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6454 {
6455     register SV *sv;
6456
6457     new_SV(sv);
6458     sv_setsv(sv,oldstr);
6459     EXTEND_MORTAL(1);
6460     PL_tmps_stack[++PL_tmps_ix] = sv;
6461     SvTEMP_on(sv);
6462     return sv;
6463 }
6464
6465 /*
6466 =for apidoc sv_newmortal
6467
6468 Creates a new null SV which is mortal.  The reference count of the SV is
6469 set to 1. It will be destroyed "soon", either by an explicit call to
6470 FREETMPS, or by an implicit call at places such as statement boundaries.
6471 See also C<sv_mortalcopy> and C<sv_2mortal>.
6472
6473 =cut
6474 */
6475
6476 SV *
6477 Perl_sv_newmortal(pTHX)
6478 {
6479     register SV *sv;
6480
6481     new_SV(sv);
6482     SvFLAGS(sv) = SVs_TEMP;
6483     EXTEND_MORTAL(1);
6484     PL_tmps_stack[++PL_tmps_ix] = sv;
6485     return sv;
6486 }
6487
6488 /*
6489 =for apidoc sv_2mortal
6490
6491 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
6492 by an explicit call to FREETMPS, or by an implicit call at places such as
6493 statement boundaries.  See also C<sv_newmortal> and C<sv_mortalcopy>.
6494
6495 =cut
6496 */
6497
6498 SV *
6499 Perl_sv_2mortal(pTHX_ register SV *sv)
6500 {
6501     if (!sv)
6502         return sv;
6503     if (SvREADONLY(sv) && SvIMMORTAL(sv))
6504         return sv;
6505     EXTEND_MORTAL(1);
6506     PL_tmps_stack[++PL_tmps_ix] = sv;
6507     SvTEMP_on(sv);
6508     return sv;
6509 }
6510
6511 /*
6512 =for apidoc newSVpv
6513
6514 Creates a new SV and copies a string into it.  The reference count for the
6515 SV is set to 1.  If C<len> is zero, Perl will compute the length using
6516 strlen().  For efficiency, consider using C<newSVpvn> instead.
6517
6518 =cut
6519 */
6520
6521 SV *
6522 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6523 {
6524     register SV *sv;
6525
6526     new_SV(sv);
6527     if (!len)
6528         len = strlen(s);
6529     sv_setpvn(sv,s,len);
6530     return sv;
6531 }
6532
6533 /*
6534 =for apidoc newSVpvn
6535
6536 Creates a new SV and copies a string into it.  The reference count for the
6537 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
6538 string.  You are responsible for ensuring that the source string is at least
6539 C<len> bytes long.
6540
6541 =cut
6542 */
6543
6544 SV *
6545 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6546 {
6547     register SV *sv;
6548
6549     new_SV(sv);
6550     sv_setpvn(sv,s,len);
6551     return sv;
6552 }
6553
6554 /*
6555 =for apidoc newSVpvn_share
6556
6557 Creates a new SV with its SvPVX pointing to a shared string in the string
6558 table. If the string does not already exist in the table, it is created
6559 first.  Turns on READONLY and FAKE.  The string's hash is stored in the UV
6560 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6561 otherwise the hash is computed.  The idea here is that as the string table
6562 is used for shared hash keys these strings will have SvPVX == HeKEY and
6563 hash lookup will avoid string compare.
6564
6565 =cut
6566 */
6567
6568 SV *
6569 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6570 {
6571     register SV *sv;
6572     bool is_utf8 = FALSE;
6573     if (len < 0) {
6574         STRLEN tmplen = -len;
6575         is_utf8 = TRUE;
6576         /* See the note in hv.c:hv_fetch() --jhi */
6577         src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6578         len = tmplen;
6579     }
6580     if (!hash)
6581         PERL_HASH(hash, src, len);
6582     new_SV(sv);
6583     sv_upgrade(sv, SVt_PVIV);
6584     SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6585     SvCUR(sv) = len;
6586     SvUVX(sv) = hash;
6587     SvLEN(sv) = 0;
6588     SvREADONLY_on(sv);
6589     SvFAKE_on(sv);
6590     SvPOK_on(sv);
6591     if (is_utf8)
6592         SvUTF8_on(sv);
6593     return sv;
6594 }
6595
6596
6597 #if defined(PERL_IMPLICIT_CONTEXT)
6598
6599 /* pTHX_ magic can't cope with varargs, so this is a no-context
6600  * version of the main function, (which may itself be aliased to us).
6601  * Don't access this version directly.
6602  */
6603
6604 SV *
6605 Perl_newSVpvf_nocontext(const char* pat, ...)
6606 {
6607     dTHX;
6608     register SV *sv;
6609     va_list args;
6610     va_start(args, pat);
6611     sv = vnewSVpvf(pat, &args);
6612     va_end(args);
6613     return sv;
6614 }
6615 #endif
6616
6617 /*
6618 =for apidoc newSVpvf
6619
6620 Creates a new SV and initializes it with the string formatted like
6621 C<sprintf>.
6622
6623 =cut
6624 */
6625
6626 SV *
6627 Perl_newSVpvf(pTHX_ const char* pat, ...)
6628 {
6629     register SV *sv;
6630     va_list args;
6631     va_start(args, pat);
6632     sv = vnewSVpvf(pat, &args);
6633     va_end(args);
6634     return sv;
6635 }
6636
6637 /* backend for newSVpvf() and newSVpvf_nocontext() */
6638
6639 SV *
6640 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6641 {
6642     register SV *sv;
6643     new_SV(sv);
6644     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6645     return sv;
6646 }
6647
6648 /*
6649 =for apidoc newSVnv
6650
6651 Creates a new SV and copies a floating point value into it.
6652 The reference count for the SV is set to 1.
6653
6654 =cut
6655 */
6656
6657 SV *
6658 Perl_newSVnv(pTHX_ NV n)
6659 {
6660     register SV *sv;
6661
6662     new_SV(sv);
6663     sv_setnv(sv,n);
6664     return sv;
6665 }
6666
6667 /*
6668 =for apidoc newSViv
6669
6670 Creates a new SV and copies an integer into it.  The reference count for the
6671 SV is set to 1.
6672
6673 =cut
6674 */
6675
6676 SV *
6677 Perl_newSViv(pTHX_ IV i)
6678 {
6679     register SV *sv;
6680
6681     new_SV(sv);
6682     sv_setiv(sv,i);
6683     return sv;
6684 }
6685
6686 /*
6687 =for apidoc newSVuv
6688
6689 Creates a new SV and copies an unsigned integer into it.
6690 The reference count for the SV is set to 1.
6691
6692 =cut
6693 */
6694
6695 SV *
6696 Perl_newSVuv(pTHX_ UV u)
6697 {
6698     register SV *sv;
6699
6700     new_SV(sv);
6701     sv_setuv(sv,u);
6702     return sv;
6703 }
6704
6705 /*
6706 =for apidoc newRV_noinc
6707
6708 Creates an RV wrapper for an SV.  The reference count for the original
6709 SV is B<not> incremented.
6710
6711 =cut
6712 */
6713
6714 SV *
6715 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6716 {
6717     register SV *sv;
6718
6719     new_SV(sv);
6720     sv_upgrade(sv, SVt_RV);
6721     SvTEMP_off(tmpRef);
6722     SvRV(sv) = tmpRef;
6723     SvROK_on(sv);
6724     return sv;
6725 }
6726
6727 /* newRV_inc is the official function name to use now.
6728  * newRV_inc is in fact #defined to newRV in sv.h
6729  */
6730
6731 SV *
6732 Perl_newRV(pTHX_ SV *tmpRef)
6733 {
6734     return newRV_noinc(SvREFCNT_inc(tmpRef));
6735 }
6736
6737 /*
6738 =for apidoc newSVsv
6739
6740 Creates a new SV which is an exact duplicate of the original SV.
6741 (Uses C<sv_setsv>).
6742
6743 =cut
6744 */
6745
6746 SV *
6747 Perl_newSVsv(pTHX_ register SV *old)
6748 {
6749     register SV *sv;
6750
6751     if (!old)
6752         return Nullsv;
6753     if (SvTYPE(old) == SVTYPEMASK) {
6754         if (ckWARN_d(WARN_INTERNAL))
6755             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
6756         return Nullsv;
6757     }
6758     new_SV(sv);
6759     if (SvTEMP(old)) {
6760         SvTEMP_off(old);
6761         sv_setsv(sv,old);
6762         SvTEMP_on(old);
6763     }
6764     else
6765         sv_setsv(sv,old);
6766     return sv;
6767 }
6768
6769 /*
6770 =for apidoc sv_reset
6771
6772 Underlying implementation for the C<reset> Perl function.
6773 Note that the perl-level function is vaguely deprecated.
6774
6775 =cut
6776 */
6777
6778 void
6779 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6780 {
6781     register HE *entry;
6782     register GV *gv;
6783     register SV *sv;
6784     register I32 i;
6785     register PMOP *pm;
6786     register I32 max;
6787     char todo[PERL_UCHAR_MAX+1];
6788
6789     if (!stash)
6790         return;
6791
6792     if (!*s) {          /* reset ?? searches */
6793         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6794             pm->op_pmdynflags &= ~PMdf_USED;
6795         }
6796         return;
6797     }
6798
6799     /* reset variables */
6800
6801     if (!HvARRAY(stash))
6802         return;
6803
6804     Zero(todo, 256, char);
6805     while (*s) {
6806         i = (unsigned char)*s;
6807         if (s[1] == '-') {
6808             s += 2;
6809         }
6810         max = (unsigned char)*s++;
6811         for ( ; i <= max; i++) {
6812             todo[i] = 1;
6813         }
6814         for (i = 0; i <= (I32) HvMAX(stash); i++) {
6815             for (entry = HvARRAY(stash)[i];
6816                  entry;
6817                  entry = HeNEXT(entry))
6818             {
6819                 if (!todo[(U8)*HeKEY(entry)])
6820                     continue;
6821                 gv = (GV*)HeVAL(entry);
6822                 sv = GvSV(gv);
6823                 if (SvTHINKFIRST(sv)) {
6824                     if (!SvREADONLY(sv) && SvROK(sv))
6825                         sv_unref(sv);
6826                     continue;
6827                 }
6828                 (void)SvOK_off(sv);
6829                 if (SvTYPE(sv) >= SVt_PV) {
6830                     SvCUR_set(sv, 0);
6831                     if (SvPVX(sv) != Nullch)
6832                         *SvPVX(sv) = '\0';
6833                     SvTAINT(sv);
6834                 }
6835                 if (GvAV(gv)) {
6836                     av_clear(GvAV(gv));
6837                 }
6838                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6839                     hv_clear(GvHV(gv));
6840 #ifdef USE_ENVIRON_ARRAY
6841                     if (gv == PL_envgv
6842 #  ifdef USE_ITHREADS
6843                         && PL_curinterp == aTHX
6844 #  endif
6845                     )
6846                     {
6847                         environ[0] = Nullch;
6848                     }
6849 #endif
6850                 }
6851             }
6852         }
6853     }
6854 }
6855
6856 /*
6857 =for apidoc sv_2io
6858
6859 Using various gambits, try to get an IO from an SV: the IO slot if its a
6860 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6861 named after the PV if we're a string.
6862
6863 =cut
6864 */
6865
6866 IO*
6867 Perl_sv_2io(pTHX_ SV *sv)
6868 {
6869     IO* io;
6870     GV* gv;
6871     STRLEN n_a;
6872
6873     switch (SvTYPE(sv)) {
6874     case SVt_PVIO:
6875         io = (IO*)sv;
6876         break;
6877     case SVt_PVGV:
6878         gv = (GV*)sv;
6879         io = GvIO(gv);
6880         if (!io)
6881             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6882         break;
6883     default:
6884         if (!SvOK(sv))
6885             Perl_croak(aTHX_ PL_no_usym, "filehandle");
6886         if (SvROK(sv))
6887             return sv_2io(SvRV(sv));
6888         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6889         if (gv)
6890             io = GvIO(gv);
6891         else
6892             io = 0;
6893         if (!io)
6894             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6895         break;
6896     }
6897     return io;
6898 }
6899
6900 /*
6901 =for apidoc sv_2cv
6902
6903 Using various gambits, try to get a CV from an SV; in addition, try if
6904 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6905
6906 =cut
6907 */
6908
6909 CV *
6910 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6911 {
6912     GV *gv = Nullgv;
6913     CV *cv = Nullcv;
6914     STRLEN n_a;
6915
6916     if (!sv)
6917         return *gvp = Nullgv, Nullcv;
6918     switch (SvTYPE(sv)) {
6919     case SVt_PVCV:
6920         *st = CvSTASH(sv);
6921         *gvp = Nullgv;
6922         return (CV*)sv;
6923     case SVt_PVHV:
6924     case SVt_PVAV:
6925         *gvp = Nullgv;
6926         return Nullcv;
6927     case SVt_PVGV:
6928         gv = (GV*)sv;
6929         *gvp = gv;
6930         *st = GvESTASH(gv);
6931         goto fix_gv;
6932
6933     default:
6934         if (SvGMAGICAL(sv))
6935             mg_get(sv);
6936         if (SvROK(sv)) {
6937             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
6938             tryAMAGICunDEREF(to_cv);
6939
6940             sv = SvRV(sv);
6941             if (SvTYPE(sv) == SVt_PVCV) {
6942                 cv = (CV*)sv;
6943                 *gvp = Nullgv;
6944                 *st = CvSTASH(cv);
6945                 return cv;
6946             }
6947             else if(isGV(sv))
6948                 gv = (GV*)sv;
6949             else
6950                 Perl_croak(aTHX_ "Not a subroutine reference");
6951         }
6952         else if (isGV(sv))
6953             gv = (GV*)sv;
6954         else
6955             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6956         *gvp = gv;
6957         if (!gv)
6958             return Nullcv;
6959         *st = GvESTASH(gv);
6960     fix_gv:
6961         if (lref && !GvCVu(gv)) {
6962             SV *tmpsv;
6963             ENTER;
6964             tmpsv = NEWSV(704,0);
6965             gv_efullname3(tmpsv, gv, Nullch);
6966             /* XXX this is probably not what they think they're getting.
6967              * It has the same effect as "sub name;", i.e. just a forward
6968              * declaration! */
6969             newSUB(start_subparse(FALSE, 0),
6970                    newSVOP(OP_CONST, 0, tmpsv),
6971                    Nullop,
6972                    Nullop);
6973             LEAVE;
6974             if (!GvCVu(gv))
6975                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6976         }
6977         return GvCVu(gv);
6978     }
6979 }
6980
6981 /*
6982 =for apidoc sv_true
6983
6984 Returns true if the SV has a true value by Perl's rules.
6985 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6986 instead use an in-line version.
6987
6988 =cut
6989 */
6990
6991 I32
6992 Perl_sv_true(pTHX_ register SV *sv)
6993 {
6994     if (!sv)
6995         return 0;
6996     if (SvPOK(sv)) {
6997         register XPV* tXpv;
6998         if ((tXpv = (XPV*)SvANY(sv)) &&
6999                 (tXpv->xpv_cur > 1 ||
7000                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
7001             return 1;
7002         else
7003             return 0;
7004     }
7005     else {
7006         if (SvIOK(sv))
7007             return SvIVX(sv) != 0;
7008         else {
7009             if (SvNOK(sv))
7010                 return SvNVX(sv) != 0.0;
7011             else
7012                 return sv_2bool(sv);
7013         }
7014     }
7015 }
7016
7017 /*
7018 =for apidoc sv_iv
7019
7020 A private implementation of the C<SvIVx> macro for compilers which can't
7021 cope with complex macro expressions. Always use the macro instead.
7022
7023 =cut
7024 */
7025
7026 IV
7027 Perl_sv_iv(pTHX_ register SV *sv)
7028 {
7029     if (SvIOK(sv)) {
7030         if (SvIsUV(sv))
7031             return (IV)SvUVX(sv);
7032         return SvIVX(sv);
7033     }
7034     return sv_2iv(sv);
7035 }
7036
7037 /*
7038 =for apidoc sv_uv
7039
7040 A private implementation of the C<SvUVx> macro for compilers which can't
7041 cope with complex macro expressions. Always use the macro instead.
7042
7043 =cut
7044 */
7045
7046 UV
7047 Perl_sv_uv(pTHX_ register SV *sv)
7048 {
7049     if (SvIOK(sv)) {
7050         if (SvIsUV(sv))
7051             return SvUVX(sv);
7052         return (UV)SvIVX(sv);
7053     }
7054     return sv_2uv(sv);
7055 }
7056
7057 /*
7058 =for apidoc sv_nv
7059
7060 A private implementation of the C<SvNVx> macro for compilers which can't
7061 cope with complex macro expressions. Always use the macro instead.
7062
7063 =cut
7064 */
7065
7066 NV
7067 Perl_sv_nv(pTHX_ register SV *sv)
7068 {
7069     if (SvNOK(sv))
7070         return SvNVX(sv);
7071     return sv_2nv(sv);
7072 }
7073
7074 /*
7075 =for apidoc sv_pv
7076
7077 Use the C<SvPV_nolen> macro instead
7078
7079 =for apidoc sv_pvn
7080
7081 A private implementation of the C<SvPV> macro for compilers which can't
7082 cope with complex macro expressions. Always use the macro instead.
7083
7084 =cut
7085 */
7086
7087 char *
7088 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7089 {
7090     if (SvPOK(sv)) {
7091         *lp = SvCUR(sv);
7092         return SvPVX(sv);
7093     }
7094     return sv_2pv(sv, lp);
7095 }
7096
7097
7098 char *
7099 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7100 {
7101     if (SvPOK(sv)) {
7102         *lp = SvCUR(sv);
7103         return SvPVX(sv);
7104     }
7105     return sv_2pv_flags(sv, lp, 0);
7106 }
7107
7108 /*
7109 =for apidoc sv_pvn_force
7110
7111 Get a sensible string out of the SV somehow.
7112 A private implementation of the C<SvPV_force> macro for compilers which
7113 can't cope with complex macro expressions. Always use the macro instead.
7114
7115 =for apidoc sv_pvn_force_flags
7116
7117 Get a sensible string out of the SV somehow.
7118 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7119 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7120 implemented in terms of this function.
7121 You normally want to use the various wrapper macros instead: see
7122 C<SvPV_force> and C<SvPV_force_nomg>
7123
7124 =cut
7125 */
7126
7127 char *
7128 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7129 {
7130     char *s = NULL;
7131
7132     if (SvTHINKFIRST(sv) && !SvROK(sv))
7133         sv_force_normal_flags(sv, 0);
7134
7135     if (SvPOK(sv)) {
7136         *lp = SvCUR(sv);
7137     }
7138     else {
7139         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
7140             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7141                 OP_NAME(PL_op));
7142         }
7143         else
7144             s = sv_2pv_flags(sv, lp, flags);
7145         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
7146             STRLEN len = *lp;
7147
7148             if (SvROK(sv))
7149                 sv_unref(sv);
7150             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
7151             SvGROW(sv, len + 1);
7152             Move(s,SvPVX(sv),len,char);
7153             SvCUR_set(sv, len);
7154             *SvEND(sv) = '\0';
7155         }
7156         if (!SvPOK(sv)) {
7157             SvPOK_on(sv);               /* validate pointer */
7158             SvTAINT(sv);
7159             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7160                                   PTR2UV(sv),SvPVX(sv)));
7161         }
7162     }
7163     return SvPVX(sv);
7164 }
7165
7166 /*
7167 =for apidoc sv_pvbyte
7168
7169 Use C<SvPVbyte_nolen> instead.
7170
7171 =for apidoc sv_pvbyten
7172
7173 A private implementation of the C<SvPVbyte> macro for compilers
7174 which can't cope with complex macro expressions. Always use the macro
7175 instead.
7176
7177 =cut
7178 */
7179
7180 char *
7181 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7182 {
7183     sv_utf8_downgrade(sv,0);
7184     return sv_pvn(sv,lp);
7185 }
7186
7187 /*
7188 =for apidoc sv_pvbyten_force
7189
7190 A private implementation of the C<SvPVbytex_force> macro for compilers
7191 which can't cope with complex macro expressions. Always use the macro
7192 instead.
7193
7194 =cut
7195 */
7196
7197 char *
7198 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7199 {
7200     sv_utf8_downgrade(sv,0);
7201     return sv_pvn_force(sv,lp);
7202 }
7203
7204 /*
7205 =for apidoc sv_pvutf8
7206
7207 Use the C<SvPVutf8_nolen> macro instead
7208
7209 =for apidoc sv_pvutf8n
7210
7211 A private implementation of the C<SvPVutf8> macro for compilers
7212 which can't cope with complex macro expressions. Always use the macro
7213 instead.
7214
7215 =cut
7216 */
7217
7218 char *
7219 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
7220 {
7221     sv_utf8_upgrade(sv);
7222     return sv_pvn(sv,lp);
7223 }
7224
7225 /*
7226 =for apidoc sv_pvutf8n_force
7227
7228 A private implementation of the C<SvPVutf8_force> macro for compilers
7229 which can't cope with complex macro expressions. Always use the macro
7230 instead.
7231
7232 =cut
7233 */
7234
7235 char *
7236 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7237 {
7238     sv_utf8_upgrade(sv);
7239     return sv_pvn_force(sv,lp);
7240 }
7241
7242 /*
7243 =for apidoc sv_reftype
7244
7245 Returns a string describing what the SV is a reference to.
7246
7247 =cut
7248 */
7249
7250 char *
7251 Perl_sv_reftype(pTHX_ SV *sv, int ob)
7252 {
7253     if (ob && SvOBJECT(sv)) {
7254         return HvNAME(SvSTASH(sv));
7255     }
7256     else {
7257         switch (SvTYPE(sv)) {
7258         case SVt_NULL:
7259         case SVt_IV:
7260         case SVt_NV:
7261         case SVt_RV:
7262         case SVt_PV:
7263         case SVt_PVIV:
7264         case SVt_PVNV:
7265         case SVt_PVMG:
7266         case SVt_PVBM:
7267                                 if (SvVOK(sv))
7268                                     return "VSTRING";
7269                                 if (SvROK(sv))
7270                                     return "REF";
7271                                 else
7272                                     return "SCALAR";
7273         case SVt_PVLV:          return "LVALUE";
7274         case SVt_PVAV:          return "ARRAY";
7275         case SVt_PVHV:          return "HASH";
7276         case SVt_PVCV:          return "CODE";
7277         case SVt_PVGV:          return "GLOB";
7278         case SVt_PVFM:          return "FORMAT";
7279         case SVt_PVIO:          return "IO";
7280         default:                return "UNKNOWN";
7281         }
7282     }
7283 }
7284
7285 /*
7286 =for apidoc sv_isobject
7287
7288 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7289 object.  If the SV is not an RV, or if the object is not blessed, then this
7290 will return false.
7291
7292 =cut
7293 */
7294
7295 int
7296 Perl_sv_isobject(pTHX_ SV *sv)
7297 {
7298     if (!sv)
7299         return 0;
7300     if (SvGMAGICAL(sv))
7301         mg_get(sv);
7302     if (!SvROK(sv))
7303         return 0;
7304     sv = (SV*)SvRV(sv);
7305     if (!SvOBJECT(sv))
7306         return 0;
7307     return 1;
7308 }
7309
7310 /*
7311 =for apidoc sv_isa
7312
7313 Returns a boolean indicating whether the SV is blessed into the specified
7314 class.  This does not check for subtypes; use C<sv_derived_from> to verify
7315 an inheritance relationship.
7316
7317 =cut
7318 */
7319
7320 int
7321 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7322 {
7323     if (!sv)
7324         return 0;
7325     if (SvGMAGICAL(sv))
7326         mg_get(sv);
7327     if (!SvROK(sv))
7328         return 0;
7329     sv = (SV*)SvRV(sv);
7330     if (!SvOBJECT(sv))
7331         return 0;
7332
7333     return strEQ(HvNAME(SvSTASH(sv)), name);
7334 }
7335
7336 /*
7337 =for apidoc newSVrv
7338
7339 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
7340 it will be upgraded to one.  If C<classname> is non-null then the new SV will
7341 be blessed in the specified package.  The new SV is returned and its
7342 reference count is 1.
7343
7344 =cut
7345 */
7346
7347 SV*
7348 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7349 {
7350     SV *sv;
7351
7352     new_SV(sv);
7353
7354     SV_CHECK_THINKFIRST_COW_DROP(rv);
7355     SvAMAGIC_off(rv);
7356
7357     if (SvTYPE(rv) >= SVt_PVMG) {
7358         U32 refcnt = SvREFCNT(rv);
7359         SvREFCNT(rv) = 0;
7360         sv_clear(rv);
7361         SvFLAGS(rv) = 0;
7362         SvREFCNT(rv) = refcnt;
7363     }
7364
7365     if (SvTYPE(rv) < SVt_RV)
7366         sv_upgrade(rv, SVt_RV);
7367     else if (SvTYPE(rv) > SVt_RV) {
7368         (void)SvOOK_off(rv);
7369         if (SvPVX(rv) && SvLEN(rv))
7370             Safefree(SvPVX(rv));
7371         SvCUR_set(rv, 0);
7372         SvLEN_set(rv, 0);
7373     }
7374
7375     (void)SvOK_off(rv);
7376     SvRV(rv) = sv;
7377     SvROK_on(rv);
7378
7379     if (classname) {
7380         HV* stash = gv_stashpv(classname, TRUE);
7381         (void)sv_bless(rv, stash);
7382     }
7383     return sv;
7384 }
7385
7386 /*
7387 =for apidoc sv_setref_pv
7388
7389 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
7390 argument will be upgraded to an RV.  That RV will be modified to point to
7391 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7392 into the SV.  The C<classname> argument indicates the package for the
7393 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7394 will be returned and will have a reference count of 1.
7395
7396 Do not use with other Perl types such as HV, AV, SV, CV, because those
7397 objects will become corrupted by the pointer copy process.
7398
7399 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7400
7401 =cut
7402 */
7403
7404 SV*
7405 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7406 {
7407     if (!pv) {
7408         sv_setsv(rv, &PL_sv_undef);
7409         SvSETMAGIC(rv);
7410     }
7411     else
7412         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7413     return rv;
7414 }
7415
7416 /*
7417 =for apidoc sv_setref_iv
7418
7419 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
7420 argument will be upgraded to an RV.  That RV will be modified to point to
7421 the new SV.  The C<classname> argument indicates the package for the
7422 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7423 will be returned and will have a reference count of 1.
7424
7425 =cut
7426 */
7427
7428 SV*
7429 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7430 {
7431     sv_setiv(newSVrv(rv,classname), iv);
7432     return rv;
7433 }
7434
7435 /*
7436 =for apidoc sv_setref_uv
7437
7438 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
7439 argument will be upgraded to an RV.  That RV will be modified to point to
7440 the new SV.  The C<classname> argument indicates the package for the
7441 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7442 will be returned and will have a reference count of 1.
7443
7444 =cut
7445 */
7446
7447 SV*
7448 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7449 {
7450     sv_setuv(newSVrv(rv,classname), uv);
7451     return rv;
7452 }
7453
7454 /*
7455 =for apidoc sv_setref_nv
7456
7457 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
7458 argument will be upgraded to an RV.  That RV will be modified to point to
7459 the new SV.  The C<classname> argument indicates the package for the
7460 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7461 will be returned and will have a reference count of 1.
7462
7463 =cut
7464 */
7465
7466 SV*
7467 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7468 {
7469     sv_setnv(newSVrv(rv,classname), nv);
7470     return rv;
7471 }
7472
7473 /*
7474 =for apidoc sv_setref_pvn
7475
7476 Copies a string into a new SV, optionally blessing the SV.  The length of the
7477 string must be specified with C<n>.  The C<rv> argument will be upgraded to
7478 an RV.  That RV will be modified to point to the new SV.  The C<classname>
7479 argument indicates the package for the blessing.  Set C<classname> to
7480 C<Nullch> to avoid the blessing.  The new SV will be returned and will have
7481 a reference count of 1.
7482
7483 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7484
7485 =cut
7486 */
7487
7488 SV*
7489 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7490 {
7491     sv_setpvn(newSVrv(rv,classname), pv, n);
7492     return rv;
7493 }
7494
7495 /*
7496 =for apidoc sv_bless
7497
7498 Blesses an SV into a specified package.  The SV must be an RV.  The package
7499 must be designated by its stash (see C<gv_stashpv()>).  The reference count
7500 of the SV is unaffected.
7501
7502 =cut
7503 */
7504
7505 SV*
7506 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7507 {
7508     SV *tmpRef;
7509     if (!SvROK(sv))
7510         Perl_croak(aTHX_ "Can't bless non-reference value");
7511     tmpRef = SvRV(sv);
7512     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7513         if (SvREADONLY(tmpRef))
7514             Perl_croak(aTHX_ PL_no_modify);
7515         if (SvOBJECT(tmpRef)) {
7516             if (SvTYPE(tmpRef) != SVt_PVIO)
7517                 --PL_sv_objcount;
7518             SvREFCNT_dec(SvSTASH(tmpRef));
7519         }
7520     }
7521     SvOBJECT_on(tmpRef);
7522     if (SvTYPE(tmpRef) != SVt_PVIO)
7523         ++PL_sv_objcount;
7524     (void)SvUPGRADE(tmpRef, SVt_PVMG);
7525     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7526
7527     if (Gv_AMG(stash))
7528         SvAMAGIC_on(sv);
7529     else
7530         SvAMAGIC_off(sv);
7531
7532     if(SvSMAGICAL(tmpRef))
7533         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7534             mg_set(tmpRef);
7535
7536
7537
7538     return sv;
7539 }
7540
7541 /* Downgrades a PVGV to a PVMG.
7542  */
7543
7544 STATIC void
7545 S_sv_unglob(pTHX_ SV *sv)
7546 {
7547     void *xpvmg;
7548
7549     assert(SvTYPE(sv) == SVt_PVGV);
7550     SvFAKE_off(sv);
7551     if (GvGP(sv))
7552         gp_free((GV*)sv);
7553     if (GvSTASH(sv)) {
7554         SvREFCNT_dec(GvSTASH(sv));
7555         GvSTASH(sv) = Nullhv;
7556     }
7557     sv_unmagic(sv, PERL_MAGIC_glob);
7558     Safefree(GvNAME(sv));
7559     GvMULTI_off(sv);
7560
7561     /* need to keep SvANY(sv) in the right arena */
7562     xpvmg = new_XPVMG();
7563     StructCopy(SvANY(sv), xpvmg, XPVMG);
7564     del_XPVGV(SvANY(sv));
7565     SvANY(sv) = xpvmg;
7566
7567     SvFLAGS(sv) &= ~SVTYPEMASK;
7568     SvFLAGS(sv) |= SVt_PVMG;
7569 }
7570
7571 /*
7572 =for apidoc sv_unref_flags
7573
7574 Unsets the RV status of the SV, and decrements the reference count of
7575 whatever was being referenced by the RV.  This can almost be thought of
7576 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
7577 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7578 (otherwise the decrementing is conditional on the reference count being
7579 different from one or the reference being a readonly SV).
7580 See C<SvROK_off>.
7581
7582 =cut
7583 */
7584
7585 void
7586 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7587 {
7588     SV* rv = SvRV(sv);
7589
7590     if (SvWEAKREF(sv)) {
7591         sv_del_backref(sv);
7592         SvWEAKREF_off(sv);
7593         SvRV(sv) = 0;
7594         return;
7595     }
7596     SvRV(sv) = 0;
7597     SvROK_off(sv);
7598     if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || (flags & SV_IMMEDIATE_UNREF))
7599         SvREFCNT_dec(rv);
7600     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7601         sv_2mortal(rv);         /* Schedule for freeing later */
7602 }
7603
7604 /*
7605 =for apidoc sv_unref
7606
7607 Unsets the RV status of the SV, and decrements the reference count of
7608 whatever was being referenced by the RV.  This can almost be thought of
7609 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
7610 being zero.  See C<SvROK_off>.
7611
7612 =cut
7613 */
7614
7615 void
7616 Perl_sv_unref(pTHX_ SV *sv)
7617 {
7618     sv_unref_flags(sv, 0);
7619 }
7620
7621 /*
7622 =for apidoc sv_taint
7623
7624 Taint an SV. Use C<SvTAINTED_on> instead.
7625 =cut
7626 */
7627
7628 void
7629 Perl_sv_taint(pTHX_ SV *sv)
7630 {
7631     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7632 }
7633
7634 /*
7635 =for apidoc sv_untaint
7636
7637 Untaint an SV. Use C<SvTAINTED_off> instead.
7638 =cut
7639 */
7640
7641 void
7642 Perl_sv_untaint(pTHX_ SV *sv)
7643 {
7644     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7645         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7646         if (mg)
7647             mg->mg_len &= ~1;
7648     }
7649 }
7650
7651 /*
7652 =for apidoc sv_tainted
7653
7654 Test an SV for taintedness. Use C<SvTAINTED> instead.
7655 =cut
7656 */
7657
7658 bool
7659 Perl_sv_tainted(pTHX_ SV *sv)
7660 {
7661     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7662         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7663         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7664             return TRUE;
7665     }
7666     return FALSE;
7667 }
7668
7669 #if defined(PERL_IMPLICIT_CONTEXT)
7670
7671 /* pTHX_ magic can't cope with varargs, so this is a no-context
7672  * version of the main function, (which may itself be aliased to us).
7673  * Don't access this version directly.
7674  */
7675
7676 void
7677 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7678 {
7679     dTHX;
7680     va_list args;
7681     va_start(args, pat);
7682     sv_vsetpvf(sv, pat, &args);
7683     va_end(args);
7684 }
7685
7686 /* pTHX_ magic can't cope with varargs, so this is a no-context
7687  * version of the main function, (which may itself be aliased to us).
7688  * Don't access this version directly.
7689  */
7690
7691 void
7692 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7693 {
7694     dTHX;
7695     va_list args;
7696     va_start(args, pat);
7697     sv_vsetpvf_mg(sv, pat, &args);
7698     va_end(args);
7699 }
7700 #endif
7701
7702 /*
7703 =for apidoc sv_setpvf
7704
7705 Processes its arguments like C<sprintf> and sets an SV to the formatted
7706 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
7707
7708 =cut
7709 */
7710
7711 void
7712 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7713 {
7714     va_list args;
7715     va_start(args, pat);
7716     sv_vsetpvf(sv, pat, &args);
7717     va_end(args);
7718 }
7719
7720 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7721
7722 void
7723 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7724 {
7725     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7726 }
7727
7728 /*
7729 =for apidoc sv_setpvf_mg
7730
7731 Like C<sv_setpvf>, but also handles 'set' magic.
7732
7733 =cut
7734 */
7735
7736 void
7737 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7738 {
7739     va_list args;
7740     va_start(args, pat);
7741     sv_vsetpvf_mg(sv, pat, &args);
7742     va_end(args);
7743 }
7744
7745 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7746
7747 void
7748 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7749 {
7750     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7751     SvSETMAGIC(sv);
7752 }
7753
7754 #if defined(PERL_IMPLICIT_CONTEXT)
7755
7756 /* pTHX_ magic can't cope with varargs, so this is a no-context
7757  * version of the main function, (which may itself be aliased to us).
7758  * Don't access this version directly.
7759  */
7760
7761 void
7762 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7763 {
7764     dTHX;
7765     va_list args;
7766     va_start(args, pat);
7767     sv_vcatpvf(sv, pat, &args);
7768     va_end(args);
7769 }
7770
7771 /* pTHX_ magic can't cope with varargs, so this is a no-context
7772  * version of the main function, (which may itself be aliased to us).
7773  * Don't access this version directly.
7774  */
7775
7776 void
7777 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7778 {
7779     dTHX;
7780     va_list args;
7781     va_start(args, pat);
7782     sv_vcatpvf_mg(sv, pat, &args);
7783     va_end(args);
7784 }
7785 #endif
7786
7787 /*
7788 =for apidoc sv_catpvf
7789
7790 Processes its arguments like C<sprintf> and appends the formatted
7791 output to an SV.  If the appended data contains "wide" characters
7792 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7793 and characters >255 formatted with %c), the original SV might get
7794 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.
7795 C<SvSETMAGIC()> must typically be called after calling this function
7796 to handle 'set' magic.
7797
7798 =cut */
7799
7800 void
7801 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7802 {
7803     va_list args;
7804     va_start(args, pat);
7805     sv_vcatpvf(sv, pat, &args);
7806     va_end(args);
7807 }
7808
7809 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7810
7811 void
7812 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7813 {
7814     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7815 }
7816
7817 /*
7818 =for apidoc sv_catpvf_mg
7819
7820 Like C<sv_catpvf>, but also handles 'set' magic.
7821
7822 =cut
7823 */
7824
7825 void
7826 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7827 {
7828     va_list args;
7829     va_start(args, pat);
7830     sv_vcatpvf_mg(sv, pat, &args);
7831     va_end(args);
7832 }
7833
7834 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7835
7836 void
7837 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7838 {
7839     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7840     SvSETMAGIC(sv);
7841 }
7842
7843 /*
7844 =for apidoc sv_vsetpvfn
7845
7846 Works like C<vcatpvfn> but copies the text into the SV instead of
7847 appending it.
7848
7849 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7850
7851 =cut
7852 */
7853
7854 void
7855 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7856 {
7857     sv_setpvn(sv, "", 0);
7858     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7859 }
7860
7861 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7862
7863 STATIC I32
7864 S_expect_number(pTHX_ char** pattern)
7865 {
7866     I32 var = 0;
7867     switch (**pattern) {
7868     case '1': case '2': case '3':
7869     case '4': case '5': case '6':
7870     case '7': case '8': case '9':
7871         while (isDIGIT(**pattern))
7872             var = var * 10 + (*(*pattern)++ - '0');
7873     }
7874     return var;
7875 }
7876 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7877
7878 /*
7879 =for apidoc sv_vcatpvfn
7880
7881 Processes its arguments like C<vsprintf> and appends the formatted output
7882 to an SV.  Uses an array of SVs if the C style variable argument list is
7883 missing (NULL).  When running with taint checks enabled, indicates via
7884 C<maybe_tainted> if results are untrustworthy (often due to the use of
7885 locales).
7886
7887 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7888
7889 =cut
7890 */
7891
7892 void
7893 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7894 {
7895     char *p;
7896     char *q;
7897     char *patend;
7898     STRLEN origlen;
7899     I32 svix = 0;
7900     static char nullstr[] = "(null)";
7901     SV *argsv = Nullsv;
7902     bool has_utf8 = FALSE; /* has the result utf8? */
7903
7904     /* no matter what, this is a string now */
7905     (void)SvPV_force(sv, origlen);
7906
7907     /* special-case "", "%s", and "%_" */
7908     if (patlen == 0)
7909         return;
7910     if (patlen == 2 && pat[0] == '%') {
7911         switch (pat[1]) {
7912         case 's':
7913             if (args) {
7914                 char *s = va_arg(*args, char*);
7915                 sv_catpv(sv, s ? s : nullstr);
7916             }
7917             else if (svix < svmax) {
7918                 sv_catsv(sv, *svargs);
7919                 if (DO_UTF8(*svargs))
7920                     SvUTF8_on(sv);
7921             }
7922             return;
7923         case '_':
7924             if (args) {
7925                 argsv = va_arg(*args, SV*);
7926                 sv_catsv(sv, argsv);
7927                 if (DO_UTF8(argsv))
7928                     SvUTF8_on(sv);
7929                 return;
7930             }
7931             /* See comment on '_' below */
7932             break;
7933         }
7934     }
7935
7936     if (!args && svix < svmax && DO_UTF8(*svargs))
7937         has_utf8 = TRUE;
7938
7939     patend = (char*)pat + patlen;
7940     for (p = (char*)pat; p < patend; p = q) {
7941         bool alt = FALSE;
7942         bool left = FALSE;
7943         bool vectorize = FALSE;
7944         bool vectorarg = FALSE;
7945         bool vec_utf8 = FALSE;
7946         char fill = ' ';
7947         char plus = 0;
7948         char intsize = 0;
7949         STRLEN width = 0;
7950         STRLEN zeros = 0;
7951         bool has_precis = FALSE;
7952         STRLEN precis = 0;
7953         bool is_utf8 = FALSE;  /* is this item utf8?   */
7954 #ifdef HAS_LDBL_SPRINTF_BUG
7955         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
7956            with sfio - Allen <allens@cpan.org> */
7957         bool fix_ldbl_sprintf_bug = FALSE;
7958 #endif
7959
7960         char esignbuf[4];
7961         U8 utf8buf[UTF8_MAXLEN+1];
7962         STRLEN esignlen = 0;
7963
7964         char *eptr = Nullch;
7965         STRLEN elen = 0;
7966         /* Times 4: a decimal digit takes more than 3 binary digits.
7967          * NV_DIG: mantissa takes than many decimal digits.
7968          * Plus 32: Playing safe. */
7969         char ebuf[IV_DIG * 4 + NV_DIG + 32];
7970         /* large enough for "%#.#f" --chip */
7971         /* what about long double NVs? --jhi */
7972
7973         SV *vecsv = Nullsv;
7974         U8 *vecstr = Null(U8*);
7975         STRLEN veclen = 0;
7976         char c = 0;
7977         int i;
7978         unsigned base = 0;
7979         IV iv = 0;
7980         UV uv = 0;
7981         /* we need a long double target in case HAS_LONG_DOUBLE but
7982            not USE_LONG_DOUBLE
7983         */
7984 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
7985         long double nv;
7986 #else
7987         NV nv;
7988 #endif
7989         STRLEN have;
7990         STRLEN need;
7991         STRLEN gap;
7992         char *dotstr = ".";
7993         STRLEN dotstrlen = 1;
7994         I32 efix = 0; /* explicit format parameter index */
7995         I32 ewix = 0; /* explicit width index */
7996         I32 epix = 0; /* explicit precision index */
7997         I32 evix = 0; /* explicit vector index */
7998         bool asterisk = FALSE;
7999
8000         /* echo everything up to the next format specification */
8001         for (q = p; q < patend && *q != '%'; ++q) ;
8002         if (q > p) {
8003             sv_catpvn(sv, p, q - p);
8004             p = q;
8005         }
8006         if (q++ >= patend)
8007             break;
8008
8009 /*
8010     We allow format specification elements in this order:
8011         \d+\$              explicit format parameter index
8012         [-+ 0#]+           flags
8013         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
8014         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
8015         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8016         [hlqLV]            size
8017     [%bcdefginopsux_DFOUX] format (mandatory)
8018 */
8019         if (EXPECT_NUMBER(q, width)) {
8020             if (*q == '$') {
8021                 ++q;
8022                 efix = width;
8023             } else {
8024                 goto gotwidth;
8025             }
8026         }
8027
8028         /* FLAGS */
8029
8030         while (*q) {
8031             switch (*q) {
8032             case ' ':
8033             case '+':
8034                 plus = *q++;
8035                 continue;
8036
8037             case '-':
8038                 left = TRUE;
8039                 q++;
8040                 continue;
8041
8042             case '0':
8043                 fill = *q++;
8044                 continue;
8045
8046             case '#':
8047                 alt = TRUE;
8048                 q++;
8049                 continue;
8050
8051             default:
8052                 break;
8053             }
8054             break;
8055         }
8056
8057       tryasterisk:
8058         if (*q == '*') {
8059             q++;
8060             if (EXPECT_NUMBER(q, ewix))
8061                 if (*q++ != '$')
8062                     goto unknown;
8063             asterisk = TRUE;
8064         }
8065         if (*q == 'v') {
8066             q++;
8067             if (vectorize)
8068                 goto unknown;
8069             if ((vectorarg = asterisk)) {
8070                 evix = ewix;
8071                 ewix = 0;
8072                 asterisk = FALSE;
8073             }
8074             vectorize = TRUE;
8075             goto tryasterisk;
8076         }
8077
8078         if (!asterisk)
8079             EXPECT_NUMBER(q, width);
8080
8081         if (vectorize) {
8082             if (vectorarg) {
8083                 if (args)
8084                     vecsv = va_arg(*args, SV*);
8085                 else
8086                     vecsv = (evix ? evix <= svmax : svix < svmax) ?
8087                         svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
8088                 dotstr = SvPVx(vecsv, dotstrlen);
8089                 if (DO_UTF8(vecsv))
8090                     is_utf8 = TRUE;
8091             }
8092             if (args) {
8093                 vecsv = va_arg(*args, SV*);
8094                 vecstr = (U8*)SvPVx(vecsv,veclen);
8095                 vec_utf8 = DO_UTF8(vecsv);
8096             }
8097             else if (efix ? efix <= svmax : svix < svmax) {
8098                 vecsv = svargs[efix ? efix-1 : svix++];
8099                 vecstr = (U8*)SvPVx(vecsv,veclen);
8100                 vec_utf8 = DO_UTF8(vecsv);
8101             }
8102             else {
8103                 vecstr = (U8*)"";
8104                 veclen = 0;
8105             }
8106         }
8107
8108         if (asterisk) {
8109             if (args)
8110                 i = va_arg(*args, int);
8111             else
8112                 i = (ewix ? ewix <= svmax : svix < svmax) ?
8113                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8114             left |= (i < 0);
8115             width = (i < 0) ? -i : i;
8116         }
8117       gotwidth:
8118
8119         /* PRECISION */
8120
8121         if (*q == '.') {
8122             q++;
8123             if (*q == '*') {
8124                 q++;
8125                 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8126                     goto unknown;
8127                 /* XXX: todo, support specified precision parameter */
8128                 if (epix)
8129                     goto unknown;
8130                 if (args)
8131                     i = va_arg(*args, int);
8132                 else
8133                     i = (ewix ? ewix <= svmax : svix < svmax)
8134                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8135                 precis = (i < 0) ? 0 : i;
8136             }
8137             else {
8138                 precis = 0;
8139                 while (isDIGIT(*q))
8140                     precis = precis * 10 + (*q++ - '0');
8141             }
8142             has_precis = TRUE;
8143         }
8144
8145         /* SIZE */
8146
8147         switch (*q) {
8148 #ifdef WIN32
8149         case 'I':                       /* Ix, I32x, and I64x */
8150 #  ifdef WIN64
8151             if (q[1] == '6' && q[2] == '4') {
8152                 q += 3;
8153                 intsize = 'q';
8154                 break;
8155             }
8156 #  endif
8157             if (q[1] == '3' && q[2] == '2') {
8158                 q += 3;
8159                 break;
8160             }
8161 #  ifdef WIN64
8162             intsize = 'q';
8163 #  endif
8164             q++;
8165             break;
8166 #endif
8167 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8168         case 'L':                       /* Ld */
8169             /* FALL THROUGH */
8170 #ifdef HAS_QUAD
8171         case 'q':                       /* qd */
8172 #endif
8173             intsize = 'q';
8174             q++;
8175             break;
8176 #endif
8177         case 'l':
8178 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8179             if (*(q + 1) == 'l') {      /* lld, llf */
8180                 intsize = 'q';
8181                 q += 2;
8182                 break;
8183              }
8184 #endif
8185             /* FALL THROUGH */
8186         case 'h':
8187             /* FALL THROUGH */
8188         case 'V':
8189             intsize = *q++;
8190             break;
8191         }
8192
8193         /* CONVERSION */
8194
8195         if (*q == '%') {
8196             eptr = q++;
8197             elen = 1;
8198             goto string;
8199         }
8200
8201         if (vectorize)
8202             argsv = vecsv;
8203         else if (!args)
8204             argsv = (efix ? efix <= svmax : svix < svmax) ?
8205                     svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8206
8207         switch (c = *q++) {
8208
8209             /* STRINGS */
8210
8211         case 'c':
8212             uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8213             if ((uv > 255 ||
8214                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8215                 && !IN_BYTES) {
8216                 eptr = (char*)utf8buf;
8217                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8218                 is_utf8 = TRUE;
8219             }
8220             else {
8221                 c = (char)uv;
8222                 eptr = &c;
8223                 elen = 1;
8224             }
8225             goto string;
8226
8227         case 's':
8228             if (args && !vectorize) {
8229                 eptr = va_arg(*args, char*);
8230                 if (eptr)
8231 #ifdef MACOS_TRADITIONAL
8232                   /* On MacOS, %#s format is used for Pascal strings */
8233                   if (alt)
8234                     elen = *eptr++;
8235                   else
8236 #endif
8237                     elen = strlen(eptr);
8238                 else {
8239                     eptr = nullstr;
8240                     elen = sizeof nullstr - 1;
8241                 }
8242             }
8243             else {
8244                 eptr = SvPVx(argsv, elen);
8245                 if (DO_UTF8(argsv)) {
8246                     if (has_precis && precis < elen) {
8247                         I32 p = precis;
8248                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8249                         precis = p;
8250                     }
8251                     if (width) { /* fudge width (can't fudge elen) */
8252                         width += elen - sv_len_utf8(argsv);
8253                     }
8254                     is_utf8 = TRUE;
8255                 }
8256             }
8257             goto string;
8258
8259         case '_':
8260             /*
8261              * The "%_" hack might have to be changed someday,
8262              * if ISO or ANSI decide to use '_' for something.
8263              * So we keep it hidden from users' code.
8264              */
8265             if (!args || vectorize)
8266                 goto unknown;
8267             argsv = va_arg(*args, SV*);
8268             eptr = SvPVx(argsv, elen);
8269             if (DO_UTF8(argsv))
8270                 is_utf8 = TRUE;
8271
8272         string:
8273             vectorize = FALSE;
8274             if (has_precis && elen > precis)
8275                 elen = precis;
8276             break;
8277
8278             /* INTEGERS */
8279
8280         case 'p':
8281             if (alt || vectorize)
8282                 goto unknown;
8283             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8284             base = 16;
8285             goto integer;
8286
8287         case 'D':
8288 #ifdef IV_IS_QUAD
8289             intsize = 'q';
8290 #else
8291             intsize = 'l';
8292 #endif
8293             /* FALL THROUGH */
8294         case 'd':
8295         case 'i':
8296             if (vectorize) {
8297                 STRLEN ulen;
8298                 if (!veclen)
8299                     continue;
8300                 if (vec_utf8)
8301                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8302                                         UTF8_ALLOW_ANYUV);
8303                 else {
8304                     uv = *vecstr;
8305                     ulen = 1;
8306                 }
8307                 vecstr += ulen;
8308                 veclen -= ulen;
8309                 if (plus)
8310                      esignbuf[esignlen++] = plus;
8311             }
8312             else if (args) {
8313                 switch (intsize) {
8314                 case 'h':       iv = (short)va_arg(*args, int); break;
8315                 default:        iv = va_arg(*args, int); break;
8316                 case 'l':       iv = va_arg(*args, long); break;
8317                 case 'V':       iv = va_arg(*args, IV); break;
8318 #ifdef HAS_QUAD
8319                 case 'q':       iv = va_arg(*args, Quad_t); break;
8320 #endif
8321                 }
8322             }
8323             else {
8324                 iv = SvIVx(argsv);
8325                 switch (intsize) {
8326                 case 'h':       iv = (short)iv; break;
8327                 default:        break;
8328                 case 'l':       iv = (long)iv; break;
8329                 case 'V':       break;
8330 #ifdef HAS_QUAD
8331                 case 'q':       iv = (Quad_t)iv; break;
8332 #endif
8333                 }
8334             }
8335             if ( !vectorize )   /* we already set uv above */
8336             {
8337                 if (iv >= 0) {
8338                     uv = iv;
8339                     if (plus)
8340                         esignbuf[esignlen++] = plus;
8341                 }
8342                 else {
8343                     uv = -iv;
8344                     esignbuf[esignlen++] = '-';
8345                 }
8346             }
8347             base = 10;
8348             goto integer;
8349
8350         case 'U':
8351 #ifdef IV_IS_QUAD
8352             intsize = 'q';
8353 #else
8354             intsize = 'l';
8355 #endif
8356             /* FALL THROUGH */
8357         case 'u':
8358             base = 10;
8359             goto uns_integer;
8360
8361         case 'b':
8362             base = 2;
8363             goto uns_integer;
8364
8365         case 'O':
8366 #ifdef IV_IS_QUAD
8367             intsize = 'q';
8368 #else
8369             intsize = 'l';
8370 #endif
8371             /* FALL THROUGH */
8372         case 'o':
8373             base = 8;
8374             goto uns_integer;
8375
8376         case 'X':
8377         case 'x':
8378             base = 16;
8379
8380         uns_integer:
8381             if (vectorize) {
8382                 STRLEN ulen;
8383         vector:
8384                 if (!veclen)
8385                     continue;
8386                 if (vec_utf8)
8387                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8388                                         UTF8_ALLOW_ANYUV);
8389                 else {
8390                     uv = *vecstr;
8391                     ulen = 1;
8392                 }
8393                 vecstr += ulen;
8394                 veclen -= ulen;
8395             }
8396             else if (args) {
8397                 switch (intsize) {
8398                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
8399                 default:   uv = va_arg(*args, unsigned); break;
8400                 case 'l':  uv = va_arg(*args, unsigned long); break;
8401                 case 'V':  uv = va_arg(*args, UV); break;
8402 #ifdef HAS_QUAD
8403                 case 'q':  uv = va_arg(*args, Quad_t); break;
8404 #endif
8405                 }
8406             }
8407             else {
8408                 uv = SvUVx(argsv);
8409                 switch (intsize) {
8410                 case 'h':       uv = (unsigned short)uv; break;
8411                 default:        break;
8412                 case 'l':       uv = (unsigned long)uv; break;
8413                 case 'V':       break;
8414 #ifdef HAS_QUAD
8415                 case 'q':       uv = (Quad_t)uv; break;
8416 #endif
8417                 }
8418             }
8419
8420         integer:
8421             eptr = ebuf + sizeof ebuf;
8422             switch (base) {
8423                 unsigned dig;
8424             case 16:
8425                 if (!uv)
8426                     alt = FALSE;
8427                 p = (char*)((c == 'X')
8428                             ? "0123456789ABCDEF" : "0123456789abcdef");
8429                 do {
8430                     dig = uv & 15;
8431                     *--eptr = p[dig];
8432                 } while (uv >>= 4);
8433                 if (alt) {
8434                     esignbuf[esignlen++] = '0';
8435                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
8436                 }
8437                 break;
8438             case 8:
8439                 do {
8440                     dig = uv & 7;
8441                     *--eptr = '0' + dig;
8442                 } while (uv >>= 3);
8443                 if (alt && *eptr != '0')
8444                     *--eptr = '0';
8445                 break;
8446             case 2:
8447                 do {
8448                     dig = uv & 1;
8449                     *--eptr = '0' + dig;
8450                 } while (uv >>= 1);
8451                 if (alt) {
8452                     esignbuf[esignlen++] = '0';
8453                     esignbuf[esignlen++] = 'b';
8454                 }
8455                 break;
8456             default:            /* it had better be ten or less */
8457 #if defined(PERL_Y2KWARN)
8458                 if (ckWARN(WARN_Y2K)) {
8459                     STRLEN n;
8460                     char *s = SvPV(sv,n);
8461                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8462                         && (n == 2 || !isDIGIT(s[n-3])))
8463                     {
8464                         Perl_warner(aTHX_ packWARN(WARN_Y2K),
8465                                     "Possible Y2K bug: %%%c %s",
8466                                     c, "format string following '19'");
8467                     }
8468                 }
8469 #endif
8470                 do {
8471                     dig = uv % base;
8472                     *--eptr = '0' + dig;
8473                 } while (uv /= base);
8474                 break;
8475             }
8476             elen = (ebuf + sizeof ebuf) - eptr;
8477             if (has_precis) {
8478                 if (precis > elen)
8479                     zeros = precis - elen;
8480                 else if (precis == 0 && elen == 1 && *eptr == '0')
8481                     elen = 0;
8482             }
8483             break;
8484
8485             /* FLOATING POINT */
8486
8487         case 'F':
8488             c = 'f';            /* maybe %F isn't supported here */
8489             /* FALL THROUGH */
8490         case 'e': case 'E':
8491         case 'f':
8492         case 'g': case 'G':
8493
8494             /* This is evil, but floating point is even more evil */
8495
8496             /* for SV-style calling, we can only get NV
8497                for C-style calling, we assume %f is double;
8498                for simplicity we allow any of %Lf, %llf, %qf for long double
8499             */
8500             switch (intsize) {
8501             case 'V':
8502 #if defined(USE_LONG_DOUBLE)
8503                 intsize = 'q';
8504 #endif
8505                 break;
8506             default:
8507 #if defined(USE_LONG_DOUBLE)
8508                 intsize = args ? 0 : 'q';
8509 #endif
8510                 break;
8511             case 'q':
8512 #if defined(HAS_LONG_DOUBLE)
8513                 break;
8514 #else
8515                 /* FALL THROUGH */
8516 #endif
8517             case 'h':
8518                 /* FALL THROUGH */
8519             case 'l':
8520                 goto unknown;
8521             }
8522
8523             /* now we need (long double) if intsize == 'q', else (double) */
8524             nv = (args && !vectorize) ?
8525 #if LONG_DOUBLESIZE > DOUBLESIZE
8526                 intsize == 'q' ?
8527                     va_arg(*args, long double) :
8528                     va_arg(*args, double)
8529 #else
8530                     va_arg(*args, double)
8531 #endif
8532                 : SvNVx(argsv);
8533
8534             need = 0;
8535             vectorize = FALSE;
8536             if (c != 'e' && c != 'E') {
8537                 i = PERL_INT_MIN;
8538                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
8539                    will cast our (long double) to (double) */
8540                 (void)Perl_frexp(nv, &i);
8541                 if (i == PERL_INT_MIN)
8542                     Perl_die(aTHX_ "panic: frexp");
8543                 if (i > 0)
8544                     need = BIT_DIGITS(i);
8545             }
8546             need += has_precis ? precis : 6; /* known default */
8547
8548             if (need < width)
8549                 need = width;
8550
8551 #ifdef HAS_LDBL_SPRINTF_BUG
8552             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8553                with sfio - Allen <allens@cpan.org> */
8554
8555 #  ifdef DBL_MAX
8556 #    define MY_DBL_MAX DBL_MAX
8557 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
8558 #    if DOUBLESIZE >= 8
8559 #      define MY_DBL_MAX 1.7976931348623157E+308L
8560 #    else
8561 #      define MY_DBL_MAX 3.40282347E+38L
8562 #    endif
8563 #  endif
8564
8565 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
8566 #    define MY_DBL_MAX_BUG 1L
8567 #  else
8568 #    define MY_DBL_MAX_BUG MY_DBL_MAX
8569 #  endif
8570
8571 #  ifdef DBL_MIN
8572 #    define MY_DBL_MIN DBL_MIN
8573 #  else  /* XXX guessing! -Allen */
8574 #    if DOUBLESIZE >= 8
8575 #      define MY_DBL_MIN 2.2250738585072014E-308L
8576 #    else
8577 #      define MY_DBL_MIN 1.17549435E-38L
8578 #    endif
8579 #  endif
8580
8581             if ((intsize == 'q') && (c == 'f') &&
8582                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
8583                 (need < DBL_DIG)) {
8584                 /* it's going to be short enough that
8585                  * long double precision is not needed */
8586
8587                 if ((nv <= 0L) && (nv >= -0L))
8588                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
8589                 else {
8590                     /* would use Perl_fp_class as a double-check but not
8591                      * functional on IRIX - see perl.h comments */
8592
8593                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
8594                         /* It's within the range that a double can represent */
8595 #if defined(DBL_MAX) && !defined(DBL_MIN)
8596                         if ((nv >= ((long double)1/DBL_MAX)) ||
8597                             (nv <= (-(long double)1/DBL_MAX)))
8598 #endif
8599                         fix_ldbl_sprintf_bug = TRUE;
8600                     }
8601                 }
8602                 if (fix_ldbl_sprintf_bug == TRUE) {
8603                     double temp;
8604
8605                     intsize = 0;
8606                     temp = (double)nv;
8607                     nv = (NV)temp;
8608                 }
8609             }
8610
8611 #  undef MY_DBL_MAX
8612 #  undef MY_DBL_MAX_BUG
8613 #  undef MY_DBL_MIN
8614
8615 #endif /* HAS_LDBL_SPRINTF_BUG */
8616
8617             need += 20; /* fudge factor */
8618             if (PL_efloatsize < need) {
8619                 Safefree(PL_efloatbuf);
8620                 PL_efloatsize = need + 20; /* more fudge */
8621                 New(906, PL_efloatbuf, PL_efloatsize, char);
8622                 PL_efloatbuf[0] = '\0';
8623             }
8624
8625             eptr = ebuf + sizeof ebuf;
8626             *--eptr = '\0';
8627             *--eptr = c;
8628             /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
8629 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8630             if (intsize == 'q') {
8631                 /* Copy the one or more characters in a long double
8632                  * format before the 'base' ([efgEFG]) character to
8633                  * the format string. */
8634                 static char const prifldbl[] = PERL_PRIfldbl;
8635                 char const *p = prifldbl + sizeof(prifldbl) - 3;
8636                 while (p >= prifldbl) { *--eptr = *p--; }
8637             }
8638 #endif
8639             if (has_precis) {
8640                 base = precis;
8641                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8642                 *--eptr = '.';
8643             }
8644             if (width) {
8645                 base = width;
8646                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8647             }
8648             if (fill == '0')
8649                 *--eptr = fill;
8650             if (left)
8651                 *--eptr = '-';
8652             if (plus)
8653                 *--eptr = plus;
8654             if (alt)
8655                 *--eptr = '#';
8656             *--eptr = '%';
8657
8658             /* No taint.  Otherwise we are in the strange situation
8659              * where printf() taints but print($float) doesn't.
8660              * --jhi */
8661 #if defined(HAS_LONG_DOUBLE)
8662             if (intsize == 'q')
8663                 (void)sprintf(PL_efloatbuf, eptr, nv);
8664             else
8665                 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
8666 #else
8667             (void)sprintf(PL_efloatbuf, eptr, nv);
8668 #endif
8669             eptr = PL_efloatbuf;
8670             elen = strlen(PL_efloatbuf);
8671             break;
8672
8673             /* SPECIAL */
8674
8675         case 'n':
8676             i = SvCUR(sv) - origlen;
8677             if (args && !vectorize) {
8678                 switch (intsize) {
8679                 case 'h':       *(va_arg(*args, short*)) = i; break;
8680                 default:        *(va_arg(*args, int*)) = i; break;
8681                 case 'l':       *(va_arg(*args, long*)) = i; break;
8682                 case 'V':       *(va_arg(*args, IV*)) = i; break;
8683 #ifdef HAS_QUAD
8684                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
8685 #endif
8686                 }
8687             }
8688             else
8689                 sv_setuv_mg(argsv, (UV)i);
8690             vectorize = FALSE;
8691             continue;   /* not "break" */
8692
8693             /* UNKNOWN */
8694
8695         default:
8696       unknown:
8697             vectorize = FALSE;
8698             if (!args && ckWARN(WARN_PRINTF) &&
8699                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8700                 SV *msg = sv_newmortal();
8701                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8702                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8703                 if (c) {
8704                     if (isPRINT(c))
8705                         Perl_sv_catpvf(aTHX_ msg,
8706                                        "\"%%%c\"", c & 0xFF);
8707                     else
8708                         Perl_sv_catpvf(aTHX_ msg,
8709                                        "\"%%\\%03"UVof"\"",
8710                                        (UV)c & 0xFF);
8711                 } else
8712                     sv_catpv(msg, "end of string");
8713                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
8714             }
8715
8716             /* output mangled stuff ... */
8717             if (c == '\0')
8718                 --q;
8719             eptr = p;
8720             elen = q - p;
8721
8722             /* ... right here, because formatting flags should not apply */
8723             SvGROW(sv, SvCUR(sv) + elen + 1);
8724             p = SvEND(sv);
8725             Copy(eptr, p, elen, char);
8726             p += elen;
8727             *p = '\0';
8728             SvCUR(sv) = p - SvPVX(sv);
8729             continue;   /* not "break" */
8730         }
8731
8732         if (is_utf8 != has_utf8) {
8733              if (is_utf8) {
8734                   if (SvCUR(sv))
8735                        sv_utf8_upgrade(sv);
8736              }
8737              else {
8738                   SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
8739                   sv_utf8_upgrade(nsv);
8740                   eptr = SvPVX(nsv);
8741                   elen = SvCUR(nsv);
8742              }
8743              SvGROW(sv, SvCUR(sv) + elen + 1);
8744              p = SvEND(sv);
8745              *p = '\0';
8746         }
8747
8748         have = esignlen + zeros + elen;
8749         need = (have > width ? have : width);
8750         gap = need - have;
8751
8752         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8753         p = SvEND(sv);
8754         if (esignlen && fill == '0') {
8755             for (i = 0; i < (int)esignlen; i++)
8756                 *p++ = esignbuf[i];
8757         }
8758         if (gap && !left) {
8759             memset(p, fill, gap);
8760             p += gap;
8761         }
8762         if (esignlen && fill != '0') {
8763             for (i = 0; i < (int)esignlen; i++)
8764                 *p++ = esignbuf[i];
8765         }
8766         if (zeros) {
8767             for (i = zeros; i; i--)
8768                 *p++ = '0';
8769         }
8770         if (elen) {
8771             Copy(eptr, p, elen, char);
8772             p += elen;
8773         }
8774         if (gap && left) {
8775             memset(p, ' ', gap);
8776             p += gap;
8777         }
8778         if (vectorize) {
8779             if (veclen) {
8780                 Copy(dotstr, p, dotstrlen, char);
8781                 p += dotstrlen;
8782             }
8783             else
8784                 vectorize = FALSE;              /* done iterating over vecstr */
8785         }
8786         if (is_utf8)
8787             has_utf8 = TRUE;
8788         if (has_utf8)
8789             SvUTF8_on(sv);
8790         *p = '\0';
8791         SvCUR(sv) = p - SvPVX(sv);
8792         if (vectorize) {
8793             esignlen = 0;
8794             goto vector;
8795         }
8796     }
8797 }
8798
8799 /* =========================================================================
8800
8801 =head1 Cloning an interpreter
8802
8803 All the macros and functions in this section are for the private use of
8804 the main function, perl_clone().
8805
8806 The foo_dup() functions make an exact copy of an existing foo thinngy.
8807 During the course of a cloning, a hash table is used to map old addresses
8808 to new addresses. The table is created and manipulated with the
8809 ptr_table_* functions.
8810
8811 =cut
8812
8813 ============================================================================*/
8814
8815
8816 #if defined(USE_ITHREADS)
8817
8818 #ifndef GpREFCNT_inc
8819 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8820 #endif
8821
8822
8823 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8824 #define av_dup(s,t)     (AV*)sv_dup((SV*)s,t)
8825 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8826 #define hv_dup(s,t)     (HV*)sv_dup((SV*)s,t)
8827 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8828 #define cv_dup(s,t)     (CV*)sv_dup((SV*)s,t)
8829 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8830 #define io_dup(s,t)     (IO*)sv_dup((SV*)s,t)
8831 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8832 #define gv_dup(s,t)     (GV*)sv_dup((SV*)s,t)
8833 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8834 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
8835 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
8836
8837
8838 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8839    regcomp.c. AMS 20010712 */
8840
8841 REGEXP *
8842 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
8843 {
8844     REGEXP *ret;
8845     int i, len, npar;
8846     struct reg_substr_datum *s;
8847
8848     if (!r)
8849         return (REGEXP *)NULL;
8850
8851     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8852         return ret;
8853
8854     len = r->offsets[0];
8855     npar = r->nparens+1;
8856
8857     Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8858     Copy(r->program, ret->program, len+1, regnode);
8859
8860     New(0, ret->startp, npar, I32);
8861     Copy(r->startp, ret->startp, npar, I32);
8862     New(0, ret->endp, npar, I32);
8863     Copy(r->startp, ret->startp, npar, I32);
8864
8865     New(0, ret->substrs, 1, struct reg_substr_data);
8866     for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8867         s->min_offset = r->substrs->data[i].min_offset;
8868         s->max_offset = r->substrs->data[i].max_offset;
8869         s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
8870         s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8871     }
8872
8873     ret->regstclass = NULL;
8874     if (r->data) {
8875         struct reg_data *d;
8876         int count = r->data->count;
8877
8878         Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8879                 char, struct reg_data);
8880         New(0, d->what, count, U8);
8881
8882         d->count = count;
8883         for (i = 0; i < count; i++) {
8884             d->what[i] = r->data->what[i];
8885             switch (d->what[i]) {
8886             case 's':
8887                 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8888                 break;
8889             case 'p':
8890                 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8891                 break;
8892             case 'f':
8893                 /* This is cheating. */
8894                 New(0, d->data[i], 1, struct regnode_charclass_class);
8895                 StructCopy(r->data->data[i], d->data[i],
8896                             struct regnode_charclass_class);
8897                 ret->regstclass = (regnode*)d->data[i];
8898                 break;
8899             case 'o':
8900                 /* Compiled op trees are readonly, and can thus be
8901                    shared without duplication. */
8902                 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8903                 break;
8904             case 'n':
8905                 d->data[i] = r->data->data[i];
8906                 break;
8907             }
8908         }
8909
8910         ret->data = d;
8911     }
8912     else
8913         ret->data = NULL;
8914
8915     New(0, ret->offsets, 2*len+1, U32);
8916     Copy(r->offsets, ret->offsets, 2*len+1, U32);
8917
8918     ret->precomp        = SAVEPV(r->precomp);
8919     ret->refcnt         = r->refcnt;
8920     ret->minlen         = r->minlen;
8921     ret->prelen         = r->prelen;
8922     ret->nparens        = r->nparens;
8923     ret->lastparen      = r->lastparen;
8924     ret->lastcloseparen = r->lastcloseparen;
8925     ret->reganch        = r->reganch;
8926
8927     ret->sublen         = r->sublen;
8928
8929     if (RX_MATCH_COPIED(ret))
8930         ret->subbeg  = SAVEPV(r->subbeg);
8931     else
8932         ret->subbeg = Nullch;
8933
8934     ptr_table_store(PL_ptr_table, r, ret);
8935     return ret;
8936 }
8937
8938 /* duplicate a file handle */
8939
8940 PerlIO *
8941 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8942 {
8943     PerlIO *ret;
8944     if (!fp)
8945         return (PerlIO*)NULL;
8946
8947     /* look for it in the table first */
8948     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8949     if (ret)
8950         return ret;
8951
8952     /* create anew and remember what it is */
8953     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
8954     ptr_table_store(PL_ptr_table, fp, ret);
8955     return ret;
8956 }
8957
8958 /* duplicate a directory handle */
8959
8960 DIR *
8961 Perl_dirp_dup(pTHX_ DIR *dp)
8962 {
8963     if (!dp)
8964         return (DIR*)NULL;
8965     /* XXX TODO */
8966     return dp;
8967 }
8968
8969 /* duplicate a typeglob */
8970
8971 GP *
8972 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8973 {
8974     GP *ret;
8975     if (!gp)
8976         return (GP*)NULL;
8977     /* look for it in the table first */
8978     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8979     if (ret)
8980         return ret;
8981
8982     /* create anew and remember what it is */
8983     Newz(0, ret, 1, GP);
8984     ptr_table_store(PL_ptr_table, gp, ret);
8985
8986     /* clone */
8987     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
8988     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
8989     ret->gp_io          = io_dup_inc(gp->gp_io, param);
8990     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
8991     ret->gp_av          = av_dup_inc(gp->gp_av, param);
8992     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
8993     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8994     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
8995     ret->gp_cvgen       = gp->gp_cvgen;
8996     ret->gp_flags       = gp->gp_flags;
8997     ret->gp_line        = gp->gp_line;
8998     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
8999     return ret;
9000 }
9001
9002 /* duplicate a chain of magic */
9003
9004 MAGIC *
9005 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9006 {
9007     MAGIC *mgprev = (MAGIC*)NULL;
9008     MAGIC *mgret;
9009     if (!mg)
9010         return (MAGIC*)NULL;
9011     /* look for it in the table first */
9012     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9013     if (mgret)
9014         return mgret;
9015
9016     for (; mg; mg = mg->mg_moremagic) {
9017         MAGIC *nmg;
9018         Newz(0, nmg, 1, MAGIC);
9019         if (mgprev)
9020             mgprev->mg_moremagic = nmg;
9021         else
9022             mgret = nmg;
9023         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
9024         nmg->mg_private = mg->mg_private;
9025         nmg->mg_type    = mg->mg_type;
9026         nmg->mg_flags   = mg->mg_flags;
9027         if (mg->mg_type == PERL_MAGIC_qr) {
9028             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9029         }
9030         else if(mg->mg_type == PERL_MAGIC_backref) {
9031              AV *av = (AV*) mg->mg_obj;
9032              SV **svp;
9033              I32 i;
9034              nmg->mg_obj = (SV*)newAV();
9035              svp = AvARRAY(av);
9036              i = AvFILLp(av);
9037              while (i >= 0) {
9038                   av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9039                   i--;
9040              }
9041         }
9042         else {
9043             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9044                               ? sv_dup_inc(mg->mg_obj, param)
9045                               : sv_dup(mg->mg_obj, param);
9046         }
9047         nmg->mg_len     = mg->mg_len;
9048         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
9049         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9050             if (mg->mg_len > 0) {
9051                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
9052                 if (mg->mg_type == PERL_MAGIC_overload_table &&
9053                         AMT_AMAGIC((AMT*)mg->mg_ptr))
9054                 {
9055                     AMT *amtp = (AMT*)mg->mg_ptr;
9056                     AMT *namtp = (AMT*)nmg->mg_ptr;
9057                     I32 i;
9058                     for (i = 1; i < NofAMmeth; i++) {
9059                         namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9060                     }
9061                 }
9062             }
9063             else if (mg->mg_len == HEf_SVKEY)
9064                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9065         }
9066         if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9067             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9068         }
9069         mgprev = nmg;
9070     }
9071     return mgret;
9072 }
9073
9074 /* create a new pointer-mapping table */
9075
9076 PTR_TBL_t *
9077 Perl_ptr_table_new(pTHX)
9078 {
9079     PTR_TBL_t *tbl;
9080     Newz(0, tbl, 1, PTR_TBL_t);
9081     tbl->tbl_max        = 511;
9082     tbl->tbl_items      = 0;
9083     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9084     return tbl;
9085 }
9086
9087 /* map an existing pointer using a table */
9088
9089 void *
9090 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
9091 {
9092     PTR_TBL_ENT_t *tblent;
9093     UV hash = PTR2UV(sv);
9094     assert(tbl);
9095     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9096     for (; tblent; tblent = tblent->next) {
9097         if (tblent->oldval == sv)
9098             return tblent->newval;
9099     }
9100     return (void*)NULL;
9101 }
9102
9103 /* add a new entry to a pointer-mapping table */
9104
9105 void
9106 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
9107 {
9108     PTR_TBL_ENT_t *tblent, **otblent;
9109     /* XXX this may be pessimal on platforms where pointers aren't good
9110      * hash values e.g. if they grow faster in the most significant
9111      * bits */
9112     UV hash = PTR2UV(oldv);
9113     bool i = 1;
9114
9115     assert(tbl);
9116     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9117     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
9118         if (tblent->oldval == oldv) {
9119             tblent->newval = newv;
9120             return;
9121         }
9122     }
9123     Newz(0, tblent, 1, PTR_TBL_ENT_t);
9124     tblent->oldval = oldv;
9125     tblent->newval = newv;
9126     tblent->next = *otblent;
9127     *otblent = tblent;
9128     tbl->tbl_items++;
9129     if (i && tbl->tbl_items > tbl->tbl_max)
9130         ptr_table_split(tbl);
9131 }
9132
9133 /* double the hash bucket size of an existing ptr table */
9134
9135 void
9136 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9137 {
9138     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9139     UV oldsize = tbl->tbl_max + 1;
9140     UV newsize = oldsize * 2;
9141     UV i;
9142
9143     Renew(ary, newsize, PTR_TBL_ENT_t*);
9144     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9145     tbl->tbl_max = --newsize;
9146     tbl->tbl_ary = ary;
9147     for (i=0; i < oldsize; i++, ary++) {
9148         PTR_TBL_ENT_t **curentp, **entp, *ent;
9149         if (!*ary)
9150             continue;
9151         curentp = ary + oldsize;
9152         for (entp = ary, ent = *ary; ent; ent = *entp) {
9153             if ((newsize & PTR2UV(ent->oldval)) != i) {
9154                 *entp = ent->next;
9155                 ent->next = *curentp;
9156                 *curentp = ent;
9157                 continue;
9158             }
9159             else
9160                 entp = &ent->next;
9161         }
9162     }
9163 }
9164
9165 /* remove all the entries from a ptr table */
9166
9167 void
9168 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9169 {
9170     register PTR_TBL_ENT_t **array;
9171     register PTR_TBL_ENT_t *entry;
9172     register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
9173     UV riter = 0;
9174     UV max;
9175
9176     if (!tbl || !tbl->tbl_items) {
9177         return;
9178     }
9179
9180     array = tbl->tbl_ary;
9181     entry = array[0];
9182     max = tbl->tbl_max;
9183
9184     for (;;) {
9185         if (entry) {
9186             oentry = entry;
9187             entry = entry->next;
9188             Safefree(oentry);
9189         }
9190         if (!entry) {
9191             if (++riter > max) {
9192                 break;
9193             }
9194             entry = array[riter];
9195         }
9196     }
9197
9198     tbl->tbl_items = 0;
9199 }
9200
9201 /* clear and free a ptr table */
9202
9203 void
9204 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9205 {
9206     if (!tbl) {
9207         return;
9208     }
9209     ptr_table_clear(tbl);
9210     Safefree(tbl->tbl_ary);
9211     Safefree(tbl);
9212 }
9213
9214 #ifdef DEBUGGING
9215 char *PL_watch_pvx;
9216 #endif
9217
9218 /* attempt to make everything in the typeglob readonly */
9219
9220 STATIC SV *
9221 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
9222 {
9223     GV *gv = (GV*)sstr;
9224     SV *sv = &param->proto_perl->Isv_no; /* just need SvREADONLY-ness */
9225
9226     if (GvIO(gv) || GvFORM(gv)) {
9227         GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
9228     }
9229     else if (!GvCV(gv)) {
9230         GvCV(gv) = (CV*)sv;
9231     }
9232     else {
9233         /* CvPADLISTs cannot be shared */
9234         if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
9235             GvUNIQUE_off(gv);
9236         }
9237     }
9238
9239     if (!GvUNIQUE(gv)) {
9240 #if 0
9241         PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
9242                       HvNAME(GvSTASH(gv)), GvNAME(gv));
9243 #endif
9244         return Nullsv;
9245     }
9246
9247     /*
9248      * write attempts will die with
9249      * "Modification of a read-only value attempted"
9250      */
9251     if (!GvSV(gv)) {
9252         GvSV(gv) = sv;
9253     }
9254     else {
9255         SvREADONLY_on(GvSV(gv));
9256     }
9257
9258     if (!GvAV(gv)) {
9259         GvAV(gv) = (AV*)sv;
9260     }
9261     else {
9262         SvREADONLY_on(GvAV(gv));
9263     }
9264
9265     if (!GvHV(gv)) {
9266         GvHV(gv) = (HV*)sv;
9267     }
9268     else {
9269         SvREADONLY_on(GvAV(gv));
9270     }
9271
9272     return sstr; /* he_dup() will SvREFCNT_inc() */
9273 }
9274
9275 /* duplicate an SV of any type (including AV, HV etc) */
9276
9277 void
9278 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9279 {
9280     if (SvROK(sstr)) {
9281         SvRV(dstr) = SvWEAKREF(sstr)
9282                      ? sv_dup(SvRV(sstr), param)
9283                      : sv_dup_inc(SvRV(sstr), param);
9284     }
9285     else if (SvPVX(sstr)) {
9286         /* Has something there */
9287         if (SvLEN(sstr)) {
9288             /* Normal PV - clone whole allocated space */
9289             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9290             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9291                 /* Not that normal - actually sstr is copy on write.
9292                    But we are a true, independant SV, so:  */
9293                 SvREADONLY_off(dstr);
9294                 SvFAKE_off(dstr);
9295             }
9296         }
9297         else {
9298             /* Special case - not normally malloced for some reason */
9299             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9300                 /* A "shared" PV - clone it as unshared string */
9301                 SvFAKE_off(dstr);
9302                 SvREADONLY_off(dstr);
9303                 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
9304             }
9305             else {
9306                 /* Some other special case - random pointer */
9307                 SvPVX(dstr) = SvPVX(sstr);
9308             }
9309         }
9310     }
9311     else {
9312         /* Copy the Null */
9313         SvPVX(dstr) = SvPVX(sstr);
9314     }
9315 }
9316
9317 SV *
9318 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9319 {
9320     SV *dstr;
9321
9322     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9323         return Nullsv;
9324     /* look for it in the table first */
9325     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9326     if (dstr)
9327         return dstr;
9328
9329     /* create anew and remember what it is */
9330     new_SV(dstr);
9331     ptr_table_store(PL_ptr_table, sstr, dstr);
9332
9333     /* clone */
9334     SvFLAGS(dstr)       = SvFLAGS(sstr);
9335     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
9336     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
9337
9338 #ifdef DEBUGGING
9339     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
9340         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9341                       PL_watch_pvx, SvPVX(sstr));
9342 #endif
9343
9344     switch (SvTYPE(sstr)) {
9345     case SVt_NULL:
9346         SvANY(dstr)     = NULL;
9347         break;
9348     case SVt_IV:
9349         SvANY(dstr)     = new_XIV();
9350         SvIVX(dstr)     = SvIVX(sstr);
9351         break;
9352     case SVt_NV:
9353         SvANY(dstr)     = new_XNV();
9354         SvNVX(dstr)     = SvNVX(sstr);
9355         break;
9356     case SVt_RV:
9357         SvANY(dstr)     = new_XRV();
9358         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9359         break;
9360     case SVt_PV:
9361         SvANY(dstr)     = new_XPV();
9362         SvCUR(dstr)     = SvCUR(sstr);
9363         SvLEN(dstr)     = SvLEN(sstr);
9364         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9365         break;
9366     case SVt_PVIV:
9367         SvANY(dstr)     = new_XPVIV();
9368         SvCUR(dstr)     = SvCUR(sstr);
9369         SvLEN(dstr)     = SvLEN(sstr);
9370         SvIVX(dstr)     = SvIVX(sstr);
9371         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9372         break;
9373     case SVt_PVNV:
9374         SvANY(dstr)     = new_XPVNV();
9375         SvCUR(dstr)     = SvCUR(sstr);
9376         SvLEN(dstr)     = SvLEN(sstr);
9377         SvIVX(dstr)     = SvIVX(sstr);
9378         SvNVX(dstr)     = SvNVX(sstr);
9379         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9380         break;
9381     case SVt_PVMG:
9382         SvANY(dstr)     = new_XPVMG();
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         break;
9391     case SVt_PVBM:
9392         SvANY(dstr)     = new_XPVBM();
9393         SvCUR(dstr)     = SvCUR(sstr);
9394         SvLEN(dstr)     = SvLEN(sstr);
9395         SvIVX(dstr)     = SvIVX(sstr);
9396         SvNVX(dstr)     = SvNVX(sstr);
9397         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9398         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9399         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9400         BmRARE(dstr)    = BmRARE(sstr);
9401         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
9402         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
9403         break;
9404     case SVt_PVLV:
9405         SvANY(dstr)     = new_XPVLV();
9406         SvCUR(dstr)     = SvCUR(sstr);
9407         SvLEN(dstr)     = SvLEN(sstr);
9408         SvIVX(dstr)     = SvIVX(sstr);
9409         SvNVX(dstr)     = SvNVX(sstr);
9410         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9411         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9412         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9413         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
9414         LvTARGLEN(dstr) = LvTARGLEN(sstr);
9415         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr), param);
9416         LvTYPE(dstr)    = LvTYPE(sstr);
9417         break;
9418     case SVt_PVGV:
9419         if (GvUNIQUE((GV*)sstr)) {
9420             SV *share;
9421             if ((share = gv_share(sstr, param))) {
9422                 del_SV(dstr);
9423                 dstr = share;
9424                 ptr_table_store(PL_ptr_table, sstr, dstr);
9425 #if 0
9426                 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
9427                               HvNAME(GvSTASH(share)), GvNAME(share));
9428 #endif
9429                 break;
9430             }
9431         }
9432         SvANY(dstr)     = new_XPVGV();
9433         SvCUR(dstr)     = SvCUR(sstr);
9434         SvLEN(dstr)     = SvLEN(sstr);
9435         SvIVX(dstr)     = SvIVX(sstr);
9436         SvNVX(dstr)     = SvNVX(sstr);
9437         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9438         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9439         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9440         GvNAMELEN(dstr) = GvNAMELEN(sstr);
9441         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
9442         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr), param);
9443         GvFLAGS(dstr)   = GvFLAGS(sstr);
9444         GvGP(dstr)      = gp_dup(GvGP(sstr), param);
9445         (void)GpREFCNT_inc(GvGP(dstr));
9446         break;
9447     case SVt_PVIO:
9448         SvANY(dstr)     = new_XPVIO();
9449         SvCUR(dstr)     = SvCUR(sstr);
9450         SvLEN(dstr)     = SvLEN(sstr);
9451         SvIVX(dstr)     = SvIVX(sstr);
9452         SvNVX(dstr)     = SvNVX(sstr);
9453         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9454         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9455         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9456         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
9457         if (IoOFP(sstr) == IoIFP(sstr))
9458             IoOFP(dstr) = IoIFP(dstr);
9459         else
9460             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
9461         /* PL_rsfp_filters entries have fake IoDIRP() */
9462         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
9463             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
9464         else
9465             IoDIRP(dstr)        = IoDIRP(sstr);
9466         IoLINES(dstr)           = IoLINES(sstr);
9467         IoPAGE(dstr)            = IoPAGE(sstr);
9468         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
9469         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
9470         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
9471         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr), param);
9472         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
9473         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr), param);
9474         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
9475         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr), param);
9476         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
9477         IoTYPE(dstr)            = IoTYPE(sstr);
9478         IoFLAGS(dstr)           = IoFLAGS(sstr);
9479         break;
9480     case SVt_PVAV:
9481         SvANY(dstr)     = new_XPVAV();
9482         SvCUR(dstr)     = SvCUR(sstr);
9483         SvLEN(dstr)     = SvLEN(sstr);
9484         SvIVX(dstr)     = SvIVX(sstr);
9485         SvNVX(dstr)     = SvNVX(sstr);
9486         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9487         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9488         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9489         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9490         if (AvARRAY((AV*)sstr)) {
9491             SV **dst_ary, **src_ary;
9492             SSize_t items = AvFILLp((AV*)sstr) + 1;
9493
9494             src_ary = AvARRAY((AV*)sstr);
9495             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9496             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9497             SvPVX(dstr) = (char*)dst_ary;
9498             AvALLOC((AV*)dstr) = dst_ary;
9499             if (AvREAL((AV*)sstr)) {
9500                 while (items-- > 0)
9501                     *dst_ary++ = sv_dup_inc(*src_ary++, param);
9502             }
9503             else {
9504                 while (items-- > 0)
9505                     *dst_ary++ = sv_dup(*src_ary++, param);
9506             }
9507             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9508             while (items-- > 0) {
9509                 *dst_ary++ = &PL_sv_undef;
9510             }
9511         }
9512         else {
9513             SvPVX(dstr)         = Nullch;
9514             AvALLOC((AV*)dstr)  = (SV**)NULL;
9515         }
9516         break;
9517     case SVt_PVHV:
9518         SvANY(dstr)     = new_XPVHV();
9519         SvCUR(dstr)     = SvCUR(sstr);
9520         SvLEN(dstr)     = SvLEN(sstr);
9521         SvIVX(dstr)     = SvIVX(sstr);
9522         SvNVX(dstr)     = SvNVX(sstr);
9523         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9524         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9525         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
9526         if (HvARRAY((HV*)sstr)) {
9527             STRLEN i = 0;
9528             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9529             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9530             Newz(0, dxhv->xhv_array,
9531                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9532             while (i <= sxhv->xhv_max) {
9533                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9534                                                     (bool)!!HvSHAREKEYS(sstr),
9535                                                     param);
9536                 ++i;
9537             }
9538             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
9539                                      (bool)!!HvSHAREKEYS(sstr), param);
9540         }
9541         else {
9542             SvPVX(dstr)         = Nullch;
9543             HvEITER((HV*)dstr)  = (HE*)NULL;
9544         }
9545         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
9546         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
9547     /* Record stashes for possible cloning in Perl_clone(). */
9548         if(HvNAME((HV*)dstr))
9549             av_push(param->stashes, dstr);
9550         break;
9551     case SVt_PVFM:
9552         SvANY(dstr)     = new_XPVFM();
9553         FmLINES(dstr)   = FmLINES(sstr);
9554         goto dup_pvcv;
9555         /* NOTREACHED */
9556     case SVt_PVCV:
9557         SvANY(dstr)     = new_XPVCV();
9558         dup_pvcv:
9559         SvCUR(dstr)     = SvCUR(sstr);
9560         SvLEN(dstr)     = SvLEN(sstr);
9561         SvIVX(dstr)     = SvIVX(sstr);
9562         SvNVX(dstr)     = SvNVX(sstr);
9563         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9564         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9565         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9566         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9567         CvSTART(dstr)   = CvSTART(sstr);
9568         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
9569         CvXSUB(dstr)    = CvXSUB(sstr);
9570         CvXSUBANY(dstr) = CvXSUBANY(sstr);
9571         if (CvCONST(sstr)) {
9572             CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9573                 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9574                 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9575         }
9576         CvGV(dstr)      = gv_dup(CvGV(sstr), param);
9577         if (param->flags & CLONEf_COPY_STACKS) {
9578           CvDEPTH(dstr) = CvDEPTH(sstr);
9579         } else {
9580           CvDEPTH(dstr) = 0;
9581         }
9582         PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
9583         if (!CvANON(sstr) || CvCLONED(sstr))
9584             CvOUTSIDE(dstr)     = cv_dup_inc(CvOUTSIDE(sstr), param);
9585         else
9586             CvOUTSIDE(dstr)     = cv_dup(CvOUTSIDE(sstr), param);
9587         CvFLAGS(dstr)   = CvFLAGS(sstr);
9588         CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9589         break;
9590     default:
9591         Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
9592         break;
9593     }
9594
9595     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9596         ++PL_sv_objcount;
9597
9598     return dstr;
9599  }
9600
9601 /* duplicate a context */
9602
9603 PERL_CONTEXT *
9604 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9605 {
9606     PERL_CONTEXT *ncxs;
9607
9608     if (!cxs)
9609         return (PERL_CONTEXT*)NULL;
9610
9611     /* look for it in the table first */
9612     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9613     if (ncxs)
9614         return ncxs;
9615
9616     /* create anew and remember what it is */
9617     Newz(56, ncxs, max + 1, PERL_CONTEXT);
9618     ptr_table_store(PL_ptr_table, cxs, ncxs);
9619
9620     while (ix >= 0) {
9621         PERL_CONTEXT *cx = &cxs[ix];
9622         PERL_CONTEXT *ncx = &ncxs[ix];
9623         ncx->cx_type    = cx->cx_type;
9624         if (CxTYPE(cx) == CXt_SUBST) {
9625             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9626         }
9627         else {
9628             ncx->blk_oldsp      = cx->blk_oldsp;
9629             ncx->blk_oldcop     = cx->blk_oldcop;
9630             ncx->blk_oldretsp   = cx->blk_oldretsp;
9631             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
9632             ncx->blk_oldscopesp = cx->blk_oldscopesp;
9633             ncx->blk_oldpm      = cx->blk_oldpm;
9634             ncx->blk_gimme      = cx->blk_gimme;
9635             switch (CxTYPE(cx)) {
9636             case CXt_SUB:
9637                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
9638                                            ? cv_dup_inc(cx->blk_sub.cv, param)
9639                                            : cv_dup(cx->blk_sub.cv,param));
9640                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
9641                                            ? av_dup_inc(cx->blk_sub.argarray, param)
9642                                            : Nullav);
9643                 ncx->blk_sub.savearray  = av_dup_inc(cx->blk_sub.savearray, param);
9644                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
9645                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
9646                 ncx->blk_sub.lval       = cx->blk_sub.lval;
9647                 break;
9648             case CXt_EVAL:
9649                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9650                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9651                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
9652                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9653                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text, param);
9654                 break;
9655             case CXt_LOOP:
9656                 ncx->blk_loop.label     = cx->blk_loop.label;
9657                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
9658                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
9659                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
9660                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
9661                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
9662                                            ? cx->blk_loop.iterdata
9663                                            : gv_dup((GV*)cx->blk_loop.iterdata, param));
9664                 ncx->blk_loop.oldcomppad
9665                     = (PAD*)ptr_table_fetch(PL_ptr_table,
9666                                             cx->blk_loop.oldcomppad);
9667                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave, param);
9668                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval, param);
9669                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary, param);
9670                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
9671                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
9672                 break;
9673             case CXt_FORMAT:
9674                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv, param);
9675                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv, param);
9676                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9677                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
9678                 break;
9679             case CXt_BLOCK:
9680             case CXt_NULL:
9681                 break;
9682             }
9683         }
9684         --ix;
9685     }
9686     return ncxs;
9687 }
9688
9689 /* duplicate a stack info structure */
9690
9691 PERL_SI *
9692 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9693 {
9694     PERL_SI *nsi;
9695
9696     if (!si)
9697         return (PERL_SI*)NULL;
9698
9699     /* look for it in the table first */
9700     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9701     if (nsi)
9702         return nsi;
9703
9704     /* create anew and remember what it is */
9705     Newz(56, nsi, 1, PERL_SI);
9706     ptr_table_store(PL_ptr_table, si, nsi);
9707
9708     nsi->si_stack       = av_dup_inc(si->si_stack, param);
9709     nsi->si_cxix        = si->si_cxix;
9710     nsi->si_cxmax       = si->si_cxmax;
9711     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9712     nsi->si_type        = si->si_type;
9713     nsi->si_prev        = si_dup(si->si_prev, param);
9714     nsi->si_next        = si_dup(si->si_next, param);
9715     nsi->si_markoff     = si->si_markoff;
9716
9717     return nsi;
9718 }
9719
9720 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
9721 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
9722 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
9723 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
9724 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
9725 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
9726 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
9727 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
9728 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
9729 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
9730 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9731 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9732
9733 /* XXXXX todo */
9734 #define pv_dup_inc(p)   SAVEPV(p)
9735 #define pv_dup(p)       SAVEPV(p)
9736 #define svp_dup_inc(p,pp)       any_dup(p,pp)
9737
9738 /* map any object to the new equivent - either something in the
9739  * ptr table, or something in the interpreter structure
9740  */
9741
9742 void *
9743 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9744 {
9745     void *ret;
9746
9747     if (!v)
9748         return (void*)NULL;
9749
9750     /* look for it in the table first */
9751     ret = ptr_table_fetch(PL_ptr_table, v);
9752     if (ret)
9753         return ret;
9754
9755     /* see if it is part of the interpreter structure */
9756     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9757         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9758     else {
9759         ret = v;
9760     }
9761
9762     return ret;
9763 }
9764
9765 /* duplicate the save stack */
9766
9767 ANY *
9768 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9769 {
9770     ANY *ss     = proto_perl->Tsavestack;
9771     I32 ix      = proto_perl->Tsavestack_ix;
9772     I32 max     = proto_perl->Tsavestack_max;
9773     ANY *nss;
9774     SV *sv;
9775     GV *gv;
9776     AV *av;
9777     HV *hv;
9778     void* ptr;
9779     int intval;
9780     long longval;
9781     GP *gp;
9782     IV iv;
9783     I32 i;
9784     char *c = NULL;
9785     void (*dptr) (void*);
9786     void (*dxptr) (pTHX_ void*);
9787     OP *o;
9788
9789     Newz(54, nss, max, ANY);
9790
9791     while (ix > 0) {
9792         i = POPINT(ss,ix);
9793         TOPINT(nss,ix) = i;
9794         switch (i) {
9795         case SAVEt_ITEM:                        /* normal string */
9796             sv = (SV*)POPPTR(ss,ix);
9797             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9798             sv = (SV*)POPPTR(ss,ix);
9799             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9800             break;
9801         case SAVEt_SV:                          /* scalar reference */
9802             sv = (SV*)POPPTR(ss,ix);
9803             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9804             gv = (GV*)POPPTR(ss,ix);
9805             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9806             break;
9807         case SAVEt_GENERIC_PVREF:               /* generic char* */
9808             c = (char*)POPPTR(ss,ix);
9809             TOPPTR(nss,ix) = pv_dup(c);
9810             ptr = POPPTR(ss,ix);
9811             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9812             break;
9813         case SAVEt_SHARED_PVREF:                /* char* in shared space */
9814             c = (char*)POPPTR(ss,ix);
9815             TOPPTR(nss,ix) = savesharedpv(c);
9816             ptr = POPPTR(ss,ix);
9817             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9818             break;
9819         case SAVEt_GENERIC_SVREF:               /* generic sv */
9820         case SAVEt_SVREF:                       /* scalar reference */
9821             sv = (SV*)POPPTR(ss,ix);
9822             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9823             ptr = POPPTR(ss,ix);
9824             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9825             break;
9826         case SAVEt_AV:                          /* array reference */
9827             av = (AV*)POPPTR(ss,ix);
9828             TOPPTR(nss,ix) = av_dup_inc(av, param);
9829             gv = (GV*)POPPTR(ss,ix);
9830             TOPPTR(nss,ix) = gv_dup(gv, param);
9831             break;
9832         case SAVEt_HV:                          /* hash reference */
9833             hv = (HV*)POPPTR(ss,ix);
9834             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9835             gv = (GV*)POPPTR(ss,ix);
9836             TOPPTR(nss,ix) = gv_dup(gv, param);
9837             break;
9838         case SAVEt_INT:                         /* int reference */
9839             ptr = POPPTR(ss,ix);
9840             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9841             intval = (int)POPINT(ss,ix);
9842             TOPINT(nss,ix) = intval;
9843             break;
9844         case SAVEt_LONG:                        /* long reference */
9845             ptr = POPPTR(ss,ix);
9846             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9847             longval = (long)POPLONG(ss,ix);
9848             TOPLONG(nss,ix) = longval;
9849             break;
9850         case SAVEt_I32:                         /* I32 reference */
9851         case SAVEt_I16:                         /* I16 reference */
9852         case SAVEt_I8:                          /* I8 reference */
9853             ptr = POPPTR(ss,ix);
9854             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9855             i = POPINT(ss,ix);
9856             TOPINT(nss,ix) = i;
9857             break;
9858         case SAVEt_IV:                          /* IV reference */
9859             ptr = POPPTR(ss,ix);
9860             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9861             iv = POPIV(ss,ix);
9862             TOPIV(nss,ix) = iv;
9863             break;
9864         case SAVEt_SPTR:                        /* SV* reference */
9865             ptr = POPPTR(ss,ix);
9866             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9867             sv = (SV*)POPPTR(ss,ix);
9868             TOPPTR(nss,ix) = sv_dup(sv, param);
9869             break;
9870         case SAVEt_VPTR:                        /* random* reference */
9871             ptr = POPPTR(ss,ix);
9872             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9873             ptr = POPPTR(ss,ix);
9874             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9875             break;
9876         case SAVEt_PPTR:                        /* char* reference */
9877             ptr = POPPTR(ss,ix);
9878             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9879             c = (char*)POPPTR(ss,ix);
9880             TOPPTR(nss,ix) = pv_dup(c);
9881             break;
9882         case SAVEt_HPTR:                        /* HV* reference */
9883             ptr = POPPTR(ss,ix);
9884             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9885             hv = (HV*)POPPTR(ss,ix);
9886             TOPPTR(nss,ix) = hv_dup(hv, param);
9887             break;
9888         case SAVEt_APTR:                        /* AV* reference */
9889             ptr = POPPTR(ss,ix);
9890             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9891             av = (AV*)POPPTR(ss,ix);
9892             TOPPTR(nss,ix) = av_dup(av, param);
9893             break;
9894         case SAVEt_NSTAB:
9895             gv = (GV*)POPPTR(ss,ix);
9896             TOPPTR(nss,ix) = gv_dup(gv, param);
9897             break;
9898         case SAVEt_GP:                          /* scalar reference */
9899             gp = (GP*)POPPTR(ss,ix);
9900             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9901             (void)GpREFCNT_inc(gp);
9902             gv = (GV*)POPPTR(ss,ix);
9903             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9904             c = (char*)POPPTR(ss,ix);
9905             TOPPTR(nss,ix) = pv_dup(c);
9906             iv = POPIV(ss,ix);
9907             TOPIV(nss,ix) = iv;
9908             iv = POPIV(ss,ix);
9909             TOPIV(nss,ix) = iv;
9910             break;
9911         case SAVEt_FREESV:
9912         case SAVEt_MORTALIZESV:
9913             sv = (SV*)POPPTR(ss,ix);
9914             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9915             break;
9916         case SAVEt_FREEOP:
9917             ptr = POPPTR(ss,ix);
9918             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9919                 /* these are assumed to be refcounted properly */
9920                 switch (((OP*)ptr)->op_type) {
9921                 case OP_LEAVESUB:
9922                 case OP_LEAVESUBLV:
9923                 case OP_LEAVEEVAL:
9924                 case OP_LEAVE:
9925                 case OP_SCOPE:
9926                 case OP_LEAVEWRITE:
9927                     TOPPTR(nss,ix) = ptr;
9928                     o = (OP*)ptr;
9929                     OpREFCNT_inc(o);
9930                     break;
9931                 default:
9932                     TOPPTR(nss,ix) = Nullop;
9933                     break;
9934                 }
9935             }
9936             else
9937                 TOPPTR(nss,ix) = Nullop;
9938             break;
9939         case SAVEt_FREEPV:
9940             c = (char*)POPPTR(ss,ix);
9941             TOPPTR(nss,ix) = pv_dup_inc(c);
9942             break;
9943         case SAVEt_CLEARSV:
9944             longval = POPLONG(ss,ix);
9945             TOPLONG(nss,ix) = longval;
9946             break;
9947         case SAVEt_DELETE:
9948             hv = (HV*)POPPTR(ss,ix);
9949             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9950             c = (char*)POPPTR(ss,ix);
9951             TOPPTR(nss,ix) = pv_dup_inc(c);
9952             i = POPINT(ss,ix);
9953             TOPINT(nss,ix) = i;
9954             break;
9955         case SAVEt_DESTRUCTOR:
9956             ptr = POPPTR(ss,ix);
9957             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
9958             dptr = POPDPTR(ss,ix);
9959             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9960             break;
9961         case SAVEt_DESTRUCTOR_X:
9962             ptr = POPPTR(ss,ix);
9963             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
9964             dxptr = POPDXPTR(ss,ix);
9965             TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
9966             break;
9967         case SAVEt_REGCONTEXT:
9968         case SAVEt_ALLOC:
9969             i = POPINT(ss,ix);
9970             TOPINT(nss,ix) = i;
9971             ix -= i;
9972             break;
9973         case SAVEt_STACK_POS:           /* Position on Perl stack */
9974             i = POPINT(ss,ix);
9975             TOPINT(nss,ix) = i;
9976             break;
9977         case SAVEt_AELEM:               /* array element */
9978             sv = (SV*)POPPTR(ss,ix);
9979             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9980             i = POPINT(ss,ix);
9981             TOPINT(nss,ix) = i;
9982             av = (AV*)POPPTR(ss,ix);
9983             TOPPTR(nss,ix) = av_dup_inc(av, param);
9984             break;
9985         case SAVEt_HELEM:               /* hash element */
9986             sv = (SV*)POPPTR(ss,ix);
9987             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9988             sv = (SV*)POPPTR(ss,ix);
9989             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9990             hv = (HV*)POPPTR(ss,ix);
9991             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9992             break;
9993         case SAVEt_OP:
9994             ptr = POPPTR(ss,ix);
9995             TOPPTR(nss,ix) = ptr;
9996             break;
9997         case SAVEt_HINTS:
9998             i = POPINT(ss,ix);
9999             TOPINT(nss,ix) = i;
10000             break;
10001         case SAVEt_COMPPAD:
10002             av = (AV*)POPPTR(ss,ix);
10003             TOPPTR(nss,ix) = av_dup(av, param);
10004             break;
10005         case SAVEt_PADSV:
10006             longval = (long)POPLONG(ss,ix);
10007             TOPLONG(nss,ix) = longval;
10008             ptr = POPPTR(ss,ix);
10009             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10010             sv = (SV*)POPPTR(ss,ix);
10011             TOPPTR(nss,ix) = sv_dup(sv, param);
10012             break;
10013         default:
10014             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10015         }
10016     }
10017
10018     return nss;
10019 }
10020
10021 /*
10022 =for apidoc perl_clone
10023
10024 Create and return a new interpreter by cloning the current one.
10025
10026 =cut
10027 */
10028
10029 /* XXX the above needs expanding by someone who actually understands it ! */
10030 EXTERN_C PerlInterpreter *
10031 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10032
10033 PerlInterpreter *
10034 perl_clone(PerlInterpreter *proto_perl, UV flags)
10035 {
10036 #ifdef PERL_IMPLICIT_SYS
10037
10038    /* perlhost.h so we need to call into it
10039    to clone the host, CPerlHost should have a c interface, sky */
10040
10041    if (flags & CLONEf_CLONE_HOST) {
10042        return perl_clone_host(proto_perl,flags);
10043    }
10044    return perl_clone_using(proto_perl, flags,
10045                             proto_perl->IMem,
10046                             proto_perl->IMemShared,
10047                             proto_perl->IMemParse,
10048                             proto_perl->IEnv,
10049                             proto_perl->IStdIO,
10050                             proto_perl->ILIO,
10051                             proto_perl->IDir,
10052                             proto_perl->ISock,
10053                             proto_perl->IProc);
10054 }
10055
10056 PerlInterpreter *
10057 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10058                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
10059                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10060                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10061                  struct IPerlDir* ipD, struct IPerlSock* ipS,
10062                  struct IPerlProc* ipP)
10063 {
10064     /* XXX many of the string copies here can be optimized if they're
10065      * constants; they need to be allocated as common memory and just
10066      * their pointers copied. */
10067
10068     IV i;
10069     CLONE_PARAMS clone_params;
10070     CLONE_PARAMS* param = &clone_params;
10071
10072     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10073     PERL_SET_THX(my_perl);
10074
10075 #  ifdef DEBUGGING
10076     Poison(my_perl, 1, PerlInterpreter);
10077     PL_markstack = 0;
10078     PL_scopestack = 0;
10079     PL_savestack = 0;
10080     PL_retstack = 0;
10081     PL_sig_pending = 0;
10082     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10083 #  else /* !DEBUGGING */
10084     Zero(my_perl, 1, PerlInterpreter);
10085 #  endif        /* DEBUGGING */
10086
10087     /* host pointers */
10088     PL_Mem              = ipM;
10089     PL_MemShared        = ipMS;
10090     PL_MemParse         = ipMP;
10091     PL_Env              = ipE;
10092     PL_StdIO            = ipStd;
10093     PL_LIO              = ipLIO;
10094     PL_Dir              = ipD;
10095     PL_Sock             = ipS;
10096     PL_Proc             = ipP;
10097 #else           /* !PERL_IMPLICIT_SYS */
10098     IV i;
10099     CLONE_PARAMS clone_params;
10100     CLONE_PARAMS* param = &clone_params;
10101     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10102     PERL_SET_THX(my_perl);
10103
10104
10105
10106 #    ifdef DEBUGGING
10107     Poison(my_perl, 1, PerlInterpreter);
10108     PL_markstack = 0;
10109     PL_scopestack = 0;
10110     PL_savestack = 0;
10111     PL_retstack = 0;
10112     PL_sig_pending = 0;
10113     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10114 #    else       /* !DEBUGGING */
10115     Zero(my_perl, 1, PerlInterpreter);
10116 #    endif      /* DEBUGGING */
10117 #endif          /* PERL_IMPLICIT_SYS */
10118     param->flags = flags;
10119     param->proto_perl = proto_perl;
10120
10121     /* arena roots */
10122     PL_xiv_arenaroot    = NULL;
10123     PL_xiv_root         = NULL;
10124     PL_xnv_arenaroot    = NULL;
10125     PL_xnv_root         = NULL;
10126     PL_xrv_arenaroot    = NULL;
10127     PL_xrv_root         = NULL;
10128     PL_xpv_arenaroot    = NULL;
10129     PL_xpv_root         = NULL;
10130     PL_xpviv_arenaroot  = NULL;
10131     PL_xpviv_root       = NULL;
10132     PL_xpvnv_arenaroot  = NULL;
10133     PL_xpvnv_root       = NULL;
10134     PL_xpvcv_arenaroot  = NULL;
10135     PL_xpvcv_root       = NULL;
10136     PL_xpvav_arenaroot  = NULL;
10137     PL_xpvav_root       = NULL;
10138     PL_xpvhv_arenaroot  = NULL;
10139     PL_xpvhv_root       = NULL;
10140     PL_xpvmg_arenaroot  = NULL;
10141     PL_xpvmg_root       = NULL;
10142     PL_xpvlv_arenaroot  = NULL;
10143     PL_xpvlv_root       = NULL;
10144     PL_xpvbm_arenaroot  = NULL;
10145     PL_xpvbm_root       = NULL;
10146     PL_he_arenaroot     = NULL;
10147     PL_he_root          = NULL;
10148     PL_nice_chunk       = NULL;
10149     PL_nice_chunk_size  = 0;
10150     PL_sv_count         = 0;
10151     PL_sv_objcount      = 0;
10152     PL_sv_root          = Nullsv;
10153     PL_sv_arenaroot     = Nullsv;
10154
10155     PL_debug            = proto_perl->Idebug;
10156
10157 #ifdef USE_REENTRANT_API
10158     Perl_reentrant_init(aTHX);
10159 #endif
10160
10161     /* create SV map for pointer relocation */
10162     PL_ptr_table = ptr_table_new();
10163
10164     /* initialize these special pointers as early as possible */
10165     SvANY(&PL_sv_undef)         = NULL;
10166     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
10167     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
10168     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10169
10170     SvANY(&PL_sv_no)            = new_XPVNV();
10171     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
10172     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10173     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
10174     SvCUR(&PL_sv_no)            = 0;
10175     SvLEN(&PL_sv_no)            = 1;
10176     SvNVX(&PL_sv_no)            = 0;
10177     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10178
10179     SvANY(&PL_sv_yes)           = new_XPVNV();
10180     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
10181     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10182     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
10183     SvCUR(&PL_sv_yes)           = 1;
10184     SvLEN(&PL_sv_yes)           = 2;
10185     SvNVX(&PL_sv_yes)           = 1;
10186     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10187
10188     /* create (a non-shared!) shared string table */
10189     PL_strtab           = newHV();
10190     HvSHAREKEYS_off(PL_strtab);
10191     hv_ksplit(PL_strtab, 512);
10192     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10193
10194     PL_compiling = proto_perl->Icompiling;
10195
10196     /* These two PVs will be free'd special way so must set them same way op.c does */
10197     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10198     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10199
10200     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
10201     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10202
10203     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10204     if (!specialWARN(PL_compiling.cop_warnings))
10205         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10206     if (!specialCopIO(PL_compiling.cop_io))
10207         PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10208     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10209
10210     /* pseudo environmental stuff */
10211     PL_origargc         = proto_perl->Iorigargc;
10212     i = PL_origargc;
10213     New(0, PL_origargv, i+1, char*);
10214     PL_origargv[i] = '\0';
10215     while (i-- > 0) {
10216         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
10217     }
10218
10219     param->stashes      = newAV();  /* Setup array of objects to call clone on */
10220
10221 #ifdef PERLIO_LAYERS
10222     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10223     PerlIO_clone(aTHX_ proto_perl, param);
10224 #endif
10225
10226     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
10227     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
10228     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
10229     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
10230     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
10231     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
10232
10233     /* switches */
10234     PL_minus_c          = proto_perl->Iminus_c;
10235     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
10236     PL_localpatches     = proto_perl->Ilocalpatches;
10237     PL_splitstr         = proto_perl->Isplitstr;
10238     PL_preprocess       = proto_perl->Ipreprocess;
10239     PL_minus_n          = proto_perl->Iminus_n;
10240     PL_minus_p          = proto_perl->Iminus_p;
10241     PL_minus_l          = proto_perl->Iminus_l;
10242     PL_minus_a          = proto_perl->Iminus_a;
10243     PL_minus_F          = proto_perl->Iminus_F;
10244     PL_doswitches       = proto_perl->Idoswitches;
10245     PL_dowarn           = proto_perl->Idowarn;
10246     PL_doextract        = proto_perl->Idoextract;
10247     PL_sawampersand     = proto_perl->Isawampersand;
10248     PL_unsafe           = proto_perl->Iunsafe;
10249     PL_inplace          = SAVEPV(proto_perl->Iinplace);
10250     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
10251     PL_perldb           = proto_perl->Iperldb;
10252     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10253     PL_exit_flags       = proto_perl->Iexit_flags;
10254
10255     /* magical thingies */
10256     /* XXX time(&PL_basetime) when asked for? */
10257     PL_basetime         = proto_perl->Ibasetime;
10258     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
10259
10260     PL_maxsysfd         = proto_perl->Imaxsysfd;
10261     PL_multiline        = proto_perl->Imultiline;
10262     PL_statusvalue      = proto_perl->Istatusvalue;
10263 #ifdef VMS
10264     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
10265 #endif
10266     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
10267
10268     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
10269     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
10270     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
10271
10272     /* Clone the regex array */
10273     PL_regex_padav = newAV();
10274     {
10275         I32 len = av_len((AV*)proto_perl->Iregex_padav);
10276         SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10277         av_push(PL_regex_padav,
10278                 sv_dup_inc(regexen[0],param));
10279         for(i = 1; i <= len; i++) {
10280             if(SvREPADTMP(regexen[i])) {
10281               av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
10282             } else {
10283                 av_push(PL_regex_padav,
10284                     SvREFCNT_inc(
10285                         newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
10286                              SvIVX(regexen[i])), param)))
10287                        ));
10288             }
10289         }
10290     }
10291     PL_regex_pad = AvARRAY(PL_regex_padav);
10292
10293     /* shortcuts to various I/O objects */
10294     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
10295     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
10296     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
10297     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
10298     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
10299     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
10300
10301     /* shortcuts to regexp stuff */
10302     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
10303
10304     /* shortcuts to misc objects */
10305     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
10306
10307     /* shortcuts to debugging objects */
10308     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
10309     PL_DBline           = gv_dup(proto_perl->IDBline, param);
10310     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
10311     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
10312     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
10313     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
10314     PL_lineary          = av_dup(proto_perl->Ilineary, param);
10315     PL_dbargs           = av_dup(proto_perl->Idbargs, param);
10316
10317     /* symbol tables */
10318     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash, param);
10319     PL_curstash         = hv_dup(proto_perl->Tcurstash, param);
10320     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
10321     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
10322     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
10323
10324     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
10325     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
10326     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
10327     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
10328     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
10329     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
10330
10331     PL_sub_generation   = proto_perl->Isub_generation;
10332
10333     /* funky return mechanisms */
10334     PL_forkprocess      = proto_perl->Iforkprocess;
10335
10336     /* subprocess state */
10337     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
10338
10339     /* internal state */
10340     PL_tainting         = proto_perl->Itainting;
10341     PL_maxo             = proto_perl->Imaxo;
10342     if (proto_perl->Iop_mask)
10343         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10344     else
10345         PL_op_mask      = Nullch;
10346
10347     /* current interpreter roots */
10348     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
10349     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
10350     PL_main_start       = proto_perl->Imain_start;
10351     PL_eval_root        = proto_perl->Ieval_root;
10352     PL_eval_start       = proto_perl->Ieval_start;
10353
10354     /* runtime control stuff */
10355     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10356     PL_copline          = proto_perl->Icopline;
10357
10358     PL_filemode         = proto_perl->Ifilemode;
10359     PL_lastfd           = proto_perl->Ilastfd;
10360     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
10361     PL_Argv             = NULL;
10362     PL_Cmd              = Nullch;
10363     PL_gensym           = proto_perl->Igensym;
10364     PL_preambled        = proto_perl->Ipreambled;
10365     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
10366     PL_laststatval      = proto_perl->Ilaststatval;
10367     PL_laststype        = proto_perl->Ilaststype;
10368     PL_mess_sv          = Nullsv;
10369
10370     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
10371     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
10372
10373     /* interpreter atexit processing */
10374     PL_exitlistlen      = proto_perl->Iexitlistlen;
10375     if (PL_exitlistlen) {
10376         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10377         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10378     }
10379     else
10380         PL_exitlist     = (PerlExitListEntry*)NULL;
10381     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
10382     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
10383     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10384
10385     PL_profiledata      = NULL;
10386     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<', param);
10387     /* PL_rsfp_filters entries have fake IoDIRP() */
10388     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters, param);
10389
10390     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
10391
10392     PAD_CLONE_VARS(proto_perl, param);
10393
10394 #ifdef HAVE_INTERP_INTERN
10395     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10396 #endif
10397
10398     /* more statics moved here */
10399     PL_generation       = proto_perl->Igeneration;
10400     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
10401
10402     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
10403     PL_in_clean_all     = proto_perl->Iin_clean_all;
10404
10405     PL_uid              = proto_perl->Iuid;
10406     PL_euid             = proto_perl->Ieuid;
10407     PL_gid              = proto_perl->Igid;
10408     PL_egid             = proto_perl->Iegid;
10409     PL_nomemok          = proto_perl->Inomemok;
10410     PL_an               = proto_perl->Ian;
10411     PL_op_seqmax        = proto_perl->Iop_seqmax;
10412     PL_evalseq          = proto_perl->Ievalseq;
10413     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
10414     PL_origalen         = proto_perl->Iorigalen;
10415     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
10416     PL_osname           = SAVEPV(proto_perl->Iosname);
10417     PL_sh_path          = proto_perl->Ish_path; /* XXX never deallocated */
10418     PL_sighandlerp      = proto_perl->Isighandlerp;
10419
10420
10421     PL_runops           = proto_perl->Irunops;
10422
10423     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10424
10425 #ifdef CSH
10426     PL_cshlen           = proto_perl->Icshlen;
10427     PL_cshname          = proto_perl->Icshname; /* XXX never deallocated */
10428 #endif
10429
10430     PL_lex_state        = proto_perl->Ilex_state;
10431     PL_lex_defer        = proto_perl->Ilex_defer;
10432     PL_lex_expect       = proto_perl->Ilex_expect;
10433     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
10434     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
10435     PL_lex_starts       = proto_perl->Ilex_starts;
10436     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff, param);
10437     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl, param);
10438     PL_lex_op           = proto_perl->Ilex_op;
10439     PL_lex_inpat        = proto_perl->Ilex_inpat;
10440     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
10441     PL_lex_brackets     = proto_perl->Ilex_brackets;
10442     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10443     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
10444     PL_lex_casemods     = proto_perl->Ilex_casemods;
10445     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10446     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
10447
10448     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10449     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10450     PL_nexttoke         = proto_perl->Inexttoke;
10451
10452     /* XXX This is probably masking the deeper issue of why
10453      * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
10454      * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
10455      * (A little debugging with a watchpoint on it may help.)
10456      */
10457     if (SvANY(proto_perl->Ilinestr)) {
10458         PL_linestr              = sv_dup_inc(proto_perl->Ilinestr, param);
10459         i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
10460         PL_bufptr               = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10461         i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
10462         PL_oldbufptr    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10463         i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
10464         PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10465         i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
10466         PL_linestart    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10467     }
10468     else {
10469         PL_linestr = NEWSV(65,79);
10470         sv_upgrade(PL_linestr,SVt_PVIV);
10471         sv_setpvn(PL_linestr,"",0);
10472         PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
10473     }
10474     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10475     PL_pending_ident    = proto_perl->Ipending_ident;
10476     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
10477
10478     PL_expect           = proto_perl->Iexpect;
10479
10480     PL_multi_start      = proto_perl->Imulti_start;
10481     PL_multi_end        = proto_perl->Imulti_end;
10482     PL_multi_open       = proto_perl->Imulti_open;
10483     PL_multi_close      = proto_perl->Imulti_close;
10484
10485     PL_error_count      = proto_perl->Ierror_count;
10486     PL_subline          = proto_perl->Isubline;
10487     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
10488
10489     /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
10490     if (SvANY(proto_perl->Ilinestr)) {
10491         i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10492         PL_last_uni             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10493         i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10494         PL_last_lop             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10495         PL_last_lop_op  = proto_perl->Ilast_lop_op;
10496     }
10497     else {
10498         PL_last_uni     = SvPVX(PL_linestr);
10499         PL_last_lop     = SvPVX(PL_linestr);
10500         PL_last_lop_op  = 0;
10501     }
10502     PL_in_my            = proto_perl->Iin_my;
10503     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash, param);
10504 #ifdef FCRYPT
10505     PL_cryptseen        = proto_perl->Icryptseen;
10506 #endif
10507
10508     PL_hints            = proto_perl->Ihints;
10509
10510     PL_amagic_generation        = proto_perl->Iamagic_generation;
10511
10512 #ifdef USE_LOCALE_COLLATE
10513     PL_collation_ix     = proto_perl->Icollation_ix;
10514     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
10515     PL_collation_standard       = proto_perl->Icollation_standard;
10516     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
10517     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
10518 #endif /* USE_LOCALE_COLLATE */
10519
10520 #ifdef USE_LOCALE_NUMERIC
10521     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
10522     PL_numeric_standard = proto_perl->Inumeric_standard;
10523     PL_numeric_local    = proto_perl->Inumeric_local;
10524     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10525 #endif /* !USE_LOCALE_NUMERIC */
10526
10527     /* utf8 character classes */
10528     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10529     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10530     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10531     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10532     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
10533     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10534     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
10535     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
10536     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
10537     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
10538     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
10539     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
10540     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10541     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
10542     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10543     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10544     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10545     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
10546     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
10547     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
10548
10549     /* swatch cache */
10550     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
10551     PL_last_swash_klen  = 0;
10552     PL_last_swash_key[0]= '\0';
10553     PL_last_swash_tmps  = (U8*)NULL;
10554     PL_last_swash_slen  = 0;
10555
10556     /* perly.c globals */
10557     PL_yydebug          = proto_perl->Iyydebug;
10558     PL_yynerrs          = proto_perl->Iyynerrs;
10559     PL_yyerrflag        = proto_perl->Iyyerrflag;
10560     PL_yychar           = proto_perl->Iyychar;
10561     PL_yyval            = proto_perl->Iyyval;
10562     PL_yylval           = proto_perl->Iyylval;
10563
10564     PL_glob_index       = proto_perl->Iglob_index;
10565     PL_srand_called     = proto_perl->Isrand_called;
10566     PL_uudmap['M']      = 0;            /* reinits on demand */
10567     PL_bitcount         = Nullch;       /* reinits on demand */
10568
10569     if (proto_perl->Ipsig_pend) {
10570         Newz(0, PL_psig_pend, SIG_SIZE, int);
10571     }
10572     else {
10573         PL_psig_pend    = (int*)NULL;
10574     }
10575
10576     if (proto_perl->Ipsig_ptr) {
10577         Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
10578         Newz(0, PL_psig_name, SIG_SIZE, SV*);
10579         for (i = 1; i < SIG_SIZE; i++) {
10580             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10581             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10582         }
10583     }
10584     else {
10585         PL_psig_ptr     = (SV**)NULL;
10586         PL_psig_name    = (SV**)NULL;
10587     }
10588
10589     /* thrdvar.h stuff */
10590
10591     if (flags & CLONEf_COPY_STACKS) {
10592         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10593         PL_tmps_ix              = proto_perl->Ttmps_ix;
10594         PL_tmps_max             = proto_perl->Ttmps_max;
10595         PL_tmps_floor           = proto_perl->Ttmps_floor;
10596         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10597         i = 0;
10598         while (i <= PL_tmps_ix) {
10599             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10600             ++i;
10601         }
10602
10603         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10604         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10605         Newz(54, PL_markstack, i, I32);
10606         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
10607                                                   - proto_perl->Tmarkstack);
10608         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
10609                                                   - proto_perl->Tmarkstack);
10610         Copy(proto_perl->Tmarkstack, PL_markstack,
10611              PL_markstack_ptr - PL_markstack + 1, I32);
10612
10613         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10614          * NOTE: unlike the others! */
10615         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
10616         PL_scopestack_max       = proto_perl->Tscopestack_max;
10617         Newz(54, PL_scopestack, PL_scopestack_max, I32);
10618         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10619
10620         /* next push_return() sets PL_retstack[PL_retstack_ix]
10621          * NOTE: unlike the others! */
10622         PL_retstack_ix          = proto_perl->Tretstack_ix;
10623         PL_retstack_max         = proto_perl->Tretstack_max;
10624         Newz(54, PL_retstack, PL_retstack_max, OP*);
10625         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
10626
10627         /* NOTE: si_dup() looks at PL_markstack */
10628         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo, param);
10629
10630         /* PL_curstack          = PL_curstackinfo->si_stack; */
10631         PL_curstack             = av_dup(proto_perl->Tcurstack, param);
10632         PL_mainstack            = av_dup(proto_perl->Tmainstack, param);
10633
10634         /* next PUSHs() etc. set *(PL_stack_sp+1) */
10635         PL_stack_base           = AvARRAY(PL_curstack);
10636         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
10637                                                    - proto_perl->Tstack_base);
10638         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
10639
10640         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10641          * NOTE: unlike the others! */
10642         PL_savestack_ix         = proto_perl->Tsavestack_ix;
10643         PL_savestack_max        = proto_perl->Tsavestack_max;
10644         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10645         PL_savestack            = ss_dup(proto_perl, param);
10646     }
10647     else {
10648         init_stacks();
10649         ENTER;                  /* perl_destruct() wants to LEAVE; */
10650     }
10651
10652     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
10653     PL_top_env          = &PL_start_env;
10654
10655     PL_op               = proto_perl->Top;
10656
10657     PL_Sv               = Nullsv;
10658     PL_Xpv              = (XPV*)NULL;
10659     PL_na               = proto_perl->Tna;
10660
10661     PL_statbuf          = proto_perl->Tstatbuf;
10662     PL_statcache        = proto_perl->Tstatcache;
10663     PL_statgv           = gv_dup(proto_perl->Tstatgv, param);
10664     PL_statname         = sv_dup_inc(proto_perl->Tstatname, param);
10665 #ifdef HAS_TIMES
10666     PL_timesbuf         = proto_perl->Ttimesbuf;
10667 #endif
10668
10669     PL_tainted          = proto_perl->Ttainted;
10670     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
10671     PL_rs               = sv_dup_inc(proto_perl->Trs, param);
10672     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv, param);
10673     PL_ofs_sv           = sv_dup_inc(proto_perl->Tofs_sv, param);
10674     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv, param);
10675     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
10676     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget, param);
10677     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget, param);
10678     PL_formtarget       = sv_dup(proto_perl->Tformtarget, param);
10679
10680     PL_restartop        = proto_perl->Trestartop;
10681     PL_in_eval          = proto_perl->Tin_eval;
10682     PL_delaymagic       = proto_perl->Tdelaymagic;
10683     PL_dirty            = proto_perl->Tdirty;
10684     PL_localizing       = proto_perl->Tlocalizing;
10685
10686 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10687     PL_protect          = proto_perl->Tprotect;
10688 #endif
10689     PL_errors           = sv_dup_inc(proto_perl->Terrors, param);
10690     PL_av_fetch_sv      = Nullsv;
10691     PL_hv_fetch_sv      = Nullsv;
10692     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
10693     PL_modcount         = proto_perl->Tmodcount;
10694     PL_lastgotoprobe    = Nullop;
10695     PL_dumpindent       = proto_perl->Tdumpindent;
10696
10697     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10698     PL_sortstash        = hv_dup(proto_perl->Tsortstash, param);
10699     PL_firstgv          = gv_dup(proto_perl->Tfirstgv, param);
10700     PL_secondgv         = gv_dup(proto_perl->Tsecondgv, param);
10701     PL_sortcxix         = proto_perl->Tsortcxix;
10702     PL_efloatbuf        = Nullch;               /* reinits on demand */
10703     PL_efloatsize       = 0;                    /* reinits on demand */
10704
10705     /* regex stuff */
10706
10707     PL_screamfirst      = NULL;
10708     PL_screamnext       = NULL;
10709     PL_maxscream        = -1;                   /* reinits on demand */
10710     PL_lastscream       = Nullsv;
10711
10712     PL_watchaddr        = NULL;
10713     PL_watchok          = Nullch;
10714
10715     PL_regdummy         = proto_perl->Tregdummy;
10716     PL_regcomp_parse    = Nullch;
10717     PL_regxend          = Nullch;
10718     PL_regcode          = (regnode*)NULL;
10719     PL_regnaughty       = 0;
10720     PL_regsawback       = 0;
10721     PL_regprecomp       = Nullch;
10722     PL_regnpar          = 0;
10723     PL_regsize          = 0;
10724     PL_regflags         = 0;
10725     PL_regseen          = 0;
10726     PL_seen_zerolen     = 0;
10727     PL_seen_evals       = 0;
10728     PL_regcomp_rx       = (regexp*)NULL;
10729     PL_extralen         = 0;
10730     PL_colorset         = 0;            /* reinits PL_colors[] */
10731     /*PL_colors[6]      = {0,0,0,0,0,0};*/
10732     PL_reg_whilem_seen  = 0;
10733     PL_reginput         = Nullch;
10734     PL_regbol           = Nullch;
10735     PL_regeol           = Nullch;
10736     PL_regstartp        = (I32*)NULL;
10737     PL_regendp          = (I32*)NULL;
10738     PL_reglastparen     = (U32*)NULL;
10739     PL_regtill          = Nullch;
10740     PL_reg_start_tmp    = (char**)NULL;
10741     PL_reg_start_tmpl   = 0;
10742     PL_regdata          = (struct reg_data*)NULL;
10743     PL_bostr            = Nullch;
10744     PL_reg_flags        = 0;
10745     PL_reg_eval_set     = 0;
10746     PL_regnarrate       = 0;
10747     PL_regprogram       = (regnode*)NULL;
10748     PL_regindent        = 0;
10749     PL_regcc            = (CURCUR*)NULL;
10750     PL_reg_call_cc      = (struct re_cc_state*)NULL;
10751     PL_reg_re           = (regexp*)NULL;
10752     PL_reg_ganch        = Nullch;
10753     PL_reg_sv           = Nullsv;
10754     PL_reg_match_utf8   = FALSE;
10755     PL_reg_magic        = (MAGIC*)NULL;
10756     PL_reg_oldpos       = 0;
10757     PL_reg_oldcurpm     = (PMOP*)NULL;
10758     PL_reg_curpm        = (PMOP*)NULL;
10759     PL_reg_oldsaved     = Nullch;
10760     PL_reg_oldsavedlen  = 0;
10761     PL_reg_maxiter      = 0;
10762     PL_reg_leftiter     = 0;
10763     PL_reg_poscache     = Nullch;
10764     PL_reg_poscache_size= 0;
10765
10766     /* RE engine - function pointers */
10767     PL_regcompp         = proto_perl->Tregcompp;
10768     PL_regexecp         = proto_perl->Tregexecp;
10769     PL_regint_start     = proto_perl->Tregint_start;
10770     PL_regint_string    = proto_perl->Tregint_string;
10771     PL_regfree          = proto_perl->Tregfree;
10772
10773     PL_reginterp_cnt    = 0;
10774     PL_reg_starttry     = 0;
10775
10776     /* Pluggable optimizer */
10777     PL_peepp            = proto_perl->Tpeepp;
10778
10779     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10780         ptr_table_free(PL_ptr_table);
10781         PL_ptr_table = NULL;
10782     }
10783
10784     /* Call the ->CLONE method, if it exists, for each of the stashes
10785        identified by sv_dup() above.
10786     */
10787     while(av_len(param->stashes) != -1) {
10788         HV* stash = (HV*) av_shift(param->stashes);
10789         GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10790         if (cloner && GvCV(cloner)) {
10791             dSP;
10792             ENTER;
10793             SAVETMPS;
10794             PUSHMARK(SP);
10795            XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10796             PUTBACK;
10797             call_sv((SV*)GvCV(cloner), G_DISCARD);
10798             FREETMPS;
10799             LEAVE;
10800         }
10801     }
10802
10803     SvREFCNT_dec(param->stashes);
10804
10805     return my_perl;
10806 }
10807
10808 #endif /* USE_ITHREADS */
10809
10810 /*
10811 =head1 Unicode Support
10812
10813 =for apidoc sv_recode_to_utf8
10814
10815 The encoding is assumed to be an Encode object, on entry the PV
10816 of the sv is assumed to be octets in that encoding, and the sv
10817 will be converted into Unicode (and UTF-8).
10818
10819 If the sv already is UTF-8 (or if it is not POK), or if the encoding
10820 is not a reference, nothing is done to the sv.  If the encoding is not
10821 an C<Encode::XS> Encoding object, bad things will happen.
10822 (See F<lib/encoding.pm> and L<Encode>).
10823
10824 The PV of the sv is returned.
10825
10826 =cut */
10827
10828 char *
10829 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
10830 {
10831     if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
10832         int vary = FALSE;
10833         SV *uni;
10834         STRLEN len;
10835         char *s;
10836         dSP;
10837         ENTER;
10838         SAVETMPS;
10839         PUSHMARK(sp);
10840         EXTEND(SP, 3);
10841         XPUSHs(encoding);
10842         XPUSHs(sv);
10843 /*
10844   NI-S 2002/07/09
10845   Passing sv_yes is wrong - it needs to be or'ed set of constants
10846   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
10847   remove converted chars from source.
10848
10849   Both will default the value - let them.
10850
10851         XPUSHs(&PL_sv_yes);
10852 */
10853         PUTBACK;
10854         call_method("decode", G_SCALAR);
10855         SPAGAIN;
10856         uni = POPs;
10857         PUTBACK;
10858         s = SvPV(uni, len);
10859         {
10860             U8 *t = (U8 *)s, *e = (U8 *)s + len;
10861             while (t < e) {
10862                 if ((vary = !UTF8_IS_INVARIANT(*t++)))
10863                     break;
10864             }
10865         }
10866         if (s != SvPVX(sv)) {
10867             SvGROW(sv, len + 1);
10868             Move(s, SvPVX(sv), len, char);
10869             SvCUR_set(sv, len);
10870             SvPVX(sv)[len] = 0;
10871         }
10872         FREETMPS;
10873         LEAVE;
10874         if (vary)
10875             SvUTF8_on(sv);
10876         SvUTF8_on(sv);
10877     }
10878     return SvPVX(sv);
10879 }
10880
10881
10882