sv.c

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