sv.c

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