sv.c

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