sv.c

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