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