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