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