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