sv.c

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