sv.c

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