sv.c

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