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