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