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                    if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
6441                         cache[2] += *offsetp;
6442               }
6443               *lenp = s - start;
6444          }
6445          ASSERT_UTF8_CACHE(cache);
6446     }
6447     else {
6448          *offsetp = 0;
6449          if (lenp)
6450               *lenp = 0;
6451     }
6452
6453     return;
6454 }
6455
6456 /*
6457 =for apidoc sv_pos_b2u
6458
6459 Converts the value pointed to by offsetp from a count of bytes from the
6460 start of the string, to a count of the equivalent number of UTF-8 chars.
6461 Handles magic and type coercion.
6462
6463 =cut
6464 */
6465
6466 /*
6467  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6468  * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6469  * byte offsets.  See also the comments of S_utf8_mg_pos().
6470  *
6471  */
6472
6473 void
6474 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6475 {
6476     U8* s;
6477     STRLEN len;
6478
6479     if (!sv)
6480         return;
6481
6482     s = (U8*)SvPV(sv, len);
6483     if ((I32)len < *offsetp)
6484         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6485     else {
6486         U8* send = s + *offsetp;
6487         MAGIC* mg = NULL;
6488         STRLEN *cache = NULL;
6489
6490         len = 0;
6491
6492         if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6493             mg = mg_find(sv, PERL_MAGIC_utf8);
6494             if (mg && mg->mg_ptr) {
6495                 cache = (STRLEN *) mg->mg_ptr;
6496                 if (cache[1] == (STRLEN)*offsetp) {
6497                     /* An exact match. */
6498                     *offsetp = cache[0];
6499
6500                     return;
6501                 }
6502                 else if (cache[1] < (STRLEN)*offsetp) {
6503                     /* We already know part of the way. */
6504                     len = cache[0];
6505                     s  += cache[1];
6506                     /* Let the below loop do the rest. */
6507                 }
6508                 else { /* cache[1] > *offsetp */
6509                     /* We already know all of the way, now we may
6510                      * be able to walk back.  The same assumption
6511                      * is made as in S_utf8_mg_pos(), namely that
6512                      * walking backward is twice slower than
6513                      * walking forward. */
6514                     STRLEN forw  = *offsetp;
6515                     STRLEN backw = cache[1] - *offsetp;
6516
6517                     if (!(forw < 2 * backw)) {
6518                         U8 *p = s + cache[1];
6519                         STRLEN ubackw = 0;
6520
6521                         cache[1] -= backw;
6522
6523                         while (backw--) {
6524                             p--;
6525                             while (UTF8_IS_CONTINUATION(*p)) {
6526                                 p--;
6527                                 backw--;
6528                             }
6529                             ubackw++;
6530                         }
6531
6532                         cache[0] -= ubackw;
6533                         *offsetp = cache[0];
6534                         return;
6535                     }
6536                 }
6537             }
6538             ASSERT_UTF8_CACHE(cache);
6539         }
6540
6541         while (s < send) {
6542             STRLEN n = 1;
6543
6544             /* Call utf8n_to_uvchr() to validate the sequence
6545              * (unless a simple non-UTF character) */
6546             if (!UTF8_IS_INVARIANT(*s))
6547                 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6548             if (n > 0) {
6549                 s += n;
6550                 len++;
6551             }
6552             else
6553                 break;
6554         }
6555
6556         if (!SvREADONLY(sv)) {
6557             if (!mg) {
6558                 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6559                 mg = mg_find(sv, PERL_MAGIC_utf8);
6560             }
6561             assert(mg);
6562
6563             if (!mg->mg_ptr) {
6564                 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6565                 mg->mg_ptr = (char *) cache;
6566             }
6567             assert(cache);
6568
6569             cache[0] = len;
6570             cache[1] = *offsetp;
6571         }
6572
6573         *offsetp = len;
6574     }
6575     return;
6576 }
6577
6578 /*
6579 =for apidoc sv_eq
6580
6581 Returns a boolean indicating whether the strings in the two SVs are
6582 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6583 coerce its args to strings if necessary.
6584
6585 =cut
6586 */
6587
6588 I32
6589 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6590 {
6591     char *pv1;
6592     STRLEN cur1;
6593     char *pv2;
6594     STRLEN cur2;
6595     I32  eq     = 0;
6596     char *tpv   = Nullch;
6597     SV* svrecode = Nullsv;
6598
6599     if (!sv1) {
6600         pv1 = "";
6601         cur1 = 0;
6602     }
6603     else
6604         pv1 = SvPV(sv1, cur1);
6605
6606     if (!sv2){
6607         pv2 = "";
6608         cur2 = 0;
6609     }
6610     else
6611         pv2 = SvPV(sv2, cur2);
6612
6613     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6614         /* Differing utf8ness.
6615          * Do not UTF8size the comparands as a side-effect. */
6616          if (PL_encoding) {
6617               if (SvUTF8(sv1)) {
6618                    svrecode = newSVpvn(pv2, cur2);
6619                    sv_recode_to_utf8(svrecode, PL_encoding);
6620                    pv2 = SvPV(svrecode, cur2);
6621               }
6622               else {
6623                    svrecode = newSVpvn(pv1, cur1);
6624                    sv_recode_to_utf8(svrecode, PL_encoding);
6625                    pv1 = SvPV(svrecode, cur1);
6626               }
6627               /* Now both are in UTF-8. */
6628               if (cur1 != cur2)
6629                    return FALSE;
6630          }
6631          else {
6632               bool is_utf8 = TRUE;
6633
6634               if (SvUTF8(sv1)) {
6635                    /* sv1 is the UTF-8 one,
6636                     * if is equal it must be downgrade-able */
6637                    char *pv = (char*)bytes_from_utf8((U8*)pv1,
6638                                                      &cur1, &is_utf8);
6639                    if (pv != pv1)
6640                         pv1 = tpv = pv;
6641               }
6642               else {
6643                    /* sv2 is the UTF-8 one,
6644                     * if is equal it must be downgrade-able */
6645                    char *pv = (char *)bytes_from_utf8((U8*)pv2,
6646                                                       &cur2, &is_utf8);
6647                    if (pv != pv2)
6648                         pv2 = tpv = pv;
6649               }
6650               if (is_utf8) {
6651                    /* Downgrade not possible - cannot be eq */
6652                    return FALSE;
6653               }
6654          }
6655     }
6656
6657     if (cur1 == cur2)
6658         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6659
6660     if (svrecode)
6661          SvREFCNT_dec(svrecode);
6662
6663     if (tpv)
6664         Safefree(tpv);
6665
6666     return eq;
6667 }
6668
6669 /*
6670 =for apidoc sv_cmp
6671
6672 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
6673 string in C<sv1> is less than, equal to, or greater than the string in
6674 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6675 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
6676
6677 =cut
6678 */
6679
6680 I32
6681 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6682 {
6683     STRLEN cur1, cur2;
6684     char *pv1, *pv2, *tpv = Nullch;
6685     I32  cmp;
6686     SV *svrecode = Nullsv;
6687
6688     if (!sv1) {
6689         pv1 = "";
6690         cur1 = 0;
6691     }
6692     else
6693         pv1 = SvPV(sv1, cur1);
6694
6695     if (!sv2) {
6696         pv2 = "";
6697         cur2 = 0;
6698     }
6699     else
6700         pv2 = SvPV(sv2, cur2);
6701
6702     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6703         /* Differing utf8ness.
6704          * Do not UTF8size the comparands as a side-effect. */
6705         if (SvUTF8(sv1)) {
6706             if (PL_encoding) {
6707                  svrecode = newSVpvn(pv2, cur2);
6708                  sv_recode_to_utf8(svrecode, PL_encoding);
6709                  pv2 = SvPV(svrecode, cur2);
6710             }
6711             else {
6712                  pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
6713             }
6714         }
6715         else {
6716             if (PL_encoding) {
6717                  svrecode = newSVpvn(pv1, cur1);
6718                  sv_recode_to_utf8(svrecode, PL_encoding);
6719                  pv1 = SvPV(svrecode, cur1);
6720             }
6721             else {
6722                  pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
6723             }
6724         }
6725     }
6726
6727     if (!cur1) {
6728         cmp = cur2 ? -1 : 0;
6729     } else if (!cur2) {
6730         cmp = 1;
6731     } else {
6732         I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
6733
6734         if (retval) {
6735             cmp = retval < 0 ? -1 : 1;
6736         } else if (cur1 == cur2) {
6737             cmp = 0;
6738         } else {
6739             cmp = cur1 < cur2 ? -1 : 1;
6740         }
6741     }
6742
6743     if (svrecode)
6744          SvREFCNT_dec(svrecode);
6745
6746     if (tpv)
6747         Safefree(tpv);
6748
6749     return cmp;
6750 }
6751
6752 /*
6753 =for apidoc sv_cmp_locale
6754
6755 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6756 'use bytes' aware, handles get magic, and will coerce its args to strings
6757 if necessary.  See also C<sv_cmp_locale>.  See also C<sv_cmp>.
6758
6759 =cut
6760 */
6761
6762 I32
6763 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6764 {
6765 #ifdef USE_LOCALE_COLLATE
6766
6767     char *pv1, *pv2;
6768     STRLEN len1, len2;
6769     I32 retval;
6770
6771     if (PL_collation_standard)
6772         goto raw_compare;
6773
6774     len1 = 0;
6775     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6776     len2 = 0;
6777     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6778
6779     if (!pv1 || !len1) {
6780         if (pv2 && len2)
6781             return -1;
6782         else
6783             goto raw_compare;
6784     }
6785     else {
6786         if (!pv2 || !len2)
6787             return 1;
6788     }
6789
6790     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6791
6792     if (retval)
6793         return retval < 0 ? -1 : 1;
6794
6795     /*
6796      * When the result of collation is equality, that doesn't mean
6797      * that there are no differences -- some locales exclude some
6798      * characters from consideration.  So to avoid false equalities,
6799      * we use the raw string as a tiebreaker.
6800      */
6801
6802   raw_compare:
6803     /* FALL THROUGH */
6804
6805 #endif /* USE_LOCALE_COLLATE */
6806
6807     return sv_cmp(sv1, sv2);
6808 }
6809
6810
6811 #ifdef USE_LOCALE_COLLATE
6812
6813 /*
6814 =for apidoc sv_collxfrm
6815
6816 Add Collate Transform magic to an SV if it doesn't already have it.
6817
6818 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6819 scalar data of the variable, but transformed to such a format that a normal
6820 memory comparison can be used to compare the data according to the locale
6821 settings.
6822
6823 =cut
6824 */
6825
6826 char *
6827 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6828 {
6829     MAGIC *mg;
6830
6831     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6832     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6833         char *s, *xf;
6834         STRLEN len, xlen;
6835
6836         if (mg)
6837             Safefree(mg->mg_ptr);
6838         s = SvPV(sv, len);
6839         if ((xf = mem_collxfrm(s, len, &xlen))) {
6840             if (SvREADONLY(sv)) {
6841                 SAVEFREEPV(xf);
6842                 *nxp = xlen;
6843                 return xf + sizeof(PL_collation_ix);
6844             }
6845             if (! mg) {
6846                 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6847                 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6848                 assert(mg);
6849             }
6850             mg->mg_ptr = xf;
6851             mg->mg_len = xlen;
6852         }
6853         else {
6854             if (mg) {
6855                 mg->mg_ptr = NULL;
6856                 mg->mg_len = -1;
6857             }
6858         }
6859     }
6860     if (mg && mg->mg_ptr) {
6861         *nxp = mg->mg_len;
6862         return mg->mg_ptr + sizeof(PL_collation_ix);
6863     }
6864     else {
6865         *nxp = 0;
6866         return NULL;
6867     }
6868 }
6869
6870 #endif /* USE_LOCALE_COLLATE */
6871
6872 /*
6873 =for apidoc sv_gets
6874
6875 Get a line from the filehandle and store it into the SV, optionally
6876 appending to the currently-stored string.
6877
6878 =cut
6879 */
6880
6881 char *
6882 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6883 {
6884     char *rsptr;
6885     STRLEN rslen;
6886     register STDCHAR rslast;
6887     register STDCHAR *bp;
6888     register I32 cnt;
6889     I32 i = 0;
6890     I32 rspara = 0;
6891     I32 recsize;
6892
6893     if (SvTHINKFIRST(sv))
6894         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6895     /* XXX. If you make this PVIV, then copy on write can copy scalars read
6896        from <>.
6897        However, perlbench says it's slower, because the existing swipe code
6898        is faster than copy on write.
6899        Swings and roundabouts.  */
6900     (void)SvUPGRADE(sv, SVt_PV);
6901
6902     SvSCREAM_off(sv);
6903
6904     if (append) {
6905         if (PerlIO_isutf8(fp)) {
6906             if (!SvUTF8(sv)) {
6907                 sv_utf8_upgrade_nomg(sv);
6908                 sv_pos_u2b(sv,&append,0);
6909             }
6910         } else if (SvUTF8(sv)) {
6911             SV *tsv = NEWSV(0,0);
6912             sv_gets(tsv, fp, 0);
6913             sv_utf8_upgrade_nomg(tsv);
6914             SvCUR_set(sv,append);
6915             sv_catsv(sv,tsv);
6916             sv_free(tsv);
6917             goto return_string_or_null;
6918         }
6919     }
6920
6921     SvPOK_only(sv);
6922     if (PerlIO_isutf8(fp))
6923         SvUTF8_on(sv);
6924
6925     if (IN_PERL_COMPILETIME) {
6926         /* we always read code in line mode */
6927         rsptr = "\n";
6928         rslen = 1;
6929     }
6930     else if (RsSNARF(PL_rs)) {
6931         /* If it is a regular disk file use size from stat() as estimate
6932            of amount we are going to read - may result in malloc-ing
6933            more memory than we realy need if layers bellow reduce
6934            size we read (e.g. CRLF or a gzip layer)
6935          */
6936         Stat_t st;
6937         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
6938             Off_t offset = PerlIO_tell(fp);
6939             if (offset != (Off_t) -1 && st.st_size + append > offset) {
6940                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6941             }
6942         }
6943         rsptr = NULL;
6944         rslen = 0;
6945     }
6946     else if (RsRECORD(PL_rs)) {
6947       I32 bytesread;
6948       char *buffer;
6949
6950       /* Grab the size of the record we're getting */
6951       recsize = SvIV(SvRV(PL_rs));
6952       buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6953       /* Go yank in */
6954 #ifdef VMS
6955       /* VMS wants read instead of fread, because fread doesn't respect */
6956       /* RMS record boundaries. This is not necessarily a good thing to be */
6957       /* doing, but we've got no other real choice - except avoid stdio
6958          as implementation - perhaps write a :vms layer ?
6959        */
6960       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6961 #else
6962       bytesread = PerlIO_read(fp, buffer, recsize);
6963 #endif
6964       if (bytesread < 0)
6965           bytesread = 0;
6966       SvCUR_set(sv, bytesread += append);
6967       buffer[bytesread] = '\0';
6968       goto return_string_or_null;
6969     }
6970     else if (RsPARA(PL_rs)) {
6971         rsptr = "\n\n";
6972         rslen = 2;
6973         rspara = 1;
6974     }
6975     else {
6976         /* Get $/ i.e. PL_rs into same encoding as stream wants */
6977         if (PerlIO_isutf8(fp)) {
6978             rsptr = SvPVutf8(PL_rs, rslen);
6979         }
6980         else {
6981             if (SvUTF8(PL_rs)) {
6982                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6983                     Perl_croak(aTHX_ "Wide character in $/");
6984                 }
6985             }
6986             rsptr = SvPV(PL_rs, rslen);
6987         }
6988     }
6989
6990     rslast = rslen ? rsptr[rslen - 1] : '\0';
6991
6992     if (rspara) {               /* have to do this both before and after */
6993         do {                    /* to make sure file boundaries work right */
6994             if (PerlIO_eof(fp))
6995                 return 0;
6996             i = PerlIO_getc(fp);
6997             if (i != '\n') {
6998                 if (i == -1)
6999                     return 0;
7000                 PerlIO_ungetc(fp,i);
7001                 break;
7002             }
7003         } while (i != EOF);
7004     }
7005
7006     /* See if we know enough about I/O mechanism to cheat it ! */
7007
7008     /* This used to be #ifdef test - it is made run-time test for ease
7009        of abstracting out stdio interface. One call should be cheap
7010        enough here - and may even be a macro allowing compile
7011        time optimization.
7012      */
7013
7014     if (PerlIO_fast_gets(fp)) {
7015
7016     /*
7017      * We're going to steal some values from the stdio struct
7018      * and put EVERYTHING in the innermost loop into registers.
7019      */
7020     register STDCHAR *ptr;
7021     STRLEN bpx;
7022     I32 shortbuffered;
7023
7024 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7025     /* An ungetc()d char is handled separately from the regular
7026      * buffer, so we getc() it back out and stuff it in the buffer.
7027      */
7028     i = PerlIO_getc(fp);
7029     if (i == EOF) return 0;
7030     *(--((*fp)->_ptr)) = (unsigned char) i;
7031     (*fp)->_cnt++;
7032 #endif
7033
7034     /* Here is some breathtakingly efficient cheating */
7035
7036     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
7037     /* make sure we have the room */
7038     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7039         /* Not room for all of it
7040            if we are looking for a separator and room for some
7041          */
7042         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7043             /* just process what we have room for */
7044             shortbuffered = cnt - SvLEN(sv) + append + 1;
7045             cnt -= shortbuffered;
7046         }
7047         else {
7048             shortbuffered = 0;
7049             /* remember that cnt can be negative */
7050             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7051         }
7052     }
7053     else
7054         shortbuffered = 0;
7055     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
7056     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7057     DEBUG_P(PerlIO_printf(Perl_debug_log,
7058         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7059     DEBUG_P(PerlIO_printf(Perl_debug_log,
7060         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7061                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7062                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7063     for (;;) {
7064       screamer:
7065         if (cnt > 0) {
7066             if (rslen) {
7067                 while (cnt > 0) {                    /* this     |  eat */
7068                     cnt--;
7069                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
7070                         goto thats_all_folks;        /* screams  |  sed :-) */
7071                 }
7072             }
7073             else {
7074                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
7075                 bp += cnt;                           /* screams  |  dust */
7076                 ptr += cnt;                          /* louder   |  sed :-) */
7077                 cnt = 0;
7078             }
7079         }
7080
7081         if (shortbuffered) {            /* oh well, must extend */
7082             cnt = shortbuffered;
7083             shortbuffered = 0;
7084             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7085             SvCUR_set(sv, bpx);
7086             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7087             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7088             continue;
7089         }
7090
7091         DEBUG_P(PerlIO_printf(Perl_debug_log,
7092                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7093                               PTR2UV(ptr),(long)cnt));
7094         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7095 #if 0
7096         DEBUG_P(PerlIO_printf(Perl_debug_log,
7097             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7098             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7099             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7100 #endif
7101         /* This used to call 'filbuf' in stdio form, but as that behaves like
7102            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7103            another abstraction.  */
7104         i   = PerlIO_getc(fp);          /* get more characters */
7105 #if 0
7106         DEBUG_P(PerlIO_printf(Perl_debug_log,
7107             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7108             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7109             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7110 #endif
7111         cnt = PerlIO_get_cnt(fp);
7112         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
7113         DEBUG_P(PerlIO_printf(Perl_debug_log,
7114             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7115
7116         if (i == EOF)                   /* all done for ever? */
7117             goto thats_really_all_folks;
7118
7119         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7120         SvCUR_set(sv, bpx);
7121         SvGROW(sv, bpx + cnt + 2);
7122         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7123
7124         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
7125
7126         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
7127             goto thats_all_folks;
7128     }
7129
7130 thats_all_folks:
7131     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
7132           memNE((char*)bp - rslen, rsptr, rslen))
7133         goto screamer;                          /* go back to the fray */
7134 thats_really_all_folks:
7135     if (shortbuffered)
7136         cnt += shortbuffered;
7137         DEBUG_P(PerlIO_printf(Perl_debug_log,
7138             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7139     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
7140     DEBUG_P(PerlIO_printf(Perl_debug_log,
7141         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7142         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7143         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7144     *bp = '\0';
7145     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
7146     DEBUG_P(PerlIO_printf(Perl_debug_log,
7147         "Screamer: done, len=%ld, string=|%.*s|\n",
7148         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
7149     }
7150    else
7151     {
7152        /*The big, slow, and stupid way. */
7153
7154       /* Any stack-challenged places. */
7155 #if defined(EPOC)
7156       /* EPOC: need to work around SDK features.         *
7157        * On WINS: MS VC5 generates calls to _chkstk,     *
7158        * if a "large" stack frame is allocated.          *
7159        * gcc on MARM does not generate calls like these. */
7160 #   define USEHEAPINSTEADOFSTACK
7161 #endif
7162
7163 #ifdef USEHEAPINSTEADOFSTACK
7164         STDCHAR *buf = 0;
7165         New(0, buf, 8192, STDCHAR);
7166         assert(buf);
7167 #else
7168         STDCHAR buf[8192];
7169 #endif
7170
7171 screamer2:
7172         if (rslen) {
7173             register STDCHAR *bpe = buf + sizeof(buf);
7174             bp = buf;
7175             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7176                 ; /* keep reading */
7177             cnt = bp - buf;
7178         }
7179         else {
7180             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7181             /* Accomodate broken VAXC compiler, which applies U8 cast to
7182              * both args of ?: operator, causing EOF to change into 255
7183              */
7184             if (cnt > 0)
7185                  i = (U8)buf[cnt - 1];
7186             else
7187                  i = EOF;
7188         }
7189
7190         if (cnt < 0)
7191             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
7192         if (append)
7193              sv_catpvn(sv, (char *) buf, cnt);
7194         else
7195              sv_setpvn(sv, (char *) buf, cnt);
7196
7197         if (i != EOF &&                 /* joy */
7198             (!rslen ||
7199              SvCUR(sv) < rslen ||
7200              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7201         {
7202             append = -1;
7203             /*
7204              * If we're reading from a TTY and we get a short read,
7205              * indicating that the user hit his EOF character, we need
7206              * to notice it now, because if we try to read from the TTY
7207              * again, the EOF condition will disappear.
7208              *
7209              * The comparison of cnt to sizeof(buf) is an optimization
7210              * that prevents unnecessary calls to feof().
7211              *
7212              * - jik 9/25/96
7213              */
7214             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
7215                 goto screamer2;
7216         }
7217
7218 #ifdef USEHEAPINSTEADOFSTACK
7219         Safefree(buf);
7220 #endif
7221     }
7222
7223     if (rspara) {               /* have to do this both before and after */
7224         while (i != EOF) {      /* to make sure file boundaries work right */
7225             i = PerlIO_getc(fp);
7226             if (i != '\n') {
7227                 PerlIO_ungetc(fp,i);
7228                 break;
7229             }
7230         }
7231     }
7232
7233 return_string_or_null:
7234     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
7235 }
7236
7237 /*
7238 =for apidoc sv_inc
7239
7240 Auto-increment of the value in the SV, doing string to numeric conversion
7241 if necessary. Handles 'get' magic.
7242
7243 =cut
7244 */
7245
7246 void
7247 Perl_sv_inc(pTHX_ register SV *sv)
7248 {
7249     register char *d;
7250     int flags;
7251
7252     if (!sv)
7253         return;
7254     if (SvGMAGICAL(sv))
7255         mg_get(sv);
7256     if (SvTHINKFIRST(sv)) {
7257         if (SvIsCOW(sv))
7258             sv_force_normal_flags(sv, 0);
7259         if (SvREADONLY(sv)) {
7260             if (IN_PERL_RUNTIME)
7261                 Perl_croak(aTHX_ PL_no_modify);
7262         }
7263         if (SvROK(sv)) {
7264             IV i;
7265             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7266                 return;
7267             i = PTR2IV(SvRV(sv));
7268             sv_unref(sv);
7269             sv_setiv(sv, i);
7270         }
7271     }
7272     flags = SvFLAGS(sv);
7273     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7274         /* It's (privately or publicly) a float, but not tested as an
7275            integer, so test it to see. */
7276         (void) SvIV(sv);
7277         flags = SvFLAGS(sv);
7278     }
7279     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7280         /* It's publicly an integer, or privately an integer-not-float */
7281 #ifdef PERL_PRESERVE_IVUV
7282       oops_its_int:
7283 #endif
7284         if (SvIsUV(sv)) {
7285             if (SvUVX(sv) == UV_MAX)
7286                 sv_setnv(sv, UV_MAX_P1);
7287             else
7288                 (void)SvIOK_only_UV(sv);
7289                 ++SvUVX(sv);
7290         } else {
7291             if (SvIVX(sv) == IV_MAX)
7292                 sv_setuv(sv, (UV)IV_MAX + 1);
7293             else {
7294                 (void)SvIOK_only(sv);
7295                 ++SvIVX(sv);
7296             }
7297         }
7298         return;
7299     }
7300     if (flags & SVp_NOK) {
7301         (void)SvNOK_only(sv);
7302         SvNVX(sv) += 1.0;
7303         return;
7304     }
7305
7306     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
7307         if ((flags & SVTYPEMASK) < SVt_PVIV)
7308             sv_upgrade(sv, SVt_IV);
7309         (void)SvIOK_only(sv);
7310         SvIVX(sv) = 1;
7311         return;
7312     }
7313     d = SvPVX(sv);
7314     while (isALPHA(*d)) d++;
7315     while (isDIGIT(*d)) d++;
7316     if (*d) {
7317 #ifdef PERL_PRESERVE_IVUV
7318         /* Got to punt this as an integer if needs be, but we don't issue
7319            warnings. Probably ought to make the sv_iv_please() that does
7320            the conversion if possible, and silently.  */
7321         int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7322         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7323             /* Need to try really hard to see if it's an integer.
7324                9.22337203685478e+18 is an integer.
7325                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7326                so $a="9.22337203685478e+18"; $a+0; $a++
7327                needs to be the same as $a="9.22337203685478e+18"; $a++
7328                or we go insane. */
7329
7330             (void) sv_2iv(sv);
7331             if (SvIOK(sv))
7332                 goto oops_its_int;
7333
7334             /* sv_2iv *should* have made this an NV */
7335             if (flags & SVp_NOK) {
7336                 (void)SvNOK_only(sv);
7337                 SvNVX(sv) += 1.0;
7338                 return;
7339             }
7340             /* I don't think we can get here. Maybe I should assert this
7341                And if we do get here I suspect that sv_setnv will croak. NWC
7342                Fall through. */
7343 #if defined(USE_LONG_DOUBLE)
7344             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",
7345                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7346 #else
7347             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7348                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7349 #endif
7350         }
7351 #endif /* PERL_PRESERVE_IVUV */
7352         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
7353         return;
7354     }
7355     d--;
7356     while (d >= SvPVX(sv)) {
7357         if (isDIGIT(*d)) {
7358             if (++*d <= '9')
7359                 return;
7360             *(d--) = '0';
7361         }
7362         else {
7363 #ifdef EBCDIC
7364             /* MKS: The original code here died if letters weren't consecutive.
7365              * at least it didn't have to worry about non-C locales.  The
7366              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7367              * arranged in order (although not consecutively) and that only
7368              * [A-Za-z] are accepted by isALPHA in the C locale.
7369              */
7370             if (*d != 'z' && *d != 'Z') {
7371                 do { ++*d; } while (!isALPHA(*d));
7372                 return;
7373             }
7374             *(d--) -= 'z' - 'a';
7375 #else
7376             ++*d;
7377             if (isALPHA(*d))
7378                 return;
7379             *(d--) -= 'z' - 'a' + 1;
7380 #endif
7381         }
7382     }
7383     /* oh,oh, the number grew */
7384     SvGROW(sv, SvCUR(sv) + 2);
7385     SvCUR(sv)++;
7386     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
7387         *d = d[-1];
7388     if (isDIGIT(d[1]))
7389         *d = '1';
7390     else
7391         *d = d[1];
7392 }
7393
7394 /*
7395 =for apidoc sv_dec
7396
7397 Auto-decrement of the value in the SV, doing string to numeric conversion
7398 if necessary. Handles 'get' magic.
7399
7400 =cut
7401 */
7402
7403 void
7404 Perl_sv_dec(pTHX_ register SV *sv)
7405 {
7406     int flags;
7407
7408     if (!sv)
7409         return;
7410     if (SvGMAGICAL(sv))
7411         mg_get(sv);
7412     if (SvTHINKFIRST(sv)) {
7413         if (SvIsCOW(sv))
7414             sv_force_normal_flags(sv, 0);
7415         if (SvREADONLY(sv)) {
7416             if (IN_PERL_RUNTIME)
7417                 Perl_croak(aTHX_ PL_no_modify);
7418         }
7419         if (SvROK(sv)) {
7420             IV i;
7421             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7422                 return;
7423             i = PTR2IV(SvRV(sv));
7424             sv_unref(sv);
7425             sv_setiv(sv, i);
7426         }
7427     }
7428     /* Unlike sv_inc we don't have to worry about string-never-numbers
7429        and keeping them magic. But we mustn't warn on punting */
7430     flags = SvFLAGS(sv);
7431     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7432         /* It's publicly an integer, or privately an integer-not-float */
7433 #ifdef PERL_PRESERVE_IVUV
7434       oops_its_int:
7435 #endif
7436         if (SvIsUV(sv)) {
7437             if (SvUVX(sv) == 0) {
7438                 (void)SvIOK_only(sv);
7439                 SvIVX(sv) = -1;
7440             }
7441             else {
7442                 (void)SvIOK_only_UV(sv);
7443                 --SvUVX(sv);
7444             }
7445         } else {
7446             if (SvIVX(sv) == IV_MIN)
7447                 sv_setnv(sv, (NV)IV_MIN - 1.0);
7448             else {
7449                 (void)SvIOK_only(sv);
7450                 --SvIVX(sv);
7451             }
7452         }
7453         return;
7454     }
7455     if (flags & SVp_NOK) {
7456         SvNVX(sv) -= 1.0;
7457         (void)SvNOK_only(sv);
7458         return;
7459     }
7460     if (!(flags & SVp_POK)) {
7461         if ((flags & SVTYPEMASK) < SVt_PVNV)
7462             sv_upgrade(sv, SVt_NV);
7463         SvNVX(sv) = -1.0;
7464         (void)SvNOK_only(sv);
7465         return;
7466     }
7467 #ifdef PERL_PRESERVE_IVUV
7468     {
7469         int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7470         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7471             /* Need to try really hard to see if it's an integer.
7472                9.22337203685478e+18 is an integer.
7473                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7474                so $a="9.22337203685478e+18"; $a+0; $a--
7475                needs to be the same as $a="9.22337203685478e+18"; $a--
7476                or we go insane. */
7477
7478             (void) sv_2iv(sv);
7479             if (SvIOK(sv))
7480                 goto oops_its_int;
7481
7482             /* sv_2iv *should* have made this an NV */
7483             if (flags & SVp_NOK) {
7484                 (void)SvNOK_only(sv);
7485                 SvNVX(sv) -= 1.0;
7486                 return;
7487             }
7488             /* I don't think we can get here. Maybe I should assert this
7489                And if we do get here I suspect that sv_setnv will croak. NWC
7490                Fall through. */
7491 #if defined(USE_LONG_DOUBLE)
7492             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",
7493                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7494 #else
7495             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7496                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7497 #endif
7498         }
7499     }
7500 #endif /* PERL_PRESERVE_IVUV */
7501     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
7502 }
7503
7504 /*
7505 =for apidoc sv_mortalcopy
7506
7507 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7508 The new SV is marked as mortal. It will be destroyed "soon", either by an
7509 explicit call to FREETMPS, or by an implicit call at places such as
7510 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
7511
7512 =cut
7513 */
7514
7515 /* Make a string that will exist for the duration of the expression
7516  * evaluation.  Actually, it may have to last longer than that, but
7517  * hopefully we won't free it until it has been assigned to a
7518  * permanent location. */
7519
7520 SV *
7521 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7522 {
7523     register SV *sv;
7524
7525     new_SV(sv);
7526     sv_setsv(sv,oldstr);
7527     EXTEND_MORTAL(1);
7528     PL_tmps_stack[++PL_tmps_ix] = sv;
7529     SvTEMP_on(sv);
7530     return sv;
7531 }
7532
7533 /*
7534 =for apidoc sv_newmortal
7535
7536 Creates a new null SV which is mortal.  The reference count of the SV is
7537 set to 1. It will be destroyed "soon", either by an explicit call to
7538 FREETMPS, or by an implicit call at places such as statement boundaries.
7539 See also C<sv_mortalcopy> and C<sv_2mortal>.
7540
7541 =cut
7542 */
7543
7544 SV *
7545 Perl_sv_newmortal(pTHX)
7546 {
7547     register SV *sv;
7548
7549     new_SV(sv);
7550     SvFLAGS(sv) = SVs_TEMP;
7551     EXTEND_MORTAL(1);
7552     PL_tmps_stack[++PL_tmps_ix] = sv;
7553     return sv;
7554 }
7555
7556 /*
7557 =for apidoc sv_2mortal
7558
7559 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
7560 by an explicit call to FREETMPS, or by an implicit call at places such as
7561 statement boundaries.  See also C<sv_newmortal> and C<sv_mortalcopy>.
7562
7563 =cut
7564 */
7565
7566 SV *
7567 Perl_sv_2mortal(pTHX_ register SV *sv)
7568 {
7569     if (!sv)
7570         return sv;
7571     if (SvREADONLY(sv) && SvIMMORTAL(sv))
7572         return sv;
7573     EXTEND_MORTAL(1);
7574     PL_tmps_stack[++PL_tmps_ix] = sv;
7575     SvTEMP_on(sv);
7576     return sv;
7577 }
7578
7579 /*
7580 =for apidoc newSVpv
7581
7582 Creates a new SV and copies a string into it.  The reference count for the
7583 SV is set to 1.  If C<len> is zero, Perl will compute the length using
7584 strlen().  For efficiency, consider using C<newSVpvn> instead.
7585
7586 =cut
7587 */
7588
7589 SV *
7590 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7591 {
7592     register SV *sv;
7593
7594     new_SV(sv);
7595     if (!len)
7596         len = strlen(s);
7597     sv_setpvn(sv,s,len);
7598     return sv;
7599 }
7600
7601 /*
7602 =for apidoc newSVpvn
7603
7604 Creates a new SV and copies a string into it.  The reference count for the
7605 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7606 string.  You are responsible for ensuring that the source string is at least
7607 C<len> bytes long.
7608
7609 =cut
7610 */
7611
7612 SV *
7613 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7614 {
7615     register SV *sv;
7616
7617     new_SV(sv);
7618     sv_setpvn(sv,s,len);
7619     return sv;
7620 }
7621
7622 /*
7623 =for apidoc newSVpvn_share
7624
7625 Creates a new SV with its SvPVX pointing to a shared string in the string
7626 table. If the string does not already exist in the table, it is created
7627 first.  Turns on READONLY and FAKE.  The string's hash is stored in the UV
7628 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7629 otherwise the hash is computed.  The idea here is that as the string table
7630 is used for shared hash keys these strings will have SvPVX == HeKEY and
7631 hash lookup will avoid string compare.
7632
7633 =cut
7634 */
7635
7636 SV *
7637 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7638 {
7639     register SV *sv;
7640     bool is_utf8 = FALSE;
7641     if (len < 0) {
7642         STRLEN tmplen = -len;
7643         is_utf8 = TRUE;
7644         /* See the note in hv.c:hv_fetch() --jhi */
7645         src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
7646         len = tmplen;
7647     }
7648     if (!hash)
7649         PERL_HASH(hash, src, len);
7650     new_SV(sv);
7651     sv_upgrade(sv, SVt_PVIV);
7652     SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
7653     SvCUR(sv) = len;
7654     SvUVX(sv) = hash;
7655     SvLEN(sv) = 0;
7656     SvREADONLY_on(sv);
7657     SvFAKE_on(sv);
7658     SvPOK_on(sv);
7659     if (is_utf8)
7660         SvUTF8_on(sv);
7661     return sv;
7662 }
7663
7664
7665 #if defined(PERL_IMPLICIT_CONTEXT)
7666
7667 /* pTHX_ magic can't cope with varargs, so this is a no-context
7668  * version of the main function, (which may itself be aliased to us).
7669  * Don't access this version directly.
7670  */
7671
7672 SV *
7673 Perl_newSVpvf_nocontext(const char* pat, ...)
7674 {
7675     dTHX;
7676     register SV *sv;
7677     va_list args;
7678     va_start(args, pat);
7679     sv = vnewSVpvf(pat, &args);
7680     va_end(args);
7681     return sv;
7682 }
7683 #endif
7684
7685 /*
7686 =for apidoc newSVpvf
7687
7688 Creates a new SV and initializes it with the string formatted like
7689 C<sprintf>.
7690
7691 =cut
7692 */
7693
7694 SV *
7695 Perl_newSVpvf(pTHX_ const char* pat, ...)
7696 {
7697     register SV *sv;
7698     va_list args;
7699     va_start(args, pat);
7700     sv = vnewSVpvf(pat, &args);
7701     va_end(args);
7702     return sv;
7703 }
7704
7705 /* backend for newSVpvf() and newSVpvf_nocontext() */
7706
7707 SV *
7708 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7709 {
7710     register SV *sv;
7711     new_SV(sv);
7712     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7713     return sv;
7714 }
7715
7716 /*
7717 =for apidoc newSVnv
7718
7719 Creates a new SV and copies a floating point value into it.
7720 The reference count for the SV is set to 1.
7721
7722 =cut
7723 */
7724
7725 SV *
7726 Perl_newSVnv(pTHX_ NV n)
7727 {
7728     register SV *sv;
7729
7730     new_SV(sv);
7731     sv_setnv(sv,n);
7732     return sv;
7733 }
7734
7735 /*
7736 =for apidoc newSViv
7737
7738 Creates a new SV and copies an integer into it.  The reference count for the
7739 SV is set to 1.
7740
7741 =cut
7742 */
7743
7744 SV *
7745 Perl_newSViv(pTHX_ IV i)
7746 {
7747     register SV *sv;
7748
7749     new_SV(sv);
7750     sv_setiv(sv,i);
7751     return sv;
7752 }
7753
7754 /*
7755 =for apidoc newSVuv
7756
7757 Creates a new SV and copies an unsigned integer into it.
7758 The reference count for the SV is set to 1.
7759
7760 =cut
7761 */
7762
7763 SV *
7764 Perl_newSVuv(pTHX_ UV u)
7765 {
7766     register SV *sv;
7767
7768     new_SV(sv);
7769     sv_setuv(sv,u);
7770     return sv;
7771 }
7772
7773 /*
7774 =for apidoc newRV_noinc
7775
7776 Creates an RV wrapper for an SV.  The reference count for the original
7777 SV is B<not> incremented.
7778
7779 =cut
7780 */
7781
7782 SV *
7783 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7784 {
7785     register SV *sv;
7786
7787     new_SV(sv);
7788     sv_upgrade(sv, SVt_RV);
7789     SvTEMP_off(tmpRef);
7790     SvRV(sv) = tmpRef;
7791     SvROK_on(sv);
7792     return sv;
7793 }
7794
7795 /* newRV_inc is the official function name to use now.
7796  * newRV_inc is in fact #defined to newRV in sv.h
7797  */
7798
7799 SV *
7800 Perl_newRV(pTHX_ SV *tmpRef)
7801 {
7802     return newRV_noinc(SvREFCNT_inc(tmpRef));
7803 }
7804
7805 /*
7806 =for apidoc newSVsv
7807
7808 Creates a new SV which is an exact duplicate of the original SV.
7809 (Uses C<sv_setsv>).
7810
7811 =cut
7812 */
7813
7814 SV *
7815 Perl_newSVsv(pTHX_ register SV *old)
7816 {
7817     register SV *sv;
7818
7819     if (!old)
7820         return Nullsv;
7821     if (SvTYPE(old) == SVTYPEMASK) {
7822         if (ckWARN_d(WARN_INTERNAL))
7823             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7824         return Nullsv;
7825     }
7826     new_SV(sv);
7827     if (SvTEMP(old)) {
7828         SvTEMP_off(old);
7829         sv_setsv(sv,old);
7830         SvTEMP_on(old);
7831     }
7832     else
7833         sv_setsv(sv,old);
7834     return sv;
7835 }
7836
7837 /*
7838 =for apidoc sv_reset
7839
7840 Underlying implementation for the C<reset> Perl function.
7841 Note that the perl-level function is vaguely deprecated.
7842
7843 =cut
7844 */
7845
7846 void
7847 Perl_sv_reset(pTHX_ register char *s, HV *stash)
7848 {
7849     register HE *entry;
7850     register GV *gv;
7851     register SV *sv;
7852     register I32 i;
7853     register PMOP *pm;
7854     register I32 max;
7855     char todo[PERL_UCHAR_MAX+1];
7856
7857     if (!stash)
7858         return;
7859
7860     if (!*s) {          /* reset ?? searches */
7861         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7862             pm->op_pmdynflags &= ~PMdf_USED;
7863         }
7864         return;
7865     }
7866
7867     /* reset variables */
7868
7869     if (!HvARRAY(stash))
7870         return;
7871
7872     Zero(todo, 256, char);
7873     while (*s) {
7874         i = (unsigned char)*s;
7875         if (s[1] == '-') {
7876             s += 2;
7877         }
7878         max = (unsigned char)*s++;
7879         for ( ; i <= max; i++) {
7880             todo[i] = 1;
7881         }
7882         for (i = 0; i <= (I32) HvMAX(stash); i++) {
7883             for (entry = HvARRAY(stash)[i];
7884                  entry;
7885                  entry = HeNEXT(entry))
7886             {
7887                 if (!todo[(U8)*HeKEY(entry)])
7888                     continue;
7889                 gv = (GV*)HeVAL(entry);
7890                 sv = GvSV(gv);
7891                 if (SvTHINKFIRST(sv)) {
7892                     if (!SvREADONLY(sv) && SvROK(sv))
7893                         sv_unref(sv);
7894                     continue;
7895                 }
7896                 (void)SvOK_off(sv);
7897                 if (SvTYPE(sv) >= SVt_PV) {
7898                     SvCUR_set(sv, 0);
7899                     if (SvPVX(sv) != Nullch)
7900                         *SvPVX(sv) = '\0';
7901                     SvTAINT(sv);
7902                 }
7903                 if (GvAV(gv)) {
7904                     av_clear(GvAV(gv));
7905                 }
7906                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7907                     hv_clear(GvHV(gv));
7908 #ifndef PERL_MICRO
7909 #ifdef USE_ENVIRON_ARRAY
7910                     if (gv == PL_envgv
7911 #  ifdef USE_ITHREADS
7912                         && PL_curinterp == aTHX
7913 #  endif
7914                     )
7915                     {
7916                         environ[0] = Nullch;
7917                     }
7918 #endif
7919 #endif /* !PERL_MICRO */
7920                 }
7921             }
7922         }
7923     }
7924 }
7925
7926 /*
7927 =for apidoc sv_2io
7928
7929 Using various gambits, try to get an IO from an SV: the IO slot if its a
7930 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7931 named after the PV if we're a string.
7932
7933 =cut
7934 */
7935
7936 IO*
7937 Perl_sv_2io(pTHX_ SV *sv)
7938 {
7939     IO* io;
7940     GV* gv;
7941     STRLEN n_a;
7942
7943     switch (SvTYPE(sv)) {
7944     case SVt_PVIO:
7945         io = (IO*)sv;
7946         break;
7947     case SVt_PVGV:
7948         gv = (GV*)sv;
7949         io = GvIO(gv);
7950         if (!io)
7951             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7952         break;
7953     default:
7954         if (!SvOK(sv))
7955             Perl_croak(aTHX_ PL_no_usym, "filehandle");
7956         if (SvROK(sv))
7957             return sv_2io(SvRV(sv));
7958         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
7959         if (gv)
7960             io = GvIO(gv);
7961         else
7962             io = 0;
7963         if (!io)
7964             Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7965         break;
7966     }
7967     return io;
7968 }
7969
7970 /*
7971 =for apidoc sv_2cv
7972
7973 Using various gambits, try to get a CV from an SV; in addition, try if
7974 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7975
7976 =cut
7977 */
7978
7979 CV *
7980 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7981 {
7982     GV *gv = Nullgv;
7983     CV *cv = Nullcv;
7984     STRLEN n_a;
7985
7986     if (!sv)
7987         return *gvp = Nullgv, Nullcv;
7988     switch (SvTYPE(sv)) {
7989     case SVt_PVCV:
7990         *st = CvSTASH(sv);
7991         *gvp = Nullgv;
7992         return (CV*)sv;
7993     case SVt_PVHV:
7994     case SVt_PVAV:
7995         *gvp = Nullgv;
7996         return Nullcv;
7997     case SVt_PVGV:
7998         gv = (GV*)sv;
7999         *gvp = gv;
8000         *st = GvESTASH(gv);
8001         goto fix_gv;
8002
8003     default:
8004         if (SvGMAGICAL(sv))
8005             mg_get(sv);
8006         if (SvROK(sv)) {
8007             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
8008             tryAMAGICunDEREF(to_cv);
8009
8010             sv = SvRV(sv);
8011             if (SvTYPE(sv) == SVt_PVCV) {
8012                 cv = (CV*)sv;
8013                 *gvp = Nullgv;
8014                 *st = CvSTASH(cv);
8015                 return cv;
8016             }
8017             else if(isGV(sv))
8018                 gv = (GV*)sv;
8019             else
8020                 Perl_croak(aTHX_ "Not a subroutine reference");
8021         }
8022         else if (isGV(sv))
8023             gv = (GV*)sv;
8024         else
8025             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
8026         *gvp = gv;
8027         if (!gv)
8028             return Nullcv;
8029         *st = GvESTASH(gv);
8030     fix_gv:
8031         if (lref && !GvCVu(gv)) {
8032             SV *tmpsv;
8033             ENTER;
8034             tmpsv = NEWSV(704,0);
8035             gv_efullname3(tmpsv, gv, Nullch);
8036             /* XXX this is probably not what they think they're getting.
8037              * It has the same effect as "sub name;", i.e. just a forward
8038              * declaration! */
8039             newSUB(start_subparse(FALSE, 0),
8040                    newSVOP(OP_CONST, 0, tmpsv),
8041                    Nullop,
8042                    Nullop);
8043             LEAVE;
8044             if (!GvCVu(gv))
8045                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8046                            sv);
8047         }
8048         return GvCVu(gv);
8049     }
8050 }
8051
8052 /*
8053 =for apidoc sv_true
8054
8055 Returns true if the SV has a true value by Perl's rules.
8056 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8057 instead use an in-line version.
8058
8059 =cut
8060 */
8061
8062 I32
8063 Perl_sv_true(pTHX_ register SV *sv)
8064 {
8065     if (!sv)
8066         return 0;
8067     if (SvPOK(sv)) {
8068         register XPV* tXpv;
8069         if ((tXpv = (XPV*)SvANY(sv)) &&
8070                 (tXpv->xpv_cur > 1 ||
8071                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
8072             return 1;
8073         else
8074             return 0;
8075     }
8076     else {
8077         if (SvIOK(sv))
8078             return SvIVX(sv) != 0;
8079         else {
8080             if (SvNOK(sv))
8081                 return SvNVX(sv) != 0.0;
8082             else
8083                 return sv_2bool(sv);
8084         }
8085     }
8086 }
8087
8088 /*
8089 =for apidoc sv_iv
8090
8091 A private implementation of the C<SvIVx> macro for compilers which can't
8092 cope with complex macro expressions. Always use the macro instead.
8093
8094 =cut
8095 */
8096
8097 IV
8098 Perl_sv_iv(pTHX_ register SV *sv)
8099 {
8100     if (SvIOK(sv)) {
8101         if (SvIsUV(sv))
8102             return (IV)SvUVX(sv);
8103         return SvIVX(sv);
8104     }
8105     return sv_2iv(sv);
8106 }
8107
8108 /*
8109 =for apidoc sv_uv
8110
8111 A private implementation of the C<SvUVx> macro for compilers which can't
8112 cope with complex macro expressions. Always use the macro instead.
8113
8114 =cut
8115 */
8116
8117 UV
8118 Perl_sv_uv(pTHX_ register SV *sv)
8119 {
8120     if (SvIOK(sv)) {
8121         if (SvIsUV(sv))
8122             return SvUVX(sv);
8123         return (UV)SvIVX(sv);
8124     }
8125     return sv_2uv(sv);
8126 }
8127
8128 /*
8129 =for apidoc sv_nv
8130
8131 A private implementation of the C<SvNVx> macro for compilers which can't
8132 cope with complex macro expressions. Always use the macro instead.
8133
8134 =cut
8135 */
8136
8137 NV
8138 Perl_sv_nv(pTHX_ register SV *sv)
8139 {
8140     if (SvNOK(sv))
8141         return SvNVX(sv);
8142     return sv_2nv(sv);
8143 }
8144
8145 /* sv_pv() is now a macro using SvPV_nolen();
8146  * this function provided for binary compatibility only
8147  */
8148
8149 char *
8150 Perl_sv_pv(pTHX_ SV *sv)
8151 {
8152     STRLEN n_a;
8153
8154     if (SvPOK(sv))
8155         return SvPVX(sv);
8156
8157     return sv_2pv(sv, &n_a);
8158 }
8159
8160 /*
8161 =for apidoc sv_pv
8162
8163 Use the C<SvPV_nolen> macro instead
8164
8165 =for apidoc sv_pvn
8166
8167 A private implementation of the C<SvPV> macro for compilers which can't
8168 cope with complex macro expressions. Always use the macro instead.
8169
8170 =cut
8171 */
8172
8173 char *
8174 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8175 {
8176     if (SvPOK(sv)) {
8177         *lp = SvCUR(sv);
8178         return SvPVX(sv);
8179     }
8180     return sv_2pv(sv, lp);
8181 }
8182
8183
8184 char *
8185 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8186 {
8187     if (SvPOK(sv)) {
8188         *lp = SvCUR(sv);
8189         return SvPVX(sv);
8190     }
8191     return sv_2pv_flags(sv, lp, 0);
8192 }
8193
8194 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8195  * this function provided for binary compatibility only
8196  */
8197
8198 char *
8199 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8200 {
8201     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8202 }
8203
8204 /*
8205 =for apidoc sv_pvn_force
8206
8207 Get a sensible string out of the SV somehow.
8208 A private implementation of the C<SvPV_force> macro for compilers which
8209 can't cope with complex macro expressions. Always use the macro instead.
8210
8211 =for apidoc sv_pvn_force_flags
8212
8213 Get a sensible string out of the SV somehow.
8214 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8215 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8216 implemented in terms of this function.
8217 You normally want to use the various wrapper macros instead: see
8218 C<SvPV_force> and C<SvPV_force_nomg>
8219
8220 =cut
8221 */
8222
8223 char *
8224 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8225 {
8226     char *s = NULL;
8227
8228     if (SvTHINKFIRST(sv) && !SvROK(sv))
8229         sv_force_normal_flags(sv, 0);
8230
8231     if (SvPOK(sv)) {
8232         *lp = SvCUR(sv);
8233     }
8234     else {
8235         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8236             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8237                 OP_NAME(PL_op));
8238         }
8239         else
8240             s = sv_2pv_flags(sv, lp, flags);
8241         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
8242             STRLEN len = *lp;
8243
8244             if (SvROK(sv))
8245                 sv_unref(sv);
8246             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
8247             SvGROW(sv, len + 1);
8248             Move(s,SvPVX(sv),len,char);
8249             SvCUR_set(sv, len);
8250             *SvEND(sv) = '\0';
8251         }
8252         if (!SvPOK(sv)) {
8253             SvPOK_on(sv);               /* validate pointer */
8254             SvTAINT(sv);
8255             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8256                                   PTR2UV(sv),SvPVX(sv)));
8257         }
8258     }
8259     return SvPVX(sv);
8260 }
8261
8262 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8263  * this function provided for binary compatibility only
8264  */
8265
8266 char *
8267 Perl_sv_pvbyte(pTHX_ SV *sv)
8268 {
8269     sv_utf8_downgrade(sv,0);
8270     return sv_pv(sv);
8271 }
8272
8273 /*
8274 =for apidoc sv_pvbyte
8275
8276 Use C<SvPVbyte_nolen> instead.
8277
8278 =for apidoc sv_pvbyten
8279
8280 A private implementation of the C<SvPVbyte> macro for compilers
8281 which can't cope with complex macro expressions. Always use the macro
8282 instead.
8283
8284 =cut
8285 */
8286
8287 char *
8288 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8289 {
8290     sv_utf8_downgrade(sv,0);
8291     return sv_pvn(sv,lp);
8292 }
8293
8294 /*
8295 =for apidoc sv_pvbyten_force
8296
8297 A private implementation of the C<SvPVbytex_force> macro for compilers
8298 which can't cope with complex macro expressions. Always use the macro
8299 instead.
8300
8301 =cut
8302 */
8303
8304 char *
8305 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8306 {
8307     sv_pvn_force(sv,lp);
8308     sv_utf8_downgrade(sv,0);
8309     *lp = SvCUR(sv);
8310     return SvPVX(sv);
8311 }
8312
8313 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8314  * this function provided for binary compatibility only
8315  */
8316
8317 char *
8318 Perl_sv_pvutf8(pTHX_ SV *sv)
8319 {
8320     sv_utf8_upgrade(sv);
8321     return sv_pv(sv);
8322 }
8323
8324 /*
8325 =for apidoc sv_pvutf8
8326
8327 Use the C<SvPVutf8_nolen> macro instead
8328
8329 =for apidoc sv_pvutf8n
8330
8331 A private implementation of the C<SvPVutf8> macro for compilers
8332 which can't cope with complex macro expressions. Always use the macro
8333 instead.
8334
8335 =cut
8336 */
8337
8338 char *
8339 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8340 {
8341     sv_utf8_upgrade(sv);
8342     return sv_pvn(sv,lp);
8343 }
8344
8345 /*
8346 =for apidoc sv_pvutf8n_force
8347
8348 A private implementation of the C<SvPVutf8_force> macro for compilers
8349 which can't cope with complex macro expressions. Always use the macro
8350 instead.
8351
8352 =cut
8353 */
8354
8355 char *
8356 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8357 {
8358     sv_pvn_force(sv,lp);
8359     sv_utf8_upgrade(sv);
8360     *lp = SvCUR(sv);
8361     return SvPVX(sv);
8362 }
8363
8364 /*
8365 =for apidoc sv_reftype
8366
8367 Returns a string describing what the SV is a reference to.
8368
8369 =cut
8370 */
8371
8372 char *
8373 Perl_sv_reftype(pTHX_ SV *sv, int ob)
8374 {
8375     if (ob && SvOBJECT(sv)) {
8376         if (HvNAME(SvSTASH(sv)))
8377             return HvNAME(SvSTASH(sv));
8378         else
8379             return "__ANON__";
8380     }
8381     else {
8382         switch (SvTYPE(sv)) {
8383         case SVt_NULL:
8384         case SVt_IV:
8385         case SVt_NV:
8386         case SVt_RV:
8387         case SVt_PV:
8388         case SVt_PVIV:
8389         case SVt_PVNV:
8390         case SVt_PVMG:
8391         case SVt_PVBM:
8392                                 if (SvVOK(sv))
8393                                     return "VSTRING";
8394                                 if (SvROK(sv))
8395                                     return "REF";
8396                                 else
8397                                     return "SCALAR";
8398
8399         case SVt_PVLV:          return SvROK(sv) ? "REF"
8400                                 /* tied lvalues should appear to be
8401                                  * scalars for backwards compatitbility */
8402                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8403                                     ? "SCALAR" : "LVALUE";
8404         case SVt_PVAV:          return "ARRAY";
8405         case SVt_PVHV:          return "HASH";
8406         case SVt_PVCV:          return "CODE";
8407         case SVt_PVGV:          return "GLOB";
8408         case SVt_PVFM:          return "FORMAT";
8409         case SVt_PVIO:          return "IO";
8410         default:                return "UNKNOWN";
8411         }
8412     }
8413 }
8414
8415 /*
8416 =for apidoc sv_isobject
8417
8418 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8419 object.  If the SV is not an RV, or if the object is not blessed, then this
8420 will return false.
8421
8422 =cut
8423 */
8424
8425 int
8426 Perl_sv_isobject(pTHX_ SV *sv)
8427 {
8428     if (!sv)
8429         return 0;
8430     if (SvGMAGICAL(sv))
8431         mg_get(sv);
8432     if (!SvROK(sv))
8433         return 0;
8434     sv = (SV*)SvRV(sv);
8435     if (!SvOBJECT(sv))
8436         return 0;
8437     return 1;
8438 }
8439
8440 /*
8441 =for apidoc sv_isa
8442
8443 Returns a boolean indicating whether the SV is blessed into the specified
8444 class.  This does not check for subtypes; use C<sv_derived_from> to verify
8445 an inheritance relationship.
8446
8447 =cut
8448 */
8449
8450 int
8451 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8452 {
8453     if (!sv)
8454         return 0;
8455     if (SvGMAGICAL(sv))
8456         mg_get(sv);
8457     if (!SvROK(sv))
8458         return 0;
8459     sv = (SV*)SvRV(sv);
8460     if (!SvOBJECT(sv))
8461         return 0;
8462     if (!HvNAME(SvSTASH(sv)))
8463         return 0;
8464
8465     return strEQ(HvNAME(SvSTASH(sv)), name);
8466 }
8467
8468 /*
8469 =for apidoc newSVrv
8470
8471 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
8472 it will be upgraded to one.  If C<classname> is non-null then the new SV will
8473 be blessed in the specified package.  The new SV is returned and its
8474 reference count is 1.
8475
8476 =cut
8477 */
8478
8479 SV*
8480 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8481 {
8482     SV *sv;
8483
8484     new_SV(sv);
8485
8486     SV_CHECK_THINKFIRST_COW_DROP(rv);
8487     SvAMAGIC_off(rv);
8488
8489     if (SvTYPE(rv) >= SVt_PVMG) {
8490         U32 refcnt = SvREFCNT(rv);
8491         SvREFCNT(rv) = 0;
8492         sv_clear(rv);
8493         SvFLAGS(rv) = 0;
8494         SvREFCNT(rv) = refcnt;
8495     }
8496
8497     if (SvTYPE(rv) < SVt_RV)
8498         sv_upgrade(rv, SVt_RV);
8499     else if (SvTYPE(rv) > SVt_RV) {
8500         (void)SvOOK_off(rv);
8501         if (SvPVX(rv) && SvLEN(rv))
8502             Safefree(SvPVX(rv));
8503         SvCUR_set(rv, 0);
8504         SvLEN_set(rv, 0);
8505     }
8506
8507     (void)SvOK_off(rv);
8508     SvRV(rv) = sv;
8509     SvROK_on(rv);
8510
8511     if (classname) {
8512         HV* stash = gv_stashpv(classname, TRUE);
8513         (void)sv_bless(rv, stash);
8514     }
8515     return sv;
8516 }
8517
8518 /*
8519 =for apidoc sv_setref_pv
8520
8521 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
8522 argument will be upgraded to an RV.  That RV will be modified to point to
8523 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8524 into the SV.  The C<classname> argument indicates the package for the
8525 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
8526 will have a reference count of 1, and the RV will be returned.
8527
8528 Do not use with other Perl types such as HV, AV, SV, CV, because those
8529 objects will become corrupted by the pointer copy process.
8530
8531 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8532
8533 =cut
8534 */
8535
8536 SV*
8537 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8538 {
8539     if (!pv) {
8540         sv_setsv(rv, &PL_sv_undef);
8541         SvSETMAGIC(rv);
8542     }
8543     else
8544         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8545     return rv;
8546 }
8547
8548 /*
8549 =for apidoc sv_setref_iv
8550
8551 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
8552 argument will be upgraded to an RV.  That RV will be modified to point to
8553 the new SV.  The C<classname> argument indicates the package for the
8554 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
8555 will have a reference count of 1, and the RV will be returned.
8556
8557 =cut
8558 */
8559
8560 SV*
8561 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8562 {
8563     sv_setiv(newSVrv(rv,classname), iv);
8564     return rv;
8565 }
8566
8567 /*
8568 =for apidoc sv_setref_uv
8569
8570 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
8571 argument will be upgraded to an RV.  That RV will be modified to point to
8572 the new SV.  The C<classname> argument indicates the package for the
8573 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
8574 will have a reference count of 1, and the RV will be returned.
8575
8576 =cut
8577 */
8578
8579 SV*
8580 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8581 {
8582     sv_setuv(newSVrv(rv,classname), uv);
8583     return rv;
8584 }
8585
8586 /*
8587 =for apidoc sv_setref_nv
8588
8589 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
8590 argument will be upgraded to an RV.  That RV will be modified to point to
8591 the new SV.  The C<classname> argument indicates the package for the
8592 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
8593 will have a reference count of 1, and the RV will be returned.
8594
8595 =cut
8596 */
8597
8598 SV*
8599 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8600 {
8601     sv_setnv(newSVrv(rv,classname), nv);
8602     return rv;
8603 }
8604
8605 /*
8606 =for apidoc sv_setref_pvn
8607
8608 Copies a string into a new SV, optionally blessing the SV.  The length of the
8609 string must be specified with C<n>.  The C<rv> argument will be upgraded to
8610 an RV.  That RV will be modified to point to the new SV.  The C<classname>
8611 argument indicates the package for the blessing.  Set C<classname> to
8612 C<Nullch> to avoid the blessing.  The new SV will have a reference count
8613 of 1, and the RV will be returned.
8614
8615 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8616
8617 =cut
8618 */
8619
8620 SV*
8621 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8622 {
8623     sv_setpvn(newSVrv(rv,classname), pv, n);
8624     return rv;
8625 }
8626
8627 /*
8628 =for apidoc sv_bless
8629
8630 Blesses an SV into a specified package.  The SV must be an RV.  The package
8631 must be designated by its stash (see C<gv_stashpv()>).  The reference count
8632 of the SV is unaffected.
8633
8634 =cut
8635 */
8636
8637 SV*
8638 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8639 {
8640     SV *tmpRef;
8641     if (!SvROK(sv))
8642         Perl_croak(aTHX_ "Can't bless non-reference value");
8643     tmpRef = SvRV(sv);
8644     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8645         if (SvREADONLY(tmpRef))
8646             Perl_croak(aTHX_ PL_no_modify);
8647         if (SvOBJECT(tmpRef)) {
8648             if (SvTYPE(tmpRef) != SVt_PVIO)
8649                 --PL_sv_objcount;
8650             SvREFCNT_dec(SvSTASH(tmpRef));
8651         }
8652     }
8653     SvOBJECT_on(tmpRef);
8654     if (SvTYPE(tmpRef) != SVt_PVIO)
8655         ++PL_sv_objcount;
8656     (void)SvUPGRADE(tmpRef, SVt_PVMG);
8657     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
8658
8659     if (Gv_AMG(stash))
8660         SvAMAGIC_on(sv);
8661     else
8662         SvAMAGIC_off(sv);
8663
8664     if(SvSMAGICAL(tmpRef))
8665         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8666             mg_set(tmpRef);
8667
8668
8669
8670     return sv;
8671 }
8672
8673 /* Downgrades a PVGV to a PVMG.
8674  */
8675
8676 STATIC void
8677 S_sv_unglob(pTHX_ SV *sv)
8678 {
8679     void *xpvmg;
8680
8681     assert(SvTYPE(sv) == SVt_PVGV);
8682     SvFAKE_off(sv);
8683     if (GvGP(sv))
8684         gp_free((GV*)sv);
8685     if (GvSTASH(sv)) {
8686         SvREFCNT_dec(GvSTASH(sv));
8687         GvSTASH(sv) = Nullhv;
8688     }
8689     sv_unmagic(sv, PERL_MAGIC_glob);
8690     Safefree(GvNAME(sv));
8691     GvMULTI_off(sv);
8692
8693     /* need to keep SvANY(sv) in the right arena */
8694     xpvmg = new_XPVMG();
8695     StructCopy(SvANY(sv), xpvmg, XPVMG);
8696     del_XPVGV(SvANY(sv));
8697     SvANY(sv) = xpvmg;
8698
8699     SvFLAGS(sv) &= ~SVTYPEMASK;
8700     SvFLAGS(sv) |= SVt_PVMG;
8701 }
8702
8703 /*
8704 =for apidoc sv_unref_flags
8705
8706 Unsets the RV status of the SV, and decrements the reference count of
8707 whatever was being referenced by the RV.  This can almost be thought of
8708 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
8709 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8710 (otherwise the decrementing is conditional on the reference count being
8711 different from one or the reference being a readonly SV).
8712 See C<SvROK_off>.
8713
8714 =cut
8715 */
8716
8717 void
8718 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8719 {
8720     SV* rv = SvRV(sv);
8721
8722     if (SvWEAKREF(sv)) {
8723         sv_del_backref(sv);
8724         SvWEAKREF_off(sv);
8725         SvRV(sv) = 0;
8726         return;
8727     }
8728     SvRV(sv) = 0;
8729     SvROK_off(sv);
8730     /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8731        assigned to as BEGIN {$a = \"Foo"} will fail.  */
8732     if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8733         SvREFCNT_dec(rv);
8734     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8735         sv_2mortal(rv);         /* Schedule for freeing later */
8736 }
8737
8738 /*
8739 =for apidoc sv_unref
8740
8741 Unsets the RV status of the SV, and decrements the reference count of
8742 whatever was being referenced by the RV.  This can almost be thought of
8743 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
8744 being zero.  See C<SvROK_off>.
8745
8746 =cut
8747 */
8748
8749 void
8750 Perl_sv_unref(pTHX_ SV *sv)
8751 {
8752     sv_unref_flags(sv, 0);
8753 }
8754
8755 /*
8756 =for apidoc sv_taint
8757
8758 Taint an SV. Use C<SvTAINTED_on> instead.
8759 =cut
8760 */
8761
8762 void
8763 Perl_sv_taint(pTHX_ SV *sv)
8764 {
8765     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8766 }
8767
8768 /*
8769 =for apidoc sv_untaint
8770
8771 Untaint an SV. Use C<SvTAINTED_off> instead.
8772 =cut
8773 */
8774
8775 void
8776 Perl_sv_untaint(pTHX_ SV *sv)
8777 {
8778     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8779         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8780         if (mg)
8781             mg->mg_len &= ~1;
8782     }
8783 }
8784
8785 /*
8786 =for apidoc sv_tainted
8787
8788 Test an SV for taintedness. Use C<SvTAINTED> instead.
8789 =cut
8790 */
8791
8792 bool
8793 Perl_sv_tainted(pTHX_ SV *sv)
8794 {
8795     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8796         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8797         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8798             return TRUE;
8799     }
8800     return FALSE;
8801 }
8802
8803 /*
8804 =for apidoc sv_setpviv
8805
8806 Copies an integer into the given SV, also updating its string value.
8807 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
8808
8809 =cut
8810 */
8811
8812 void
8813 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8814 {
8815     char buf[TYPE_CHARS(UV)];
8816     char *ebuf;
8817     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8818
8819     sv_setpvn(sv, ptr, ebuf - ptr);
8820 }
8821
8822 /*
8823 =for apidoc sv_setpviv_mg
8824
8825 Like C<sv_setpviv>, but also handles 'set' magic.
8826
8827 =cut
8828 */
8829
8830 void
8831 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8832 {
8833     char buf[TYPE_CHARS(UV)];
8834     char *ebuf;
8835     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8836
8837     sv_setpvn(sv, ptr, ebuf - ptr);
8838     SvSETMAGIC(sv);
8839 }
8840
8841 #if defined(PERL_IMPLICIT_CONTEXT)
8842
8843 /* pTHX_ magic can't cope with varargs, so this is a no-context
8844  * version of the main function, (which may itself be aliased to us).
8845  * Don't access this version directly.
8846  */
8847
8848 void
8849 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8850 {
8851     dTHX;
8852     va_list args;
8853     va_start(args, pat);
8854     sv_vsetpvf(sv, pat, &args);
8855     va_end(args);
8856 }
8857
8858 /* pTHX_ magic can't cope with varargs, so this is a no-context
8859  * version of the main function, (which may itself be aliased to us).
8860  * Don't access this version directly.
8861  */
8862
8863 void
8864 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8865 {
8866     dTHX;
8867     va_list args;
8868     va_start(args, pat);
8869     sv_vsetpvf_mg(sv, pat, &args);
8870     va_end(args);
8871 }
8872 #endif
8873
8874 /*
8875 =for apidoc sv_setpvf
8876
8877 Processes its arguments like C<sprintf> and sets an SV to the formatted
8878 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
8879
8880 =cut
8881 */
8882
8883 void
8884 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8885 {
8886     va_list args;
8887     va_start(args, pat);
8888     sv_vsetpvf(sv, pat, &args);
8889     va_end(args);
8890 }
8891
8892 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
8893
8894 void
8895 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8896 {
8897     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8898 }
8899
8900 /*
8901 =for apidoc sv_setpvf_mg
8902
8903 Like C<sv_setpvf>, but also handles 'set' magic.
8904
8905 =cut
8906 */
8907
8908 void
8909 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8910 {
8911     va_list args;
8912     va_start(args, pat);
8913     sv_vsetpvf_mg(sv, pat, &args);
8914     va_end(args);
8915 }
8916
8917 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
8918
8919 void
8920 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8921 {
8922     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8923     SvSETMAGIC(sv);
8924 }
8925
8926 #if defined(PERL_IMPLICIT_CONTEXT)
8927
8928 /* pTHX_ magic can't cope with varargs, so this is a no-context
8929  * version of the main function, (which may itself be aliased to us).
8930  * Don't access this version directly.
8931  */
8932
8933 void
8934 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8935 {
8936     dTHX;
8937     va_list args;
8938     va_start(args, pat);
8939     sv_vcatpvf(sv, pat, &args);
8940     va_end(args);
8941 }
8942
8943 /* pTHX_ magic can't cope with varargs, so this is a no-context
8944  * version of the main function, (which may itself be aliased to us).
8945  * Don't access this version directly.
8946  */
8947
8948 void
8949 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8950 {
8951     dTHX;
8952     va_list args;
8953     va_start(args, pat);
8954     sv_vcatpvf_mg(sv, pat, &args);
8955     va_end(args);
8956 }
8957 #endif
8958
8959 /*
8960 =for apidoc sv_catpvf
8961
8962 Processes its arguments like C<sprintf> and appends the formatted
8963 output to an SV.  If the appended data contains "wide" characters
8964 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8965 and characters >255 formatted with %c), the original SV might get
8966 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.
8967 C<SvSETMAGIC()> must typically be called after calling this function
8968 to handle 'set' magic.
8969
8970 =cut */
8971
8972 void
8973 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8974 {
8975     va_list args;
8976     va_start(args, pat);
8977     sv_vcatpvf(sv, pat, &args);
8978     va_end(args);
8979 }
8980
8981 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
8982
8983 void
8984 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8985 {
8986     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8987 }
8988
8989 /*
8990 =for apidoc sv_catpvf_mg
8991
8992 Like C<sv_catpvf>, but also handles 'set' magic.
8993
8994 =cut
8995 */
8996
8997 void
8998 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8999 {
9000     va_list args;
9001     va_start(args, pat);
9002     sv_vcatpvf_mg(sv, pat, &args);
9003     va_end(args);
9004 }
9005
9006 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
9007
9008 void
9009 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9010 {
9011     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9012     SvSETMAGIC(sv);
9013 }
9014
9015 /*
9016 =for apidoc sv_vsetpvfn
9017
9018 Works like C<vcatpvfn> but copies the text into the SV instead of
9019 appending it.
9020
9021 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
9022
9023 =cut
9024 */
9025
9026 void
9027 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9028 {
9029     sv_setpvn(sv, "", 0);
9030     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9031 }
9032
9033 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
9034
9035 STATIC I32
9036 S_expect_number(pTHX_ char** pattern)
9037 {
9038     I32 var = 0;
9039     switch (**pattern) {
9040     case '1': case '2': case '3':
9041     case '4': case '5': case '6':
9042     case '7': case '8': case '9':
9043         while (isDIGIT(**pattern))
9044             var = var * 10 + (*(*pattern)++ - '0');
9045     }
9046     return var;
9047 }
9048 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
9049
9050 static char *
9051 F0convert(NV nv, char *endbuf, STRLEN *len)
9052 {
9053     int neg = nv < 0;
9054     UV uv;
9055     char *p = endbuf;
9056
9057     if (neg)
9058         nv = -nv;
9059     if (nv < UV_MAX) {
9060         nv += 0.5;
9061         uv = (UV)nv;
9062         if (uv & 1 && uv == nv)
9063             uv--;                       /* Round to even */
9064         do {
9065             unsigned dig = uv % 10;
9066             *--p = '0' + dig;
9067         } while (uv /= 10);
9068         if (neg)
9069             *--p = '-';
9070         *len = endbuf - p;
9071         return p;
9072     }
9073     return Nullch;
9074 }
9075
9076
9077 /*
9078 =for apidoc sv_vcatpvfn
9079
9080 Processes its arguments like C<vsprintf> and appends the formatted output
9081 to an SV.  Uses an array of SVs if the C style variable argument list is
9082 missing (NULL).  When running with taint checks enabled, indicates via
9083 C<maybe_tainted> if results are untrustworthy (often due to the use of
9084 locales).
9085
9086 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
9087
9088 =cut
9089 */
9090
9091 void
9092 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9093 {
9094     char *p;
9095     char *q;
9096     char *patend;
9097     STRLEN origlen;
9098     I32 svix = 0;
9099     static char nullstr[] = "(null)";
9100     SV *argsv = Nullsv;
9101     bool has_utf8; /* has the result utf8? */
9102     bool pat_utf8; /* the pattern is in utf8? */
9103     SV *nsv = Nullsv;
9104     /* Times 4: a decimal digit takes more than 3 binary digits.
9105      * NV_DIG: mantissa takes than many decimal digits.
9106      * Plus 32: Playing safe. */
9107     char ebuf[IV_DIG * 4 + NV_DIG + 32];
9108     /* large enough for "%#.#f" --chip */
9109     /* what about long double NVs? --jhi */
9110
9111     has_utf8 = pat_utf8 = DO_UTF8(sv);
9112
9113     /* no matter what, this is a string now */
9114     (void)SvPV_force(sv, origlen);
9115
9116     /* special-case "", "%s", and "%_" */
9117     if (patlen == 0)
9118         return;
9119     if (patlen == 2 && pat[0] == '%') {
9120         switch (pat[1]) {
9121         case 's':
9122             if (args) {
9123                 char *s = va_arg(*args, char*);
9124                 sv_catpv(sv, s ? s : nullstr);
9125             }
9126             else if (svix < svmax) {
9127                 sv_catsv(sv, *svargs);
9128                 if (DO_UTF8(*svargs))
9129                     SvUTF8_on(sv);
9130             }
9131             return;
9132         case '_':
9133             if (args) {
9134                 argsv = va_arg(*args, SV*);
9135                 sv_catsv(sv, argsv);
9136                 if (DO_UTF8(argsv))
9137                     SvUTF8_on(sv);
9138                 return;
9139             }
9140             /* See comment on '_' below */
9141             break;
9142         }
9143     }
9144
9145 #ifndef USE_LONG_DOUBLE
9146     /* special-case "%.<number>[gf]" */
9147     if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9148          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9149         unsigned digits = 0;
9150         const char *pp;
9151
9152         pp = pat + 2;
9153         while (*pp >= '0' && *pp <= '9')
9154             digits = 10 * digits + (*pp++ - '0');
9155         if (pp - pat == (int)patlen - 1) {
9156             NV nv;
9157
9158             if (args)
9159                 nv = (NV)va_arg(*args, double);
9160             else if (svix < svmax)
9161                 nv = SvNV(*svargs);
9162             else
9163                 return;
9164             if (*pp == 'g') {
9165                 /* Add check for digits != 0 because it seems that some
9166                    gconverts are buggy in this case, and we don't yet have
9167                    a Configure test for this.  */
9168                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9169                      /* 0, point, slack */
9170                     Gconvert(nv, (int)digits, 0, ebuf);
9171                     sv_catpv(sv, ebuf);
9172                     if (*ebuf)  /* May return an empty string for digits==0 */
9173                         return;
9174                 }
9175             } else if (!digits) {
9176                 STRLEN l;
9177
9178                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9179                     sv_catpvn(sv, p, l);
9180                     return;
9181                 }
9182             }
9183         }
9184     }
9185 #endif /* !USE_LONG_DOUBLE */
9186
9187     if (!args && svix < svmax && DO_UTF8(*svargs))
9188         has_utf8 = TRUE;
9189
9190     patend = (char*)pat + patlen;
9191     for (p = (char*)pat; p < patend; p = q) {
9192         bool alt = FALSE;
9193         bool left = FALSE;
9194         bool vectorize = FALSE;
9195         bool vectorarg = FALSE;
9196         bool vec_utf8 = FALSE;
9197         char fill = ' ';
9198         char plus = 0;
9199         char intsize = 0;
9200         STRLEN width = 0;
9201         STRLEN zeros = 0;
9202         bool has_precis = FALSE;
9203         STRLEN precis = 0;
9204         I32 osvix = svix;
9205         bool is_utf8 = FALSE;  /* is this item utf8?   */
9206 #ifdef HAS_LDBL_SPRINTF_BUG
9207         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9208            with sfio - Allen <allens@cpan.org> */
9209         bool fix_ldbl_sprintf_bug = FALSE;
9210 #endif
9211
9212         char esignbuf[4];
9213         U8 utf8buf[UTF8_MAXLEN+1];
9214         STRLEN esignlen = 0;
9215
9216         char *eptr = Nullch;
9217         STRLEN elen = 0;
9218         SV *vecsv = Nullsv;
9219         U8 *vecstr = Null(U8*);
9220         STRLEN veclen = 0;
9221         char c = 0;
9222         int i;
9223         unsigned base = 0;
9224         IV iv = 0;
9225         UV uv = 0;
9226         /* we need a long double target in case HAS_LONG_DOUBLE but
9227            not USE_LONG_DOUBLE
9228         */
9229 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9230         long double nv;
9231 #else
9232         NV nv;
9233 #endif
9234         STRLEN have;
9235         STRLEN need;
9236         STRLEN gap;
9237         char *dotstr = ".";
9238         STRLEN dotstrlen = 1;
9239         I32 efix = 0; /* explicit format parameter index */
9240         I32 ewix = 0; /* explicit width index */
9241         I32 epix = 0; /* explicit precision index */
9242         I32 evix = 0; /* explicit vector index */
9243         bool asterisk = FALSE;
9244
9245         /* echo everything up to the next format specification */
9246         for (q = p; q < patend && *q != '%'; ++q) ;
9247         if (q > p) {
9248             if (has_utf8 && !pat_utf8)
9249                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9250             else
9251                 sv_catpvn(sv, p, q - p);
9252             p = q;
9253         }
9254         if (q++ >= patend)
9255             break;
9256
9257 /*
9258     We allow format specification elements in this order:
9259         \d+\$              explicit format parameter index
9260         [-+ 0#]+           flags
9261         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
9262         0                  flag (as above): repeated to allow "v02"
9263         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
9264         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9265         [hlqLV]            size
9266     [%bcdefginopsux_DFOUX] format (mandatory)
9267 */
9268         if (EXPECT_NUMBER(q, width)) {
9269             if (*q == '$') {
9270                 ++q;
9271                 efix = width;
9272             } else {
9273                 goto gotwidth;
9274             }
9275         }
9276
9277         /* FLAGS */
9278
9279         while (*q) {
9280             switch (*q) {
9281             case ' ':
9282             case '+':
9283                 plus = *q++;
9284                 continue;
9285
9286             case '-':
9287                 left = TRUE;
9288                 q++;
9289                 continue;
9290
9291             case '0':
9292                 fill = *q++;
9293                 continue;
9294
9295             case '#':
9296                 alt = TRUE;
9297                 q++;
9298                 continue;
9299
9300             default:
9301                 break;
9302             }
9303             break;
9304         }
9305
9306       tryasterisk:
9307         if (*q == '*') {
9308             q++;
9309             if (EXPECT_NUMBER(q, ewix))
9310                 if (*q++ != '$')
9311                     goto unknown;
9312             asterisk = TRUE;
9313         }
9314         if (*q == 'v') {
9315             q++;
9316             if (vectorize)
9317                 goto unknown;
9318             if ((vectorarg = asterisk)) {
9319                 evix = ewix;
9320                 ewix = 0;
9321                 asterisk = FALSE;
9322             }
9323             vectorize = TRUE;
9324             goto tryasterisk;
9325         }
9326
9327         if (!asterisk)
9328             if( *q == '0' )
9329                 fill = *q++;
9330             EXPECT_NUMBER(q, width);
9331
9332         if (vectorize) {
9333             if (vectorarg) {
9334                 if (args)
9335                     vecsv = va_arg(*args, SV*);
9336                 else
9337                     vecsv = (evix ? evix <= svmax : svix < svmax) ?
9338                         svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9339                 dotstr = SvPVx(vecsv, dotstrlen);
9340                 if (DO_UTF8(vecsv))
9341                     is_utf8 = TRUE;
9342             }
9343             if (args) {
9344                 vecsv = va_arg(*args, SV*);
9345                 vecstr = (U8*)SvPVx(vecsv,veclen);
9346                 vec_utf8 = DO_UTF8(vecsv);
9347             }
9348             else if (efix ? efix <= svmax : svix < svmax) {
9349                 vecsv = svargs[efix ? efix-1 : svix++];
9350                 vecstr = (U8*)SvPVx(vecsv,veclen);
9351                 vec_utf8 = DO_UTF8(vecsv);
9352             }
9353             else {
9354                 vecstr = (U8*)"";
9355                 veclen = 0;
9356             }
9357         }
9358
9359         if (asterisk) {
9360             if (args)
9361                 i = va_arg(*args, int);
9362             else
9363                 i = (ewix ? ewix <= svmax : svix < svmax) ?
9364                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9365             left |= (i < 0);
9366             width = (i < 0) ? -i : i;
9367         }
9368       gotwidth:
9369
9370         /* PRECISION */
9371
9372         if (*q == '.') {
9373             q++;
9374             if (*q == '*') {
9375                 q++;
9376                 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9377                     goto unknown;
9378                 /* XXX: todo, support specified precision parameter */
9379                 if (epix)
9380                     goto unknown;
9381                 if (args)
9382                     i = va_arg(*args, int);
9383                 else
9384                     i = (ewix ? ewix <= svmax : svix < svmax)
9385                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9386                 precis = (i < 0) ? 0 : i;
9387             }
9388             else {
9389                 precis = 0;
9390                 while (isDIGIT(*q))
9391                     precis = precis * 10 + (*q++ - '0');
9392             }
9393             has_precis = TRUE;
9394         }
9395
9396         /* SIZE */
9397
9398         switch (*q) {
9399 #ifdef WIN32
9400         case 'I':                       /* Ix, I32x, and I64x */
9401 #  ifdef WIN64
9402             if (q[1] == '6' && q[2] == '4') {
9403                 q += 3;
9404                 intsize = 'q';
9405                 break;
9406             }
9407 #  endif
9408             if (q[1] == '3' && q[2] == '2') {
9409                 q += 3;
9410                 break;
9411             }
9412 #  ifdef WIN64
9413             intsize = 'q';
9414 #  endif
9415             q++;
9416             break;
9417 #endif
9418 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9419         case 'L':                       /* Ld */
9420             /* FALL THROUGH */
9421 #ifdef HAS_QUAD
9422         case 'q':                       /* qd */
9423 #endif
9424             intsize = 'q';
9425             q++;
9426             break;
9427 #endif
9428         case 'l':
9429 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9430             if (*(q + 1) == 'l') {      /* lld, llf */
9431                 intsize = 'q';
9432                 q += 2;
9433                 break;
9434              }
9435 #endif
9436             /* FALL THROUGH */
9437         case 'h':
9438             /* FALL THROUGH */
9439         case 'V':
9440             intsize = *q++;
9441             break;
9442         }
9443
9444         /* CONVERSION */
9445
9446         if (*q == '%') {
9447             eptr = q++;
9448             elen = 1;
9449             goto string;
9450         }
9451
9452         if (vectorize)
9453             argsv = vecsv;
9454         else if (!args)
9455             argsv = (efix ? efix <= svmax : svix < svmax) ?
9456                     svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9457
9458         switch (c = *q++) {
9459
9460             /* STRINGS */
9461
9462         case 'c':
9463             uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9464             if ((uv > 255 ||
9465                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9466                 && !IN_BYTES) {
9467                 eptr = (char*)utf8buf;
9468                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9469                 is_utf8 = TRUE;
9470             }
9471             else {
9472                 c = (char)uv;
9473                 eptr = &c;
9474                 elen = 1;
9475             }
9476             goto string;
9477
9478         case 's':
9479             if (args && !vectorize) {
9480                 eptr = va_arg(*args, char*);
9481                 if (eptr)
9482 #ifdef MACOS_TRADITIONAL
9483                   /* On MacOS, %#s format is used for Pascal strings */
9484                   if (alt)
9485                     elen = *eptr++;
9486                   else
9487 #endif
9488                     elen = strlen(eptr);
9489                 else {
9490                     eptr = nullstr;
9491                     elen = sizeof nullstr - 1;
9492                 }
9493             }
9494             else {
9495                 eptr = SvPVx(argsv, elen);
9496                 if (DO_UTF8(argsv)) {
9497                     if (has_precis && precis < elen) {
9498                         I32 p = precis;
9499                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9500                         precis = p;
9501                     }
9502                     if (width) { /* fudge width (can't fudge elen) */
9503                         width += elen - sv_len_utf8(argsv);
9504                     }
9505                     is_utf8 = TRUE;
9506                 }
9507             }
9508             goto string;
9509
9510         case '_':
9511             /*
9512              * The "%_" hack might have to be changed someday,
9513              * if ISO or ANSI decide to use '_' for something.
9514              * So we keep it hidden from users' code.
9515              */
9516             if (!args || vectorize)
9517                 goto unknown;
9518             argsv = va_arg(*args, SV*);
9519             eptr = SvPVx(argsv, elen);
9520             if (DO_UTF8(argsv))
9521                 is_utf8 = TRUE;
9522
9523         string:
9524             vectorize = FALSE;
9525             if (has_precis && elen > precis)
9526                 elen = precis;
9527             break;
9528
9529             /* INTEGERS */
9530
9531         case 'p':
9532             if (alt || vectorize)
9533                 goto unknown;
9534             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9535             base = 16;
9536             goto integer;
9537
9538         case 'D':
9539 #ifdef IV_IS_QUAD
9540             intsize = 'q';
9541 #else
9542             intsize = 'l';
9543 #endif
9544             /* FALL THROUGH */
9545         case 'd':
9546         case 'i':
9547             if (vectorize) {
9548                 STRLEN ulen;
9549                 if (!veclen)
9550                     continue;
9551                 if (vec_utf8)
9552                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9553                                         UTF8_ALLOW_ANYUV);
9554                 else {
9555                     uv = *vecstr;
9556                     ulen = 1;
9557                 }
9558                 vecstr += ulen;
9559                 veclen -= ulen;
9560                 if (plus)
9561                      esignbuf[esignlen++] = plus;
9562             }
9563             else if (args) {
9564                 switch (intsize) {
9565                 case 'h':       iv = (short)va_arg(*args, int); break;
9566                 case 'l':       iv = va_arg(*args, long); break;
9567                 case 'V':       iv = va_arg(*args, IV); break;
9568                 default:        iv = va_arg(*args, int); break;
9569 #ifdef HAS_QUAD
9570                 case 'q':       iv = va_arg(*args, Quad_t); break;
9571 #endif
9572                 }
9573             }
9574             else {
9575                 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9576                 switch (intsize) {
9577                 case 'h':       iv = (short)tiv; break;
9578                 case 'l':       iv = (long)tiv; break;
9579                 case 'V':
9580                 default:        iv = tiv; break;
9581 #ifdef HAS_QUAD
9582                 case 'q':       iv = (Quad_t)tiv; break;
9583 #endif
9584                 }
9585             }
9586             if ( !vectorize )   /* we already set uv above */
9587             {
9588                 if (iv >= 0) {
9589                     uv = iv;
9590                     if (plus)
9591                         esignbuf[esignlen++] = plus;
9592                 }
9593                 else {
9594                     uv = -iv;
9595                     esignbuf[esignlen++] = '-';
9596                 }
9597             }
9598             base = 10;
9599             goto integer;
9600
9601         case 'U':
9602 #ifdef IV_IS_QUAD
9603             intsize = 'q';
9604 #else
9605             intsize = 'l';
9606 #endif
9607             /* FALL THROUGH */
9608         case 'u':
9609             base = 10;
9610             goto uns_integer;
9611
9612         case 'b':
9613             base = 2;
9614             goto uns_integer;
9615
9616         case 'O':
9617 #ifdef IV_IS_QUAD
9618             intsize = 'q';
9619 #else
9620             intsize = 'l';
9621 #endif
9622             /* FALL THROUGH */
9623         case 'o':
9624             base = 8;
9625             goto uns_integer;
9626
9627         case 'X':
9628         case 'x':
9629             base = 16;
9630
9631         uns_integer:
9632             if (vectorize) {
9633                 STRLEN ulen;
9634         vector:
9635                 if (!veclen)
9636                     continue;
9637                 if (vec_utf8)
9638                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9639                                         UTF8_ALLOW_ANYUV);
9640                 else {
9641                     uv = *vecstr;
9642                     ulen = 1;
9643                 }
9644                 vecstr += ulen;
9645                 veclen -= ulen;
9646             }
9647             else if (args) {
9648                 switch (intsize) {
9649                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
9650                 case 'l':  uv = va_arg(*args, unsigned long); break;
9651                 case 'V':  uv = va_arg(*args, UV); break;
9652                 default:   uv = va_arg(*args, unsigned); break;
9653 #ifdef HAS_QUAD
9654                 case 'q':  uv = va_arg(*args, Uquad_t); break;
9655 #endif
9656                 }
9657             }
9658             else {
9659                 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9660                 switch (intsize) {
9661                 case 'h':       uv = (unsigned short)tuv; break;
9662                 case 'l':       uv = (unsigned long)tuv; break;
9663                 case 'V':
9664                 default:        uv = tuv; break;
9665 #ifdef HAS_QUAD
9666                 case 'q':       uv = (Uquad_t)tuv; break;
9667 #endif
9668                 }
9669             }
9670
9671         integer:
9672             eptr = ebuf + sizeof ebuf;
9673             switch (base) {
9674                 unsigned dig;
9675             case 16:
9676                 if (!uv)
9677                     alt = FALSE;
9678                 p = (char*)((c == 'X')
9679                             ? "0123456789ABCDEF" : "0123456789abcdef");
9680                 do {
9681                     dig = uv & 15;
9682                     *--eptr = p[dig];
9683                 } while (uv >>= 4);
9684                 if (alt) {
9685                     esignbuf[esignlen++] = '0';
9686                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
9687                 }
9688                 break;
9689             case 8:
9690                 do {
9691                     dig = uv & 7;
9692                     *--eptr = '0' + dig;
9693                 } while (uv >>= 3);
9694                 if (alt && *eptr != '0')
9695                     *--eptr = '0';
9696                 break;
9697             case 2:
9698                 do {
9699                     dig = uv & 1;
9700                     *--eptr = '0' + dig;
9701                 } while (uv >>= 1);
9702                 if (alt) {
9703                     esignbuf[esignlen++] = '0';
9704                     esignbuf[esignlen++] = 'b';
9705                 }
9706                 break;
9707             default:            /* it had better be ten or less */
9708 #if defined(PERL_Y2KWARN)
9709                 if (ckWARN(WARN_Y2K)) {
9710                     STRLEN n;
9711                     char *s = SvPV(sv,n);
9712                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
9713                         && (n == 2 || !isDIGIT(s[n-3])))
9714                     {
9715                         Perl_warner(aTHX_ packWARN(WARN_Y2K),
9716                                     "Possible Y2K bug: %%%c %s",
9717                                     c, "format string following '19'");
9718                     }
9719                 }
9720 #endif
9721                 do {
9722                     dig = uv % base;
9723                     *--eptr = '0' + dig;
9724                 } while (uv /= base);
9725                 break;
9726             }
9727             elen = (ebuf + sizeof ebuf) - eptr;
9728             if (has_precis) {
9729                 if (precis > elen)
9730                     zeros = precis - elen;
9731                 else if (precis == 0 && elen == 1 && *eptr == '0')
9732                     elen = 0;
9733             }
9734             break;
9735
9736             /* FLOATING POINT */
9737
9738         case 'F':
9739             c = 'f';            /* maybe %F isn't supported here */
9740             /* FALL THROUGH */
9741         case 'e': case 'E':
9742         case 'f':
9743         case 'g': case 'G':
9744
9745             /* This is evil, but floating point is even more evil */
9746
9747             /* for SV-style calling, we can only get NV
9748                for C-style calling, we assume %f is double;
9749                for simplicity we allow any of %Lf, %llf, %qf for long double
9750             */
9751             switch (intsize) {
9752             case 'V':
9753 #if defined(USE_LONG_DOUBLE)
9754                 intsize = 'q';
9755 #endif
9756                 break;
9757 /* [perl #20339] - we should accept and ignore %lf rather than die */
9758             case 'l':
9759                 /* FALL THROUGH */
9760             default:
9761 #if defined(USE_LONG_DOUBLE)
9762                 intsize = args ? 0 : 'q';
9763 #endif
9764                 break;
9765             case 'q':
9766 #if defined(HAS_LONG_DOUBLE)
9767                 break;
9768 #else
9769                 /* FALL THROUGH */
9770 #endif
9771             case 'h':
9772                 goto unknown;
9773             }
9774
9775             /* now we need (long double) if intsize == 'q', else (double) */
9776             nv = (args && !vectorize) ?
9777 #if LONG_DOUBLESIZE > DOUBLESIZE
9778                 intsize == 'q' ?
9779                     va_arg(*args, long double) :
9780                     va_arg(*args, double)
9781 #else
9782                     va_arg(*args, double)
9783 #endif
9784                 : SvNVx(argsv);
9785
9786             need = 0;
9787             vectorize = FALSE;
9788             if (c != 'e' && c != 'E') {
9789                 i = PERL_INT_MIN;
9790                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9791                    will cast our (long double) to (double) */
9792                 (void)Perl_frexp(nv, &i);
9793                 if (i == PERL_INT_MIN)
9794                     Perl_die(aTHX_ "panic: frexp");
9795                 if (i > 0)
9796                     need = BIT_DIGITS(i);
9797             }
9798             need += has_precis ? precis : 6; /* known default */
9799
9800             if (need < width)
9801                 need = width;
9802
9803 #ifdef HAS_LDBL_SPRINTF_BUG
9804             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9805                with sfio - Allen <allens@cpan.org> */
9806
9807 #  ifdef DBL_MAX
9808 #    define MY_DBL_MAX DBL_MAX
9809 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9810 #    if DOUBLESIZE >= 8
9811 #      define MY_DBL_MAX 1.7976931348623157E+308L
9812 #    else
9813 #      define MY_DBL_MAX 3.40282347E+38L
9814 #    endif
9815 #  endif
9816
9817 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9818 #    define MY_DBL_MAX_BUG 1L
9819 #  else
9820 #    define MY_DBL_MAX_BUG MY_DBL_MAX
9821 #  endif
9822
9823 #  ifdef DBL_MIN
9824 #    define MY_DBL_MIN DBL_MIN
9825 #  else  /* XXX guessing! -Allen */
9826 #    if DOUBLESIZE >= 8
9827 #      define MY_DBL_MIN 2.2250738585072014E-308L
9828 #    else
9829 #      define MY_DBL_MIN 1.17549435E-38L
9830 #    endif
9831 #  endif
9832
9833             if ((intsize == 'q') && (c == 'f') &&
9834                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9835                 (need < DBL_DIG)) {
9836                 /* it's going to be short enough that
9837                  * long double precision is not needed */
9838
9839                 if ((nv <= 0L) && (nv >= -0L))
9840                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9841                 else {
9842                     /* would use Perl_fp_class as a double-check but not
9843                      * functional on IRIX - see perl.h comments */
9844
9845                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9846                         /* It's within the range that a double can represent */
9847 #if defined(DBL_MAX) && !defined(DBL_MIN)
9848                         if ((nv >= ((long double)1/DBL_MAX)) ||
9849                             (nv <= (-(long double)1/DBL_MAX)))
9850 #endif
9851                         fix_ldbl_sprintf_bug = TRUE;
9852                     }
9853                 }
9854                 if (fix_ldbl_sprintf_bug == TRUE) {
9855                     double temp;
9856
9857                     intsize = 0;
9858                     temp = (double)nv;
9859                     nv = (NV)temp;
9860                 }
9861             }
9862
9863 #  undef MY_DBL_MAX
9864 #  undef MY_DBL_MAX_BUG
9865 #  undef MY_DBL_MIN
9866
9867 #endif /* HAS_LDBL_SPRINTF_BUG */
9868
9869             need += 20; /* fudge factor */
9870             if (PL_efloatsize < need) {
9871                 Safefree(PL_efloatbuf);
9872                 PL_efloatsize = need + 20; /* more fudge */
9873                 New(906, PL_efloatbuf, PL_efloatsize, char);
9874                 PL_efloatbuf[0] = '\0';
9875             }
9876
9877             if ( !(width || left || plus || alt) && fill != '0'
9878                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
9879                 /* See earlier comment about buggy Gconvert when digits,
9880                    aka precis is 0  */
9881                 if ( c == 'g' && precis) {
9882                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9883                     if (*PL_efloatbuf)  /* May return an empty string for digits==0 */
9884                         goto float_converted;
9885                 } else if ( c == 'f' && !precis) {
9886                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9887                         break;
9888                 }
9889             }
9890             eptr = ebuf + sizeof ebuf;
9891             *--eptr = '\0';
9892             *--eptr = c;
9893             /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9894 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9895             if (intsize == 'q') {
9896                 /* Copy the one or more characters in a long double
9897                  * format before the 'base' ([efgEFG]) character to
9898                  * the format string. */
9899                 static char const prifldbl[] = PERL_PRIfldbl;
9900                 char const *p = prifldbl + sizeof(prifldbl) - 3;
9901                 while (p >= prifldbl) { *--eptr = *p--; }
9902             }
9903 #endif
9904             if (has_precis) {
9905                 base = precis;
9906                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9907                 *--eptr = '.';
9908             }
9909             if (width) {
9910                 base = width;
9911                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9912             }
9913             if (fill == '0')
9914                 *--eptr = fill;
9915             if (left)
9916                 *--eptr = '-';
9917             if (plus)
9918                 *--eptr = plus;
9919             if (alt)
9920                 *--eptr = '#';
9921             *--eptr = '%';
9922
9923             /* No taint.  Otherwise we are in the strange situation
9924              * where printf() taints but print($float) doesn't.
9925              * --jhi */
9926 #if defined(HAS_LONG_DOUBLE)
9927             if (intsize == 'q')
9928                 (void)sprintf(PL_efloatbuf, eptr, nv);
9929             else
9930                 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
9931 #else
9932             (void)sprintf(PL_efloatbuf, eptr, nv);
9933 #endif
9934         float_converted:
9935             eptr = PL_efloatbuf;
9936             elen = strlen(PL_efloatbuf);
9937             break;
9938
9939             /* SPECIAL */
9940
9941         case 'n':
9942             i = SvCUR(sv) - origlen;
9943             if (args && !vectorize) {
9944                 switch (intsize) {
9945                 case 'h':       *(va_arg(*args, short*)) = i; break;
9946                 default:        *(va_arg(*args, int*)) = i; break;
9947                 case 'l':       *(va_arg(*args, long*)) = i; break;
9948                 case 'V':       *(va_arg(*args, IV*)) = i; break;
9949 #ifdef HAS_QUAD
9950                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
9951 #endif
9952                 }
9953             }
9954             else
9955                 sv_setuv_mg(argsv, (UV)i);
9956             vectorize = FALSE;
9957             continue;   /* not "break" */
9958
9959             /* UNKNOWN */
9960
9961         default:
9962       unknown:
9963             if (!args && ckWARN(WARN_PRINTF) &&
9964                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
9965                 SV *msg = sv_newmortal();
9966                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9967                           (PL_op->op_type == OP_PRTF) ? "" : "s");
9968                 if (c) {
9969                     if (isPRINT(c))
9970                         Perl_sv_catpvf(aTHX_ msg,
9971                                        "\"%%%c\"", c & 0xFF);
9972                     else
9973                         Perl_sv_catpvf(aTHX_ msg,
9974                                        "\"%%\\%03"UVof"\"",
9975                                        (UV)c & 0xFF);
9976                 } else
9977                     sv_catpv(msg, "end of string");
9978                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9979             }
9980
9981             /* output mangled stuff ... */
9982             if (c == '\0')
9983                 --q;
9984             eptr = p;
9985             elen = q - p;
9986
9987             /* ... right here, because formatting flags should not apply */
9988             SvGROW(sv, SvCUR(sv) + elen + 1);
9989             p = SvEND(sv);
9990             Copy(eptr, p, elen, char);
9991             p += elen;
9992             *p = '\0';
9993             SvCUR(sv) = p - SvPVX(sv);
9994             svix = osvix;
9995             continue;   /* not "break" */
9996         }
9997
9998         /* calculate width before utf8_upgrade changes it */
9999         have = esignlen + zeros + elen;
10000
10001         if (is_utf8 != has_utf8) {
10002              if (is_utf8) {
10003                   if (SvCUR(sv))
10004                        sv_utf8_upgrade(sv);
10005              }
10006              else {
10007                   SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10008                   sv_utf8_upgrade(nsv);
10009                   eptr = SvPVX(nsv);
10010                   elen = SvCUR(nsv);
10011              }
10012              SvGROW(sv, SvCUR(sv) + elen + 1);
10013              p = SvEND(sv);
10014              *p = '\0';
10015         }
10016         /* Use memchr() instead of strchr(), as eptr is not guaranteed */
10017         /* to point to a null-terminated string.                       */
10018         if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
10019             (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
10020             Perl_warner(aTHX_ packWARN(WARN_PRINTF),
10021                 "Newline in left-justified string for %sprintf",
10022                         (PL_op->op_type == OP_PRTF) ? "" : "s");
10023
10024         need = (have > width ? have : width);
10025         gap = need - have;
10026
10027         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10028         p = SvEND(sv);
10029         if (esignlen && fill == '0') {
10030             for (i = 0; i < (int)esignlen; i++)
10031                 *p++ = esignbuf[i];
10032         }
10033         if (gap && !left) {
10034             memset(p, fill, gap);
10035             p += gap;
10036         }
10037         if (esignlen && fill != '0') {
10038             for (i = 0; i < (int)esignlen; i++)
10039                 *p++ = esignbuf[i];
10040         }
10041         if (zeros) {
10042             for (i = zeros; i; i--)
10043                 *p++ = '0';
10044         }
10045         if (elen) {
10046             Copy(eptr, p, elen, char);
10047             p += elen;
10048         }
10049         if (gap && left) {
10050             memset(p, ' ', gap);
10051             p += gap;
10052         }
10053         if (vectorize) {
10054             if (veclen) {
10055                 Copy(dotstr, p, dotstrlen, char);
10056                 p += dotstrlen;
10057             }
10058             else
10059                 vectorize = FALSE;              /* done iterating over vecstr */
10060         }
10061         if (is_utf8)
10062             has_utf8 = TRUE;
10063         if (has_utf8)
10064             SvUTF8_on(sv);
10065         *p = '\0';
10066         SvCUR(sv) = p - SvPVX(sv);
10067         if (vectorize) {
10068             esignlen = 0;
10069             goto vector;
10070         }
10071     }
10072 }
10073
10074 /* =========================================================================
10075
10076 =head1 Cloning an interpreter
10077
10078 All the macros and functions in this section are for the private use of
10079 the main function, perl_clone().
10080
10081 The foo_dup() functions make an exact copy of an existing foo thinngy.
10082 During the course of a cloning, a hash table is used to map old addresses
10083 to new addresses. The table is created and manipulated with the
10084 ptr_table_* functions.
10085
10086 =cut
10087
10088 ============================================================================*/
10089
10090
10091 #if defined(USE_ITHREADS)
10092
10093 #ifndef GpREFCNT_inc
10094 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10095 #endif
10096
10097
10098 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10099 #define av_dup(s,t)     (AV*)sv_dup((SV*)s,t)
10100 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10101 #define hv_dup(s,t)     (HV*)sv_dup((SV*)s,t)
10102 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10103 #define cv_dup(s,t)     (CV*)sv_dup((SV*)s,t)
10104 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10105 #define io_dup(s,t)     (IO*)sv_dup((SV*)s,t)
10106 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10107 #define gv_dup(s,t)     (GV*)sv_dup((SV*)s,t)
10108 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10109 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
10110 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
10111
10112
10113 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10114    regcomp.c. AMS 20010712 */
10115
10116 REGEXP *
10117 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10118 {
10119     REGEXP *ret;
10120     int i, len, npar;
10121     struct reg_substr_datum *s;
10122
10123     if (!r)
10124         return (REGEXP *)NULL;
10125
10126     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10127         return ret;
10128
10129     len = r->offsets[0];
10130     npar = r->nparens+1;
10131
10132     Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10133     Copy(r->program, ret->program, len+1, regnode);
10134
10135     New(0, ret->startp, npar, I32);
10136     Copy(r->startp, ret->startp, npar, I32);
10137     New(0, ret->endp, npar, I32);
10138     Copy(r->startp, ret->startp, npar, I32);
10139
10140     New(0, ret->substrs, 1, struct reg_substr_data);
10141     for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10142         s->min_offset = r->substrs->data[i].min_offset;
10143         s->max_offset = r->substrs->data[i].max_offset;
10144         s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
10145         s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10146     }
10147
10148     ret->regstclass = NULL;
10149     if (r->data) {
10150         struct reg_data *d;
10151         int count = r->data->count;
10152
10153         Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10154                 char, struct reg_data);
10155         New(0, d->what, count, U8);
10156
10157         d->count = count;
10158         for (i = 0; i < count; i++) {
10159             d->what[i] = r->data->what[i];
10160             switch (d->what[i]) {
10161             case 's':
10162                 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10163                 break;
10164             case 'p':
10165                 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10166                 break;
10167             case 'f':
10168                 /* This is cheating. */
10169                 New(0, d->data[i], 1, struct regnode_charclass_class);
10170                 StructCopy(r->data->data[i], d->data[i],
10171                             struct regnode_charclass_class);
10172                 ret->regstclass = (regnode*)d->data[i];
10173                 break;
10174             case 'o':
10175                 /* Compiled op trees are readonly, and can thus be
10176                    shared without duplication. */
10177                 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10178                 break;
10179             case 'n':
10180                 d->data[i] = r->data->data[i];
10181                 break;
10182             }
10183         }
10184
10185         ret->data = d;
10186     }
10187     else
10188         ret->data = NULL;
10189
10190     New(0, ret->offsets, 2*len+1, U32);
10191     Copy(r->offsets, ret->offsets, 2*len+1, U32);
10192
10193     ret->precomp        = SAVEPVN(r->precomp, r->prelen);
10194     ret->refcnt         = r->refcnt;
10195     ret->minlen         = r->minlen;
10196     ret->prelen         = r->prelen;
10197     ret->nparens        = r->nparens;
10198     ret->lastparen      = r->lastparen;
10199     ret->lastcloseparen = r->lastcloseparen;
10200     ret->reganch        = r->reganch;
10201
10202     ret->sublen         = r->sublen;
10203
10204     if (RX_MATCH_COPIED(ret))
10205         ret->subbeg  = SAVEPVN(r->subbeg, r->sublen);
10206     else
10207         ret->subbeg = Nullch;
10208 #ifdef PERL_COPY_ON_WRITE
10209     ret->saved_copy = Nullsv;
10210 #endif
10211
10212     ptr_table_store(PL_ptr_table, r, ret);
10213     return ret;
10214 }
10215
10216 /* duplicate a file handle */
10217
10218 PerlIO *
10219 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10220 {
10221     PerlIO *ret;
10222     if (!fp)
10223         return (PerlIO*)NULL;
10224
10225     /* look for it in the table first */
10226     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10227     if (ret)
10228         return ret;
10229
10230     /* create anew and remember what it is */
10231     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10232     ptr_table_store(PL_ptr_table, fp, ret);
10233     return ret;
10234 }
10235
10236 /* duplicate a directory handle */
10237
10238 DIR *
10239 Perl_dirp_dup(pTHX_ DIR *dp)
10240 {
10241     if (!dp)
10242         return (DIR*)NULL;
10243     /* XXX TODO */
10244     return dp;
10245 }
10246
10247 /* duplicate a typeglob */
10248
10249 GP *
10250 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10251 {
10252     GP *ret;
10253     if (!gp)
10254         return (GP*)NULL;
10255     /* look for it in the table first */
10256     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10257     if (ret)
10258         return ret;
10259
10260     /* create anew and remember what it is */
10261     Newz(0, ret, 1, GP);
10262     ptr_table_store(PL_ptr_table, gp, ret);
10263
10264     /* clone */
10265     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
10266     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
10267     ret->gp_io          = io_dup_inc(gp->gp_io, param);
10268     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
10269     ret->gp_av          = av_dup_inc(gp->gp_av, param);
10270     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
10271     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10272     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
10273     ret->gp_cvgen       = gp->gp_cvgen;
10274     ret->gp_flags       = gp->gp_flags;
10275     ret->gp_line        = gp->gp_line;
10276     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
10277     return ret;
10278 }
10279
10280 /* duplicate a chain of magic */
10281
10282 MAGIC *
10283 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10284 {
10285     MAGIC *mgprev = (MAGIC*)NULL;
10286     MAGIC *mgret;
10287     if (!mg)
10288         return (MAGIC*)NULL;
10289     /* look for it in the table first */
10290     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10291     if (mgret)
10292         return mgret;
10293
10294     for (; mg; mg = mg->mg_moremagic) {
10295         MAGIC *nmg;
10296         Newz(0, nmg, 1, MAGIC);
10297         if (mgprev)
10298             mgprev->mg_moremagic = nmg;
10299         else
10300             mgret = nmg;
10301         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
10302         nmg->mg_private = mg->mg_private;
10303         nmg->mg_type    = mg->mg_type;
10304         nmg->mg_flags   = mg->mg_flags;
10305         if (mg->mg_type == PERL_MAGIC_qr) {
10306             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10307         }
10308         else if(mg->mg_type == PERL_MAGIC_backref) {
10309             AV *av = (AV*) mg->mg_obj;
10310             SV **svp;
10311             I32 i;
10312             SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10313             svp = AvARRAY(av);
10314             for (i = AvFILLp(av); i >= 0; i--) {
10315                 if (!svp[i]) continue;
10316                 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10317             }
10318         }
10319         else {
10320             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10321                               ? sv_dup_inc(mg->mg_obj, param)
10322                               : sv_dup(mg->mg_obj, param);
10323         }
10324         nmg->mg_len     = mg->mg_len;
10325         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
10326         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10327             if (mg->mg_len > 0) {
10328                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
10329                 if (mg->mg_type == PERL_MAGIC_overload_table &&
10330                         AMT_AMAGIC((AMT*)mg->mg_ptr))
10331                 {
10332                     AMT *amtp = (AMT*)mg->mg_ptr;
10333                     AMT *namtp = (AMT*)nmg->mg_ptr;
10334                     I32 i;
10335                     for (i = 1; i < NofAMmeth; i++) {
10336                         namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10337                     }
10338                 }
10339             }
10340             else if (mg->mg_len == HEf_SVKEY)
10341                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10342         }
10343         if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10344             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10345         }
10346         mgprev = nmg;
10347     }
10348     return mgret;
10349 }
10350
10351 /* create a new pointer-mapping table */
10352
10353 PTR_TBL_t *
10354 Perl_ptr_table_new(pTHX)
10355 {
10356     PTR_TBL_t *tbl;
10357     Newz(0, tbl, 1, PTR_TBL_t);
10358     tbl->tbl_max        = 511;
10359     tbl->tbl_items      = 0;
10360     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10361     return tbl;
10362 }
10363
10364 /* map an existing pointer using a table */
10365
10366 void *
10367 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10368 {
10369     PTR_TBL_ENT_t *tblent;
10370     UV hash = PTR2UV(sv);
10371     assert(tbl);
10372     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10373     for (; tblent; tblent = tblent->next) {
10374         if (tblent->oldval == sv)
10375             return tblent->newval;
10376     }
10377     return (void*)NULL;
10378 }
10379
10380 /* add a new entry to a pointer-mapping table */
10381
10382 void
10383 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10384 {
10385     PTR_TBL_ENT_t *tblent, **otblent;
10386     /* XXX this may be pessimal on platforms where pointers aren't good
10387      * hash values e.g. if they grow faster in the most significant
10388      * bits */
10389     UV hash = PTR2UV(oldv);
10390     bool i = 1;
10391
10392     assert(tbl);
10393     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10394     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
10395         if (tblent->oldval == oldv) {
10396             tblent->newval = newv;
10397             return;
10398         }
10399     }
10400     Newz(0, tblent, 1, PTR_TBL_ENT_t);
10401     tblent->oldval = oldv;
10402     tblent->newval = newv;
10403     tblent->next = *otblent;
10404     *otblent = tblent;
10405     tbl->tbl_items++;
10406     if (i && tbl->tbl_items > tbl->tbl_max)
10407         ptr_table_split(tbl);
10408 }
10409
10410 /* double the hash bucket size of an existing ptr table */
10411
10412 void
10413 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10414 {
10415     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10416     UV oldsize = tbl->tbl_max + 1;
10417     UV newsize = oldsize * 2;
10418     UV i;
10419
10420     Renew(ary, newsize, PTR_TBL_ENT_t*);
10421     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10422     tbl->tbl_max = --newsize;
10423     tbl->tbl_ary = ary;
10424     for (i=0; i < oldsize; i++, ary++) {
10425         PTR_TBL_ENT_t **curentp, **entp, *ent;
10426         if (!*ary)
10427             continue;
10428         curentp = ary + oldsize;
10429         for (entp = ary, ent = *ary; ent; ent = *entp) {
10430             if ((newsize & PTR2UV(ent->oldval)) != i) {
10431                 *entp = ent->next;
10432                 ent->next = *curentp;
10433                 *curentp = ent;
10434                 continue;
10435             }
10436             else
10437                 entp = &ent->next;
10438         }
10439     }
10440 }
10441
10442 /* remove all the entries from a ptr table */
10443
10444 void
10445 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10446 {
10447     register PTR_TBL_ENT_t **array;
10448     register PTR_TBL_ENT_t *entry;
10449     register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
10450     UV riter = 0;
10451     UV max;
10452
10453     if (!tbl || !tbl->tbl_items) {
10454         return;
10455     }
10456
10457     array = tbl->tbl_ary;
10458     entry = array[0];
10459     max = tbl->tbl_max;
10460
10461     for (;;) {
10462         if (entry) {
10463             oentry = entry;
10464             entry = entry->next;
10465             Safefree(oentry);
10466         }
10467         if (!entry) {
10468             if (++riter > max) {
10469                 break;
10470             }
10471             entry = array[riter];
10472         }
10473     }
10474
10475     tbl->tbl_items = 0;
10476 }
10477
10478 /* clear and free a ptr table */
10479
10480 void
10481 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10482 {
10483     if (!tbl) {
10484         return;
10485     }
10486     ptr_table_clear(tbl);
10487     Safefree(tbl->tbl_ary);
10488     Safefree(tbl);
10489 }
10490
10491 #ifdef DEBUGGING
10492 char *PL_watch_pvx;
10493 #endif
10494
10495 /* attempt to make everything in the typeglob readonly */
10496
10497 STATIC SV *
10498 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10499 {
10500     GV *gv = (GV*)sstr;
10501     SV *sv = &param->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10502
10503     if (GvIO(gv) || GvFORM(gv)) {
10504         GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10505     }
10506     else if (!GvCV(gv)) {
10507         GvCV(gv) = (CV*)sv;
10508     }
10509     else {
10510         /* CvPADLISTs cannot be shared */
10511         if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10512             GvUNIQUE_off(gv);
10513         }
10514     }
10515
10516     if (!GvUNIQUE(gv)) {
10517 #if 0
10518         PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10519                       HvNAME(GvSTASH(gv)), GvNAME(gv));
10520 #endif
10521         return Nullsv;
10522     }
10523
10524     /*
10525      * write attempts will die with
10526      * "Modification of a read-only value attempted"
10527      */
10528     if (!GvSV(gv)) {
10529         GvSV(gv) = sv;
10530     }
10531     else {
10532         SvREADONLY_on(GvSV(gv));
10533     }
10534
10535     if (!GvAV(gv)) {
10536         GvAV(gv) = (AV*)sv;
10537     }
10538     else {
10539         SvREADONLY_on(GvAV(gv));
10540     }
10541
10542     if (!GvHV(gv)) {
10543         GvHV(gv) = (HV*)sv;
10544     }
10545     else {
10546         SvREADONLY_on(GvHV(gv));
10547     }
10548
10549     return sstr; /* he_dup() will SvREFCNT_inc() */
10550 }
10551
10552 /* duplicate an SV of any type (including AV, HV etc) */
10553
10554 void
10555 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10556 {
10557     if (SvROK(sstr)) {
10558         SvRV(dstr) = SvWEAKREF(sstr)
10559                      ? sv_dup(SvRV(sstr), param)
10560                      : sv_dup_inc(SvRV(sstr), param);
10561     }
10562     else if (SvPVX(sstr)) {
10563         /* Has something there */
10564         if (SvLEN(sstr)) {
10565             /* Normal PV - clone whole allocated space */
10566             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
10567             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10568                 /* Not that normal - actually sstr is copy on write.
10569                    But we are a true, independant SV, so:  */
10570                 SvREADONLY_off(dstr);
10571                 SvFAKE_off(dstr);
10572             }
10573         }
10574         else {
10575             /* Special case - not normally malloced for some reason */
10576             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10577                 /* A "shared" PV - clone it as unshared string */
10578                 if(SvPADTMP(sstr)) {
10579                     /* However, some of them live in the pad
10580                        and they should not have these flags
10581                        turned off */
10582
10583                     SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
10584                                            SvUVX(sstr));
10585                     SvUVX(dstr) = SvUVX(sstr);
10586                 } else {
10587
10588                     SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
10589                     SvFAKE_off(dstr);
10590                     SvREADONLY_off(dstr);
10591                 }
10592             }
10593             else {
10594                 /* Some other special case - random pointer */
10595                 SvPVX(dstr) = SvPVX(sstr);
10596             }
10597         }
10598     }
10599     else {
10600         /* Copy the Null */
10601         SvPVX(dstr) = SvPVX(sstr);
10602     }
10603 }
10604
10605 SV *
10606 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10607 {
10608     SV *dstr;
10609
10610     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10611         return Nullsv;
10612     /* look for it in the table first */
10613     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10614     if (dstr)
10615         return dstr;
10616
10617     if(param->flags & CLONEf_JOIN_IN) {
10618         /** We are joining here so we don't want do clone
10619             something that is bad **/
10620
10621         if(SvTYPE(sstr) == SVt_PVHV &&
10622            HvNAME(sstr)) {
10623             /** don't clone stashes if they already exist **/
10624             HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10625             return (SV*) old_stash;
10626         }
10627     }
10628
10629     /* create anew and remember what it is */
10630     new_SV(dstr);
10631     ptr_table_store(PL_ptr_table, sstr, dstr);
10632
10633     /* clone */
10634     SvFLAGS(dstr)       = SvFLAGS(sstr);
10635     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
10636     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
10637
10638 #ifdef DEBUGGING
10639     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10640         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10641                       PL_watch_pvx, SvPVX(sstr));
10642 #endif
10643
10644     switch (SvTYPE(sstr)) {
10645     case SVt_NULL:
10646         SvANY(dstr)     = NULL;
10647         break;
10648     case SVt_IV:
10649         SvANY(dstr)     = new_XIV();
10650         SvIVX(dstr)     = SvIVX(sstr);
10651         break;
10652     case SVt_NV:
10653         SvANY(dstr)     = new_XNV();
10654         SvNVX(dstr)     = SvNVX(sstr);
10655         break;
10656     case SVt_RV:
10657         SvANY(dstr)     = new_XRV();
10658         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10659         break;
10660     case SVt_PV:
10661         SvANY(dstr)     = new_XPV();
10662         SvCUR(dstr)     = SvCUR(sstr);
10663         SvLEN(dstr)     = SvLEN(sstr);
10664         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10665         break;
10666     case SVt_PVIV:
10667         SvANY(dstr)     = new_XPVIV();
10668         SvCUR(dstr)     = SvCUR(sstr);
10669         SvLEN(dstr)     = SvLEN(sstr);
10670         SvIVX(dstr)     = SvIVX(sstr);
10671         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10672         break;
10673     case SVt_PVNV:
10674         SvANY(dstr)     = new_XPVNV();
10675         SvCUR(dstr)     = SvCUR(sstr);
10676         SvLEN(dstr)     = SvLEN(sstr);
10677         SvIVX(dstr)     = SvIVX(sstr);
10678         SvNVX(dstr)     = SvNVX(sstr);
10679         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10680         break;
10681     case SVt_PVMG:
10682         SvANY(dstr)     = new_XPVMG();
10683         SvCUR(dstr)     = SvCUR(sstr);
10684         SvLEN(dstr)     = SvLEN(sstr);
10685         SvIVX(dstr)     = SvIVX(sstr);
10686         SvNVX(dstr)     = SvNVX(sstr);
10687         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10688         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10689         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10690         break;
10691     case SVt_PVBM:
10692         SvANY(dstr)     = new_XPVBM();
10693         SvCUR(dstr)     = SvCUR(sstr);
10694         SvLEN(dstr)     = SvLEN(sstr);
10695         SvIVX(dstr)     = SvIVX(sstr);
10696         SvNVX(dstr)     = SvNVX(sstr);
10697         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10698         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10699         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10700         BmRARE(dstr)    = BmRARE(sstr);
10701         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
10702         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10703         break;
10704     case SVt_PVLV:
10705         SvANY(dstr)     = new_XPVLV();
10706         SvCUR(dstr)     = SvCUR(sstr);
10707         SvLEN(dstr)     = SvLEN(sstr);
10708         SvIVX(dstr)     = SvIVX(sstr);
10709         SvNVX(dstr)     = SvNVX(sstr);
10710         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10711         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10712         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10713         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
10714         LvTARGLEN(dstr) = LvTARGLEN(sstr);
10715         if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10716             LvTARG(dstr) = dstr;
10717         else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10718             LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10719         else
10720             LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10721         LvTYPE(dstr)    = LvTYPE(sstr);
10722         break;
10723     case SVt_PVGV:
10724         if (GvUNIQUE((GV*)sstr)) {
10725             SV *share;
10726             if ((share = gv_share(sstr, param))) {
10727                 del_SV(dstr);
10728                 dstr = share;
10729                 ptr_table_store(PL_ptr_table, sstr, dstr);
10730 #if 0
10731                 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10732                               HvNAME(GvSTASH(share)), GvNAME(share));
10733 #endif
10734                 break;
10735             }
10736         }
10737         SvANY(dstr)     = new_XPVGV();
10738         SvCUR(dstr)     = SvCUR(sstr);
10739         SvLEN(dstr)     = SvLEN(sstr);
10740         SvIVX(dstr)     = SvIVX(sstr);
10741         SvNVX(dstr)     = SvNVX(sstr);
10742         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10743         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10744         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10745         GvNAMELEN(dstr) = GvNAMELEN(sstr);
10746         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10747         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr), param);
10748         GvFLAGS(dstr)   = GvFLAGS(sstr);
10749         GvGP(dstr)      = gp_dup(GvGP(sstr), param);
10750         (void)GpREFCNT_inc(GvGP(dstr));
10751         break;
10752     case SVt_PVIO:
10753         SvANY(dstr)     = new_XPVIO();
10754         SvCUR(dstr)     = SvCUR(sstr);
10755         SvLEN(dstr)     = SvLEN(sstr);
10756         SvIVX(dstr)     = SvIVX(sstr);
10757         SvNVX(dstr)     = SvNVX(sstr);
10758         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10759         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10760         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10761         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10762         if (IoOFP(sstr) == IoIFP(sstr))
10763             IoOFP(dstr) = IoIFP(dstr);
10764         else
10765             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10766         /* PL_rsfp_filters entries have fake IoDIRP() */
10767         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10768             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
10769         else
10770             IoDIRP(dstr)        = IoDIRP(sstr);
10771         IoLINES(dstr)           = IoLINES(sstr);
10772         IoPAGE(dstr)            = IoPAGE(sstr);
10773         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
10774         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
10775         if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10776             /* I have no idea why fake dirp (rsfps)
10777                should be treaded differently but otherwise
10778                we end up with leaks -- sky*/
10779             IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(sstr), param);
10780             IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(sstr), param);
10781             IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10782         } else {
10783             IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(sstr), param);
10784             IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(sstr), param);
10785             IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(sstr), param);
10786         }
10787         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
10788         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
10789         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
10790         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
10791         IoTYPE(dstr)            = IoTYPE(sstr);
10792         IoFLAGS(dstr)           = IoFLAGS(sstr);
10793         break;
10794     case SVt_PVAV:
10795         SvANY(dstr)     = new_XPVAV();
10796         SvCUR(dstr)     = SvCUR(sstr);
10797         SvLEN(dstr)     = SvLEN(sstr);
10798         SvIVX(dstr)     = SvIVX(sstr);
10799         SvNVX(dstr)     = SvNVX(sstr);
10800         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10801         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10802         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10803         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10804         if (AvARRAY((AV*)sstr)) {
10805             SV **dst_ary, **src_ary;
10806             SSize_t items = AvFILLp((AV*)sstr) + 1;
10807
10808             src_ary = AvARRAY((AV*)sstr);
10809             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10810             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10811             SvPVX(dstr) = (char*)dst_ary;
10812             AvALLOC((AV*)dstr) = dst_ary;
10813             if (AvREAL((AV*)sstr)) {
10814                 while (items-- > 0)
10815                     *dst_ary++ = sv_dup_inc(*src_ary++, param);
10816             }
10817             else {
10818                 while (items-- > 0)
10819                     *dst_ary++ = sv_dup(*src_ary++, param);
10820             }
10821             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10822             while (items-- > 0) {
10823                 *dst_ary++ = &PL_sv_undef;
10824             }
10825         }
10826         else {
10827             SvPVX(dstr)         = Nullch;
10828             AvALLOC((AV*)dstr)  = (SV**)NULL;
10829         }
10830         break;
10831     case SVt_PVHV:
10832         SvANY(dstr)     = new_XPVHV();
10833         SvCUR(dstr)     = SvCUR(sstr);
10834         SvLEN(dstr)     = SvLEN(sstr);
10835         SvIVX(dstr)     = SvIVX(sstr);
10836         SvNVX(dstr)     = SvNVX(sstr);
10837         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10838         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10839         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
10840         if (HvARRAY((HV*)sstr)) {
10841             STRLEN i = 0;
10842             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10843             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10844             Newz(0, dxhv->xhv_array,
10845                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10846             while (i <= sxhv->xhv_max) {
10847                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10848                                                     (bool)!!HvSHAREKEYS(sstr),
10849                                                     param);
10850                 ++i;
10851             }
10852             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10853                                      (bool)!!HvSHAREKEYS(sstr), param);
10854         }
10855         else {
10856             SvPVX(dstr)         = Nullch;
10857             HvEITER((HV*)dstr)  = (HE*)NULL;
10858         }
10859         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
10860         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
10861     /* Record stashes for possible cloning in Perl_clone(). */
10862         if(HvNAME((HV*)dstr))
10863             av_push(param->stashes, dstr);
10864         break;
10865     case SVt_PVFM:
10866         SvANY(dstr)     = new_XPVFM();
10867         FmLINES(dstr)   = FmLINES(sstr);
10868         goto dup_pvcv;
10869         /* NOTREACHED */
10870     case SVt_PVCV:
10871         SvANY(dstr)     = new_XPVCV();
10872         dup_pvcv:
10873         SvCUR(dstr)     = SvCUR(sstr);
10874         SvLEN(dstr)     = SvLEN(sstr);
10875         SvIVX(dstr)     = SvIVX(sstr);
10876         SvNVX(dstr)     = SvNVX(sstr);
10877         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10878         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10879         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10880         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
10881         CvSTART(dstr)   = CvSTART(sstr);
10882         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
10883         CvXSUB(dstr)    = CvXSUB(sstr);
10884         CvXSUBANY(dstr) = CvXSUBANY(sstr);
10885         if (CvCONST(sstr)) {
10886             CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
10887                 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
10888                 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
10889         }
10890         /* don't dup if copying back - CvGV isn't refcounted, so the
10891          * duped GV may never be freed. A bit of a hack! DAPM */
10892         CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
10893                 Nullgv : gv_dup(CvGV(sstr), param) ;
10894         if (param->flags & CLONEf_COPY_STACKS) {
10895           CvDEPTH(dstr) = CvDEPTH(sstr);
10896         } else {
10897           CvDEPTH(dstr) = 0;
10898         }
10899         PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10900         CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
10901         CvOUTSIDE(dstr) =
10902                 CvWEAKOUTSIDE(sstr)
10903                         ? cv_dup(    CvOUTSIDE(sstr), param)
10904                         : cv_dup_inc(CvOUTSIDE(sstr), param);
10905         CvFLAGS(dstr)   = CvFLAGS(sstr);
10906         CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
10907         break;
10908     default:
10909         Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10910         break;
10911     }
10912
10913     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10914         ++PL_sv_objcount;
10915
10916     return dstr;
10917  }
10918
10919 /* duplicate a context */
10920
10921 PERL_CONTEXT *
10922 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10923 {
10924     PERL_CONTEXT *ncxs;
10925
10926     if (!cxs)
10927         return (PERL_CONTEXT*)NULL;
10928
10929     /* look for it in the table first */
10930     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10931     if (ncxs)
10932         return ncxs;
10933
10934     /* create anew and remember what it is */
10935     Newz(56, ncxs, max + 1, PERL_CONTEXT);
10936     ptr_table_store(PL_ptr_table, cxs, ncxs);
10937
10938     while (ix >= 0) {
10939         PERL_CONTEXT *cx = &cxs[ix];
10940         PERL_CONTEXT *ncx = &ncxs[ix];
10941         ncx->cx_type    = cx->cx_type;
10942         if (CxTYPE(cx) == CXt_SUBST) {
10943             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10944         }
10945         else {
10946             ncx->blk_oldsp      = cx->blk_oldsp;
10947             ncx->blk_oldcop     = cx->blk_oldcop;
10948             ncx->blk_oldretsp   = cx->blk_oldretsp;
10949             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
10950             ncx->blk_oldscopesp = cx->blk_oldscopesp;
10951             ncx->blk_oldpm      = cx->blk_oldpm;
10952             ncx->blk_gimme      = cx->blk_gimme;
10953             switch (CxTYPE(cx)) {
10954             case CXt_SUB:
10955                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
10956                                            ? cv_dup_inc(cx->blk_sub.cv, param)
10957                                            : cv_dup(cx->blk_sub.cv,param));
10958                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
10959                                            ? av_dup_inc(cx->blk_sub.argarray, param)
10960                                            : Nullav);
10961                 ncx->blk_sub.savearray  = av_dup_inc(cx->blk_sub.savearray, param);
10962                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
10963                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
10964                 ncx->blk_sub.lval       = cx->blk_sub.lval;
10965                 break;
10966             case CXt_EVAL:
10967                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10968                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10969                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10970                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10971                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text, param);
10972                 break;
10973             case CXt_LOOP:
10974                 ncx->blk_loop.label     = cx->blk_loop.label;
10975                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
10976                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
10977                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
10978                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
10979                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
10980                                            ? cx->blk_loop.iterdata
10981                                            : gv_dup((GV*)cx->blk_loop.iterdata, param));
10982                 ncx->blk_loop.oldcomppad
10983                     = (PAD*)ptr_table_fetch(PL_ptr_table,
10984                                             cx->blk_loop.oldcomppad);
10985                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave, param);
10986                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval, param);
10987                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary, param);
10988                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
10989                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
10990                 break;
10991             case CXt_FORMAT:
10992                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv, param);
10993                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv, param);
10994                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10995                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
10996                 break;
10997             case CXt_BLOCK:
10998             case CXt_NULL:
10999                 break;
11000             }
11001         }
11002         --ix;
11003     }
11004     return ncxs;
11005 }
11006
11007 /* duplicate a stack info structure */
11008
11009 PERL_SI *
11010 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11011 {
11012     PERL_SI *nsi;
11013
11014     if (!si)
11015         return (PERL_SI*)NULL;
11016
11017     /* look for it in the table first */
11018     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11019     if (nsi)
11020         return nsi;
11021
11022     /* create anew and remember what it is */
11023     Newz(56, nsi, 1, PERL_SI);
11024     ptr_table_store(PL_ptr_table, si, nsi);
11025
11026     nsi->si_stack       = av_dup_inc(si->si_stack, param);
11027     nsi->si_cxix        = si->si_cxix;
11028     nsi->si_cxmax       = si->si_cxmax;
11029     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11030     nsi->si_type        = si->si_type;
11031     nsi->si_prev        = si_dup(si->si_prev, param);
11032     nsi->si_next        = si_dup(si->si_next, param);
11033     nsi->si_markoff     = si->si_markoff;
11034
11035     return nsi;
11036 }
11037
11038 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
11039 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
11040 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
11041 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
11042 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
11043 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
11044 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
11045 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
11046 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
11047 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
11048 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
11049 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
11050 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11051 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11052
11053 /* XXXXX todo */
11054 #define pv_dup_inc(p)   SAVEPV(p)
11055 #define pv_dup(p)       SAVEPV(p)
11056 #define svp_dup_inc(p,pp)       any_dup(p,pp)
11057
11058 /* map any object to the new equivent - either something in the
11059  * ptr table, or something in the interpreter structure
11060  */
11061
11062 void *
11063 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11064 {
11065     void *ret;
11066
11067     if (!v)
11068         return (void*)NULL;
11069
11070     /* look for it in the table first */
11071     ret = ptr_table_fetch(PL_ptr_table, v);
11072     if (ret)
11073         return ret;
11074
11075     /* see if it is part of the interpreter structure */
11076     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11077         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11078     else {
11079         ret = v;
11080     }
11081
11082     return ret;
11083 }
11084
11085 /* duplicate the save stack */
11086
11087 ANY *
11088 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11089 {
11090     ANY *ss     = proto_perl->Tsavestack;
11091     I32 ix      = proto_perl->Tsavestack_ix;
11092     I32 max     = proto_perl->Tsavestack_max;
11093     ANY *nss;
11094     SV *sv;
11095     GV *gv;
11096     AV *av;
11097     HV *hv;
11098     void* ptr;
11099     int intval;
11100     long longval;
11101     GP *gp;
11102     IV iv;
11103     I32 i;
11104     char *c = NULL;
11105     void (*dptr) (void*);
11106     void (*dxptr) (pTHX_ void*);
11107     OP *o;
11108
11109     Newz(54, nss, max, ANY);
11110
11111     while (ix > 0) {
11112         i = POPINT(ss,ix);
11113         TOPINT(nss,ix) = i;
11114         switch (i) {
11115         case SAVEt_ITEM:                        /* normal string */
11116             sv = (SV*)POPPTR(ss,ix);
11117             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11118             sv = (SV*)POPPTR(ss,ix);
11119             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11120             break;
11121         case SAVEt_SV:                          /* scalar reference */
11122             sv = (SV*)POPPTR(ss,ix);
11123             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11124             gv = (GV*)POPPTR(ss,ix);
11125             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11126             break;
11127         case SAVEt_GENERIC_PVREF:               /* generic char* */
11128             c = (char*)POPPTR(ss,ix);
11129             TOPPTR(nss,ix) = pv_dup(c);
11130             ptr = POPPTR(ss,ix);
11131             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11132             break;
11133         case SAVEt_SHARED_PVREF:                /* char* in shared space */
11134             c = (char*)POPPTR(ss,ix);
11135             TOPPTR(nss,ix) = savesharedpv(c);
11136             ptr = POPPTR(ss,ix);
11137             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11138             break;
11139         case SAVEt_GENERIC_SVREF:               /* generic sv */
11140         case SAVEt_SVREF:                       /* scalar reference */
11141             sv = (SV*)POPPTR(ss,ix);
11142             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11143             ptr = POPPTR(ss,ix);
11144             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11145             break;
11146         case SAVEt_AV:                          /* array reference */
11147             av = (AV*)POPPTR(ss,ix);
11148             TOPPTR(nss,ix) = av_dup_inc(av, param);
11149             gv = (GV*)POPPTR(ss,ix);
11150             TOPPTR(nss,ix) = gv_dup(gv, param);
11151             break;
11152         case SAVEt_HV:                          /* hash reference */
11153             hv = (HV*)POPPTR(ss,ix);
11154             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11155             gv = (GV*)POPPTR(ss,ix);
11156             TOPPTR(nss,ix) = gv_dup(gv, param);
11157             break;
11158         case SAVEt_INT:                         /* int reference */
11159             ptr = POPPTR(ss,ix);
11160             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11161             intval = (int)POPINT(ss,ix);
11162             TOPINT(nss,ix) = intval;
11163             break;
11164         case SAVEt_LONG:                        /* long reference */
11165             ptr = POPPTR(ss,ix);
11166             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11167             longval = (long)POPLONG(ss,ix);
11168             TOPLONG(nss,ix) = longval;
11169             break;
11170         case SAVEt_I32:                         /* I32 reference */
11171         case SAVEt_I16:                         /* I16 reference */
11172         case SAVEt_I8:                          /* I8 reference */
11173             ptr = POPPTR(ss,ix);
11174             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11175             i = POPINT(ss,ix);
11176             TOPINT(nss,ix) = i;
11177             break;
11178         case SAVEt_IV:                          /* IV reference */
11179             ptr = POPPTR(ss,ix);
11180             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11181             iv = POPIV(ss,ix);
11182             TOPIV(nss,ix) = iv;
11183             break;
11184         case SAVEt_SPTR:                        /* SV* reference */
11185             ptr = POPPTR(ss,ix);
11186             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11187             sv = (SV*)POPPTR(ss,ix);
11188             TOPPTR(nss,ix) = sv_dup(sv, param);
11189             break;
11190         case SAVEt_VPTR:                        /* random* reference */
11191             ptr = POPPTR(ss,ix);
11192             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11193             ptr = POPPTR(ss,ix);
11194             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11195             break;
11196         case SAVEt_PPTR:                        /* char* reference */
11197             ptr = POPPTR(ss,ix);
11198             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11199             c = (char*)POPPTR(ss,ix);
11200             TOPPTR(nss,ix) = pv_dup(c);
11201             break;
11202         case SAVEt_HPTR:                        /* HV* reference */
11203             ptr = POPPTR(ss,ix);
11204             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11205             hv = (HV*)POPPTR(ss,ix);
11206             TOPPTR(nss,ix) = hv_dup(hv, param);
11207             break;
11208         case SAVEt_APTR:                        /* AV* reference */
11209             ptr = POPPTR(ss,ix);
11210             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11211             av = (AV*)POPPTR(ss,ix);
11212             TOPPTR(nss,ix) = av_dup(av, param);
11213             break;
11214         case SAVEt_NSTAB:
11215             gv = (GV*)POPPTR(ss,ix);
11216             TOPPTR(nss,ix) = gv_dup(gv, param);
11217             break;
11218         case SAVEt_GP:                          /* scalar reference */
11219             gp = (GP*)POPPTR(ss,ix);
11220             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11221             (void)GpREFCNT_inc(gp);
11222             gv = (GV*)POPPTR(ss,ix);
11223             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11224             c = (char*)POPPTR(ss,ix);
11225             TOPPTR(nss,ix) = pv_dup(c);
11226             iv = POPIV(ss,ix);
11227             TOPIV(nss,ix) = iv;
11228             iv = POPIV(ss,ix);
11229             TOPIV(nss,ix) = iv;
11230             break;
11231         case SAVEt_FREESV:
11232         case SAVEt_MORTALIZESV:
11233             sv = (SV*)POPPTR(ss,ix);
11234             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11235             break;
11236         case SAVEt_FREEOP:
11237             ptr = POPPTR(ss,ix);
11238             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11239                 /* these are assumed to be refcounted properly */
11240                 switch (((OP*)ptr)->op_type) {
11241                 case OP_LEAVESUB:
11242                 case OP_LEAVESUBLV:
11243                 case OP_LEAVEEVAL:
11244                 case OP_LEAVE:
11245                 case OP_SCOPE:
11246                 case OP_LEAVEWRITE:
11247                     TOPPTR(nss,ix) = ptr;
11248                     o = (OP*)ptr;
11249                     OpREFCNT_inc(o);
11250                     break;
11251                 default:
11252                     TOPPTR(nss,ix) = Nullop;
11253                     break;
11254                 }
11255             }
11256             else
11257                 TOPPTR(nss,ix) = Nullop;
11258             break;
11259         case SAVEt_FREEPV:
11260             c = (char*)POPPTR(ss,ix);
11261             TOPPTR(nss,ix) = pv_dup_inc(c);
11262             break;
11263         case SAVEt_CLEARSV:
11264             longval = POPLONG(ss,ix);
11265             TOPLONG(nss,ix) = longval;
11266             break;
11267         case SAVEt_DELETE:
11268             hv = (HV*)POPPTR(ss,ix);
11269             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11270             c = (char*)POPPTR(ss,ix);
11271             TOPPTR(nss,ix) = pv_dup_inc(c);
11272             i = POPINT(ss,ix);
11273             TOPINT(nss,ix) = i;
11274             break;
11275         case SAVEt_DESTRUCTOR:
11276             ptr = POPPTR(ss,ix);
11277             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11278             dptr = POPDPTR(ss,ix);
11279             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
11280             break;
11281         case SAVEt_DESTRUCTOR_X:
11282             ptr = POPPTR(ss,ix);
11283             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11284             dxptr = POPDXPTR(ss,ix);
11285             TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
11286             break;
11287         case SAVEt_REGCONTEXT:
11288         case SAVEt_ALLOC:
11289             i = POPINT(ss,ix);
11290             TOPINT(nss,ix) = i;
11291             ix -= i;
11292             break;
11293         case SAVEt_STACK_POS:           /* Position on Perl stack */
11294             i = POPINT(ss,ix);
11295             TOPINT(nss,ix) = i;
11296             break;
11297         case SAVEt_AELEM:               /* array element */
11298             sv = (SV*)POPPTR(ss,ix);
11299             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11300             i = POPINT(ss,ix);
11301             TOPINT(nss,ix) = i;
11302             av = (AV*)POPPTR(ss,ix);
11303             TOPPTR(nss,ix) = av_dup_inc(av, param);
11304             break;
11305         case SAVEt_HELEM:               /* hash element */
11306             sv = (SV*)POPPTR(ss,ix);
11307             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11308             sv = (SV*)POPPTR(ss,ix);
11309             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11310             hv = (HV*)POPPTR(ss,ix);
11311             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11312             break;
11313         case SAVEt_OP:
11314             ptr = POPPTR(ss,ix);
11315             TOPPTR(nss,ix) = ptr;
11316             break;
11317         case SAVEt_HINTS:
11318             i = POPINT(ss,ix);
11319             TOPINT(nss,ix) = i;
11320             break;
11321         case SAVEt_COMPPAD:
11322             av = (AV*)POPPTR(ss,ix);
11323             TOPPTR(nss,ix) = av_dup(av, param);
11324             break;
11325         case SAVEt_PADSV:
11326             longval = (long)POPLONG(ss,ix);
11327             TOPLONG(nss,ix) = longval;
11328             ptr = POPPTR(ss,ix);
11329             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11330             sv = (SV*)POPPTR(ss,ix);
11331             TOPPTR(nss,ix) = sv_dup(sv, param);
11332             break;
11333         case SAVEt_BOOL:
11334             ptr = POPPTR(ss,ix);
11335             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11336             longval = (long)POPBOOL(ss,ix);
11337             TOPBOOL(nss,ix) = (bool)longval;
11338             break;
11339         case SAVEt_SET_SVFLAGS:
11340             i = POPINT(ss,ix);
11341             TOPINT(nss,ix) = i;
11342             i = POPINT(ss,ix);
11343             TOPINT(nss,ix) = i;
11344             sv = (SV*)POPPTR(ss,ix);
11345             TOPPTR(nss,ix) = sv_dup(sv, param);
11346             break;
11347         default:
11348             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11349         }
11350     }
11351
11352     return nss;
11353 }
11354
11355 /*
11356 =for apidoc perl_clone
11357
11358 Create and return a new interpreter by cloning the current one.
11359
11360 perl_clone takes these flags as parameters:
11361
11362 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11363 without it we only clone the data and zero the stacks,
11364 with it we copy the stacks and the new perl interpreter is
11365 ready to run at the exact same point as the previous one.
11366 The pseudo-fork code uses COPY_STACKS while the
11367 threads->new doesn't.
11368
11369 CLONEf_KEEP_PTR_TABLE
11370 perl_clone keeps a ptr_table with the pointer of the old
11371 variable as a key and the new variable as a value,
11372 this allows it to check if something has been cloned and not
11373 clone it again but rather just use the value and increase the
11374 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11375 the ptr_table using the function
11376 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11377 reason to keep it around is if you want to dup some of your own
11378 variable who are outside the graph perl scans, example of this
11379 code is in threads.xs create
11380
11381 CLONEf_CLONE_HOST
11382 This is a win32 thing, it is ignored on unix, it tells perls
11383 win32host code (which is c++) to clone itself, this is needed on
11384 win32 if you want to run two threads at the same time,
11385 if you just want to do some stuff in a separate perl interpreter
11386 and then throw it away and return to the original one,
11387 you don't need to do anything.
11388
11389 =cut
11390 */
11391
11392 /* XXX the above needs expanding by someone who actually understands it ! */
11393 EXTERN_C PerlInterpreter *
11394 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11395
11396 PerlInterpreter *
11397 perl_clone(PerlInterpreter *proto_perl, UV flags)
11398 {
11399 #ifdef PERL_IMPLICIT_SYS
11400
11401    /* perlhost.h so we need to call into it
11402    to clone the host, CPerlHost should have a c interface, sky */
11403
11404    if (flags & CLONEf_CLONE_HOST) {
11405        return perl_clone_host(proto_perl,flags);
11406    }
11407    return perl_clone_using(proto_perl, flags,
11408                             proto_perl->IMem,
11409                             proto_perl->IMemShared,
11410                             proto_perl->IMemParse,
11411                             proto_perl->IEnv,
11412                             proto_perl->IStdIO,
11413                             proto_perl->ILIO,
11414                             proto_perl->IDir,
11415                             proto_perl->ISock,
11416                             proto_perl->IProc);
11417 }
11418
11419 PerlInterpreter *
11420 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11421                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
11422                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11423                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11424                  struct IPerlDir* ipD, struct IPerlSock* ipS,
11425                  struct IPerlProc* ipP)
11426 {
11427     /* XXX many of the string copies here can be optimized if they're
11428      * constants; they need to be allocated as common memory and just
11429      * their pointers copied. */
11430
11431     IV i;
11432     CLONE_PARAMS clone_params;
11433     CLONE_PARAMS* param = &clone_params;
11434
11435     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11436     PERL_SET_THX(my_perl);
11437
11438 #  ifdef DEBUGGING
11439     Poison(my_perl, 1, PerlInterpreter);
11440     PL_markstack = 0;
11441     PL_scopestack = 0;
11442     PL_savestack = 0;
11443     PL_savestack_ix = 0;
11444     PL_savestack_max = -1;
11445     PL_retstack = 0;
11446     PL_sig_pending = 0;
11447     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11448 #  else /* !DEBUGGING */
11449     Zero(my_perl, 1, PerlInterpreter);
11450 #  endif        /* DEBUGGING */
11451
11452     /* host pointers */
11453     PL_Mem              = ipM;
11454     PL_MemShared        = ipMS;
11455     PL_MemParse         = ipMP;
11456     PL_Env              = ipE;
11457     PL_StdIO            = ipStd;
11458     PL_LIO              = ipLIO;
11459     PL_Dir              = ipD;
11460     PL_Sock             = ipS;
11461     PL_Proc             = ipP;
11462 #else           /* !PERL_IMPLICIT_SYS */
11463     IV i;
11464     CLONE_PARAMS clone_params;
11465     CLONE_PARAMS* param = &clone_params;
11466     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11467     PERL_SET_THX(my_perl);
11468
11469
11470
11471 #    ifdef DEBUGGING
11472     Poison(my_perl, 1, PerlInterpreter);
11473     PL_markstack = 0;
11474     PL_scopestack = 0;
11475     PL_savestack = 0;
11476     PL_savestack_ix = 0;
11477     PL_savestack_max = -1;
11478     PL_retstack = 0;
11479     PL_sig_pending = 0;
11480     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11481 #    else       /* !DEBUGGING */
11482     Zero(my_perl, 1, PerlInterpreter);
11483 #    endif      /* DEBUGGING */
11484 #endif          /* PERL_IMPLICIT_SYS */
11485     param->flags = flags;
11486     param->proto_perl = proto_perl;
11487
11488     /* arena roots */
11489     PL_xiv_arenaroot    = NULL;
11490     PL_xiv_root         = NULL;
11491     PL_xnv_arenaroot    = NULL;
11492     PL_xnv_root         = NULL;
11493     PL_xrv_arenaroot    = NULL;
11494     PL_xrv_root         = NULL;
11495     PL_xpv_arenaroot    = NULL;
11496     PL_xpv_root         = NULL;
11497     PL_xpviv_arenaroot  = NULL;
11498     PL_xpviv_root       = NULL;
11499     PL_xpvnv_arenaroot  = NULL;
11500     PL_xpvnv_root       = NULL;
11501     PL_xpvcv_arenaroot  = NULL;
11502     PL_xpvcv_root       = NULL;
11503     PL_xpvav_arenaroot  = NULL;
11504     PL_xpvav_root       = NULL;
11505     PL_xpvhv_arenaroot  = NULL;
11506     PL_xpvhv_root       = NULL;
11507     PL_xpvmg_arenaroot  = NULL;
11508     PL_xpvmg_root       = NULL;
11509     PL_xpvlv_arenaroot  = NULL;
11510     PL_xpvlv_root       = NULL;
11511     PL_xpvbm_arenaroot  = NULL;
11512     PL_xpvbm_root       = NULL;
11513     PL_he_arenaroot     = NULL;
11514     PL_he_root          = NULL;
11515     PL_nice_chunk       = NULL;
11516     PL_nice_chunk_size  = 0;
11517     PL_sv_count         = 0;
11518     PL_sv_objcount      = 0;
11519     PL_sv_root          = Nullsv;
11520     PL_sv_arenaroot     = Nullsv;
11521
11522     PL_debug            = proto_perl->Idebug;
11523
11524 #ifdef USE_REENTRANT_API
11525     /* XXX: things like -Dm will segfault here in perlio, but doing
11526      *  PERL_SET_CONTEXT(proto_perl);
11527      * breaks too many other things
11528      */
11529     Perl_reentrant_init(aTHX);
11530 #endif
11531
11532     /* create SV map for pointer relocation */
11533     PL_ptr_table = ptr_table_new();
11534
11535     /* initialize these special pointers as early as possible */
11536     SvANY(&PL_sv_undef)         = NULL;
11537     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
11538     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
11539     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11540
11541     SvANY(&PL_sv_no)            = new_XPVNV();
11542     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
11543     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11544     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
11545     SvCUR(&PL_sv_no)            = 0;
11546     SvLEN(&PL_sv_no)            = 1;
11547     SvNVX(&PL_sv_no)            = 0;
11548     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11549
11550     SvANY(&PL_sv_yes)           = new_XPVNV();
11551     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
11552     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11553     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
11554     SvCUR(&PL_sv_yes)           = 1;
11555     SvLEN(&PL_sv_yes)           = 2;
11556     SvNVX(&PL_sv_yes)           = 1;
11557     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11558
11559     /* create (a non-shared!) shared string table */
11560     PL_strtab           = newHV();
11561     HvSHAREKEYS_off(PL_strtab);
11562     hv_ksplit(PL_strtab, 512);
11563     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11564
11565     PL_compiling = proto_perl->Icompiling;
11566
11567     /* These two PVs will be free'd special way so must set them same way op.c does */
11568     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11569     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11570
11571     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
11572     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11573
11574     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11575     if (!specialWARN(PL_compiling.cop_warnings))
11576         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11577     if (!specialCopIO(PL_compiling.cop_io))
11578         PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11579     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11580
11581     /* pseudo environmental stuff */
11582     PL_origargc         = proto_perl->Iorigargc;
11583     PL_origargv         = proto_perl->Iorigargv;
11584
11585     param->stashes      = newAV();  /* Setup array of objects to call clone on */
11586
11587 #ifdef PERLIO_LAYERS
11588     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11589     PerlIO_clone(aTHX_ proto_perl, param);
11590 #endif
11591
11592     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
11593     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
11594     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
11595     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
11596     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
11597     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
11598
11599     /* switches */
11600     PL_minus_c          = proto_perl->Iminus_c;
11601     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
11602     PL_localpatches     = proto_perl->Ilocalpatches;
11603     PL_splitstr         = proto_perl->Isplitstr;
11604     PL_preprocess       = proto_perl->Ipreprocess;
11605     PL_minus_n          = proto_perl->Iminus_n;
11606     PL_minus_p          = proto_perl->Iminus_p;
11607     PL_minus_l          = proto_perl->Iminus_l;
11608     PL_minus_a          = proto_perl->Iminus_a;
11609     PL_minus_F          = proto_perl->Iminus_F;
11610     PL_doswitches       = proto_perl->Idoswitches;
11611     PL_dowarn           = proto_perl->Idowarn;
11612     PL_doextract        = proto_perl->Idoextract;
11613     PL_sawampersand     = proto_perl->Isawampersand;
11614     PL_unsafe           = proto_perl->Iunsafe;
11615     PL_inplace          = SAVEPV(proto_perl->Iinplace);
11616     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
11617     PL_perldb           = proto_perl->Iperldb;
11618     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11619     PL_exit_flags       = proto_perl->Iexit_flags;
11620
11621     /* magical thingies */
11622     /* XXX time(&PL_basetime) when asked for? */
11623     PL_basetime         = proto_perl->Ibasetime;
11624     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
11625
11626     PL_maxsysfd         = proto_perl->Imaxsysfd;
11627     PL_multiline        = proto_perl->Imultiline;
11628     PL_statusvalue      = proto_perl->Istatusvalue;
11629 #ifdef VMS
11630     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
11631 #endif
11632     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
11633
11634     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
11635     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
11636     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
11637
11638     /* Clone the regex array */
11639     PL_regex_padav = newAV();
11640     {
11641         I32 len = av_len((AV*)proto_perl->Iregex_padav);
11642         SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11643         av_push(PL_regex_padav,
11644                 sv_dup_inc(regexen[0],param));
11645         for(i = 1; i <= len; i++) {
11646             if(SvREPADTMP(regexen[i])) {
11647               av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11648             } else {
11649                 av_push(PL_regex_padav,
11650                     SvREFCNT_inc(
11651                         newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11652                              SvIVX(regexen[i])), param)))
11653                        ));
11654             }
11655         }
11656     }
11657     PL_regex_pad = AvARRAY(PL_regex_padav);
11658
11659     /* shortcuts to various I/O objects */
11660     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
11661     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
11662     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
11663     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
11664     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
11665     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
11666
11667     /* shortcuts to regexp stuff */
11668     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
11669
11670     /* shortcuts to misc objects */
11671     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
11672
11673     /* shortcuts to debugging objects */
11674     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
11675     PL_DBline           = gv_dup(proto_perl->IDBline, param);
11676     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
11677     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
11678     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
11679     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
11680     PL_DBassertion      = sv_dup(proto_perl->IDBassertion, param);
11681     PL_lineary          = av_dup(proto_perl->Ilineary, param);
11682     PL_dbargs           = av_dup(proto_perl->Idbargs, param);
11683
11684     /* symbol tables */
11685     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash, param);
11686     PL_curstash         = hv_dup(proto_perl->Tcurstash, param);
11687     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
11688     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
11689     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
11690
11691     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
11692     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
11693     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
11694     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
11695     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
11696     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
11697
11698     PL_sub_generation   = proto_perl->Isub_generation;
11699
11700     /* funky return mechanisms */
11701     PL_forkprocess      = proto_perl->Iforkprocess;
11702
11703     /* subprocess state */
11704     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
11705
11706     /* internal state */
11707     PL_tainting         = proto_perl->Itainting;
11708     PL_taint_warn       = proto_perl->Itaint_warn;
11709     PL_maxo             = proto_perl->Imaxo;
11710     if (proto_perl->Iop_mask)
11711         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11712     else
11713         PL_op_mask      = Nullch;
11714     /* PL_asserting        = proto_perl->Iasserting; */
11715
11716     /* current interpreter roots */
11717     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
11718     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
11719     PL_main_start       = proto_perl->Imain_start;
11720     PL_eval_root        = proto_perl->Ieval_root;
11721     PL_eval_start       = proto_perl->Ieval_start;
11722
11723     /* runtime control stuff */
11724     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11725     PL_copline          = proto_perl->Icopline;
11726
11727     PL_filemode         = proto_perl->Ifilemode;
11728     PL_lastfd           = proto_perl->Ilastfd;
11729     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
11730     PL_Argv             = NULL;
11731     PL_Cmd              = Nullch;
11732     PL_gensym           = proto_perl->Igensym;
11733     PL_preambled        = proto_perl->Ipreambled;
11734     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
11735     PL_laststatval      = proto_perl->Ilaststatval;
11736     PL_laststype        = proto_perl->Ilaststype;
11737     PL_mess_sv          = Nullsv;
11738
11739     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
11740     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
11741
11742     /* interpreter atexit processing */
11743     PL_exitlistlen      = proto_perl->Iexitlistlen;
11744     if (PL_exitlistlen) {
11745         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11746         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11747     }
11748     else
11749         PL_exitlist     = (PerlExitListEntry*)NULL;
11750     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
11751     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
11752     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11753
11754     PL_profiledata      = NULL;
11755     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<', param);
11756     /* PL_rsfp_filters entries have fake IoDIRP() */
11757     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters, param);
11758
11759     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
11760
11761     PAD_CLONE_VARS(proto_perl, param);
11762
11763 #ifdef HAVE_INTERP_INTERN
11764     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11765 #endif
11766
11767     /* more statics moved here */
11768     PL_generation       = proto_perl->Igeneration;
11769     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
11770
11771     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
11772     PL_in_clean_all     = proto_perl->Iin_clean_all;
11773
11774     PL_uid              = proto_perl->Iuid;
11775     PL_euid             = proto_perl->Ieuid;
11776     PL_gid              = proto_perl->Igid;
11777     PL_egid             = proto_perl->Iegid;
11778     PL_nomemok          = proto_perl->Inomemok;
11779     PL_an               = proto_perl->Ian;
11780     PL_evalseq          = proto_perl->Ievalseq;
11781     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
11782     PL_origalen         = proto_perl->Iorigalen;
11783     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
11784     PL_osname           = SAVEPV(proto_perl->Iosname);
11785     PL_sh_path_compat   = proto_perl->Ish_path_compat; /* XXX never deallocated */
11786     PL_sighandlerp      = proto_perl->Isighandlerp;
11787
11788
11789     PL_runops           = proto_perl->Irunops;
11790
11791     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11792
11793 #ifdef CSH
11794     PL_cshlen           = proto_perl->Icshlen;
11795     PL_cshname          = proto_perl->Icshname; /* XXX never deallocated */
11796 #endif
11797
11798     PL_lex_state        = proto_perl->Ilex_state;
11799     PL_lex_defer        = proto_perl->Ilex_defer;
11800     PL_lex_expect       = proto_perl->Ilex_expect;
11801     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
11802     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
11803     PL_lex_starts       = proto_perl->Ilex_starts;
11804     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff, param);
11805     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl, param);
11806     PL_lex_op           = proto_perl->Ilex_op;
11807     PL_lex_inpat        = proto_perl->Ilex_inpat;
11808     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
11809     PL_lex_brackets     = proto_perl->Ilex_brackets;
11810     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11811     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
11812     PL_lex_casemods     = proto_perl->Ilex_casemods;
11813     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11814     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
11815
11816     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11817     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11818     PL_nexttoke         = proto_perl->Inexttoke;
11819
11820     /* XXX This is probably masking the deeper issue of why
11821      * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11822      * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11823      * (A little debugging with a watchpoint on it may help.)
11824      */
11825     if (SvANY(proto_perl->Ilinestr)) {
11826         PL_linestr              = sv_dup_inc(proto_perl->Ilinestr, param);
11827         i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
11828         PL_bufptr               = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11829         i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
11830         PL_oldbufptr    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11831         i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
11832         PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11833         i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
11834         PL_linestart    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11835     }
11836     else {
11837         PL_linestr = NEWSV(65,79);
11838         sv_upgrade(PL_linestr,SVt_PVIV);
11839         sv_setpvn(PL_linestr,"",0);
11840         PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11841     }
11842     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11843     PL_pending_ident    = proto_perl->Ipending_ident;
11844     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
11845
11846     PL_expect           = proto_perl->Iexpect;
11847
11848     PL_multi_start      = proto_perl->Imulti_start;
11849     PL_multi_end        = proto_perl->Imulti_end;
11850     PL_multi_open       = proto_perl->Imulti_open;
11851     PL_multi_close      = proto_perl->Imulti_close;
11852
11853     PL_error_count      = proto_perl->Ierror_count;
11854     PL_subline          = proto_perl->Isubline;
11855     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
11856
11857     /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11858     if (SvANY(proto_perl->Ilinestr)) {
11859         i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
11860         PL_last_uni             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11861         i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
11862         PL_last_lop             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11863         PL_last_lop_op  = proto_perl->Ilast_lop_op;
11864     }
11865     else {
11866         PL_last_uni     = SvPVX(PL_linestr);
11867         PL_last_lop     = SvPVX(PL_linestr);
11868         PL_last_lop_op  = 0;
11869     }
11870     PL_in_my            = proto_perl->Iin_my;
11871     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash, param);
11872 #ifdef FCRYPT
11873     PL_cryptseen        = proto_perl->Icryptseen;
11874 #endif
11875
11876     PL_hints            = proto_perl->Ihints;
11877
11878     PL_amagic_generation        = proto_perl->Iamagic_generation;
11879
11880 #ifdef USE_LOCALE_COLLATE
11881     PL_collation_ix     = proto_perl->Icollation_ix;
11882     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
11883     PL_collation_standard       = proto_perl->Icollation_standard;
11884     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
11885     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
11886 #endif /* USE_LOCALE_COLLATE */
11887
11888 #ifdef USE_LOCALE_NUMERIC
11889     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
11890     PL_numeric_standard = proto_perl->Inumeric_standard;
11891     PL_numeric_local    = proto_perl->Inumeric_local;
11892     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11893 #endif /* !USE_LOCALE_NUMERIC */
11894
11895     /* utf8 character classes */
11896     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11897     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11898     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11899     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11900     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
11901     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11902     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
11903     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
11904     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
11905     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
11906     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
11907     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
11908     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11909     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
11910     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11911     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11912     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11913     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11914     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11915     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11916
11917     /* Did the locale setup indicate UTF-8? */
11918     PL_utf8locale       = proto_perl->Iutf8locale;
11919     /* Unicode features (see perlrun/-C) */
11920     PL_unicode          = proto_perl->Iunicode;
11921
11922     /* Pre-5.8 signals control */
11923     PL_signals          = proto_perl->Isignals;
11924
11925     /* times() ticks per second */
11926     PL_clocktick        = proto_perl->Iclocktick;
11927
11928     /* Recursion stopper for PerlIO_find_layer */
11929     PL_in_load_module   = proto_perl->Iin_load_module;
11930
11931     /* sort() routine */
11932     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
11933
11934     /* Not really needed/useful since the reenrant_retint is "volatile",
11935      * but do it for consistency's sake. */
11936     PL_reentrant_retint = proto_perl->Ireentrant_retint;
11937
11938     /* Hooks to shared SVs and locks. */
11939     PL_sharehook        = proto_perl->Isharehook;
11940     PL_lockhook         = proto_perl->Ilockhook;
11941     PL_unlockhook       = proto_perl->Iunlockhook;
11942     PL_threadhook       = proto_perl->Ithreadhook;
11943
11944     PL_runops_std       = proto_perl->Irunops_std;
11945     PL_runops_dbg       = proto_perl->Irunops_dbg;
11946
11947 #ifdef THREADS_HAVE_PIDS
11948     PL_ppid             = proto_perl->Ippid;
11949 #endif
11950
11951     /* swatch cache */
11952     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
11953     PL_last_swash_klen  = 0;
11954     PL_last_swash_key[0]= '\0';
11955     PL_last_swash_tmps  = (U8*)NULL;
11956     PL_last_swash_slen  = 0;
11957
11958     PL_glob_index       = proto_perl->Iglob_index;
11959     PL_srand_called     = proto_perl->Isrand_called;
11960     PL_hash_seed        = proto_perl->Ihash_seed;
11961     PL_rehash_seed      = proto_perl->Irehash_seed;
11962     PL_uudmap['M']      = 0;            /* reinits on demand */
11963     PL_bitcount         = Nullch;       /* reinits on demand */
11964
11965     if (proto_perl->Ipsig_pend) {
11966         Newz(0, PL_psig_pend, SIG_SIZE, int);
11967     }
11968     else {
11969         PL_psig_pend    = (int*)NULL;
11970     }
11971
11972     if (proto_perl->Ipsig_ptr) {
11973         Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
11974         Newz(0, PL_psig_name, SIG_SIZE, SV*);
11975         for (i = 1; i < SIG_SIZE; i++) {
11976             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11977             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11978         }
11979     }
11980     else {
11981         PL_psig_ptr     = (SV**)NULL;
11982         PL_psig_name    = (SV**)NULL;
11983     }
11984
11985     /* thrdvar.h stuff */
11986
11987     if (flags & CLONEf_COPY_STACKS) {
11988         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11989         PL_tmps_ix              = proto_perl->Ttmps_ix;
11990         PL_tmps_max             = proto_perl->Ttmps_max;
11991         PL_tmps_floor           = proto_perl->Ttmps_floor;
11992         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
11993         i = 0;
11994         while (i <= PL_tmps_ix) {
11995             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11996             ++i;
11997         }
11998
11999         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12000         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12001         Newz(54, PL_markstack, i, I32);
12002         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
12003                                                   - proto_perl->Tmarkstack);
12004         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
12005                                                   - proto_perl->Tmarkstack);
12006         Copy(proto_perl->Tmarkstack, PL_markstack,
12007              PL_markstack_ptr - PL_markstack + 1, I32);
12008
12009         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12010          * NOTE: unlike the others! */
12011         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
12012         PL_scopestack_max       = proto_perl->Tscopestack_max;
12013         Newz(54, PL_scopestack, PL_scopestack_max, I32);
12014         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12015
12016         /* next push_return() sets PL_retstack[PL_retstack_ix]
12017          * NOTE: unlike the others! */
12018         PL_retstack_ix          = proto_perl->Tretstack_ix;
12019         PL_retstack_max         = proto_perl->Tretstack_max;
12020         Newz(54, PL_retstack, PL_retstack_max, OP*);
12021         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
12022
12023         /* NOTE: si_dup() looks at PL_markstack */
12024         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo, param);
12025
12026         /* PL_curstack          = PL_curstackinfo->si_stack; */
12027         PL_curstack             = av_dup(proto_perl->Tcurstack, param);
12028         PL_mainstack            = av_dup(proto_perl->Tmainstack, param);
12029
12030         /* next PUSHs() etc. set *(PL_stack_sp+1) */
12031         PL_stack_base           = AvARRAY(PL_curstack);
12032         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
12033                                                    - proto_perl->Tstack_base);
12034         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
12035
12036         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12037          * NOTE: unlike the others! */
12038         PL_savestack_ix         = proto_perl->Tsavestack_ix;
12039         PL_savestack_max        = proto_perl->Tsavestack_max;
12040         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12041         PL_savestack            = ss_dup(proto_perl, param);
12042     }
12043     else {
12044         init_stacks();
12045         ENTER;                  /* perl_destruct() wants to LEAVE; */
12046     }
12047
12048     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
12049     PL_top_env          = &PL_start_env;
12050
12051     PL_op               = proto_perl->Top;
12052
12053     PL_Sv               = Nullsv;
12054     PL_Xpv              = (XPV*)NULL;
12055     PL_na               = proto_perl->Tna;
12056
12057     PL_statbuf          = proto_perl->Tstatbuf;
12058     PL_statcache        = proto_perl->Tstatcache;
12059     PL_statgv           = gv_dup(proto_perl->Tstatgv, param);
12060     PL_statname         = sv_dup_inc(proto_perl->Tstatname, param);
12061 #ifdef HAS_TIMES
12062     PL_timesbuf         = proto_perl->Ttimesbuf;
12063 #endif
12064
12065     PL_tainted          = proto_perl->Ttainted;
12066     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
12067     PL_rs               = sv_dup_inc(proto_perl->Trs, param);
12068     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv, param);
12069     PL_ofs_sv           = sv_dup_inc(proto_perl->Tofs_sv, param);
12070     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv, param);
12071     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
12072     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget, param);
12073     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget, param);
12074     PL_formtarget       = sv_dup(proto_perl->Tformtarget, param);
12075
12076     PL_restartop        = proto_perl->Trestartop;
12077     PL_in_eval          = proto_perl->Tin_eval;
12078     PL_delaymagic       = proto_perl->Tdelaymagic;
12079     PL_dirty            = proto_perl->Tdirty;
12080     PL_localizing       = proto_perl->Tlocalizing;
12081
12082 #ifdef PERL_FLEXIBLE_EXCEPTIONS
12083     PL_protect          = proto_perl->Tprotect;
12084 #endif
12085     PL_errors           = sv_dup_inc(proto_perl->Terrors, param);
12086     PL_hv_fetch_ent_mh  = Nullhe;
12087     PL_modcount         = proto_perl->Tmodcount;
12088     PL_lastgotoprobe    = Nullop;
12089     PL_dumpindent       = proto_perl->Tdumpindent;
12090
12091     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12092     PL_sortstash        = hv_dup(proto_perl->Tsortstash, param);
12093     PL_firstgv          = gv_dup(proto_perl->Tfirstgv, param);
12094     PL_secondgv         = gv_dup(proto_perl->Tsecondgv, param);
12095     PL_sortcxix         = proto_perl->Tsortcxix;
12096     PL_efloatbuf        = Nullch;               /* reinits on demand */
12097     PL_efloatsize       = 0;                    /* reinits on demand */
12098
12099     /* regex stuff */
12100
12101     PL_screamfirst      = NULL;
12102     PL_screamnext       = NULL;
12103     PL_maxscream        = -1;                   /* reinits on demand */
12104     PL_lastscream       = Nullsv;
12105
12106     PL_watchaddr        = NULL;
12107     PL_watchok          = Nullch;
12108
12109     PL_regdummy         = proto_perl->Tregdummy;
12110     PL_regprecomp       = Nullch;
12111     PL_regnpar          = 0;
12112     PL_regsize          = 0;
12113     PL_colorset         = 0;            /* reinits PL_colors[] */
12114     /*PL_colors[6]      = {0,0,0,0,0,0};*/
12115     PL_reginput         = Nullch;
12116     PL_regbol           = Nullch;
12117     PL_regeol           = Nullch;
12118     PL_regstartp        = (I32*)NULL;
12119     PL_regendp          = (I32*)NULL;
12120     PL_reglastparen     = (U32*)NULL;
12121     PL_reglastcloseparen        = (U32*)NULL;
12122     PL_regtill          = Nullch;
12123     PL_reg_start_tmp    = (char**)NULL;
12124     PL_reg_start_tmpl   = 0;
12125     PL_regdata          = (struct reg_data*)NULL;
12126     PL_bostr            = Nullch;
12127     PL_reg_flags        = 0;
12128     PL_reg_eval_set     = 0;
12129     PL_regnarrate       = 0;
12130     PL_regprogram       = (regnode*)NULL;
12131     PL_regindent        = 0;
12132     PL_regcc            = (CURCUR*)NULL;
12133     PL_reg_call_cc      = (struct re_cc_state*)NULL;
12134     PL_reg_re           = (regexp*)NULL;
12135     PL_reg_ganch        = Nullch;
12136     PL_reg_sv           = Nullsv;
12137     PL_reg_match_utf8   = FALSE;
12138     PL_reg_magic        = (MAGIC*)NULL;
12139     PL_reg_oldpos       = 0;
12140     PL_reg_oldcurpm     = (PMOP*)NULL;
12141     PL_reg_curpm        = (PMOP*)NULL;
12142     PL_reg_oldsaved     = Nullch;
12143     PL_reg_oldsavedlen  = 0;
12144 #ifdef PERL_COPY_ON_WRITE
12145     PL_nrs              = Nullsv;
12146 #endif
12147     PL_reg_maxiter      = 0;
12148     PL_reg_leftiter     = 0;
12149     PL_reg_poscache     = Nullch;
12150     PL_reg_poscache_size= 0;
12151
12152     /* RE engine - function pointers */
12153     PL_regcompp         = proto_perl->Tregcompp;
12154     PL_regexecp         = proto_perl->Tregexecp;
12155     PL_regint_start     = proto_perl->Tregint_start;
12156     PL_regint_string    = proto_perl->Tregint_string;
12157     PL_regfree          = proto_perl->Tregfree;
12158
12159     PL_reginterp_cnt    = 0;
12160     PL_reg_starttry     = 0;
12161
12162     /* Pluggable optimizer */
12163     PL_peepp            = proto_perl->Tpeepp;
12164
12165     PL_stashcache       = newHV();
12166
12167     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12168         ptr_table_free(PL_ptr_table);
12169         PL_ptr_table = NULL;
12170     }
12171
12172     /* Call the ->CLONE method, if it exists, for each of the stashes
12173        identified by sv_dup() above.
12174     */
12175     while(av_len(param->stashes) != -1) {
12176         HV* stash = (HV*) av_shift(param->stashes);
12177         GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12178         if (cloner && GvCV(cloner)) {
12179             dSP;
12180             ENTER;
12181             SAVETMPS;
12182             PUSHMARK(SP);
12183            XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
12184             PUTBACK;
12185             call_sv((SV*)GvCV(cloner), G_DISCARD);
12186             FREETMPS;
12187             LEAVE;
12188         }
12189     }
12190
12191     SvREFCNT_dec(param->stashes);
12192
12193     return my_perl;
12194 }
12195
12196 #endif /* USE_ITHREADS */
12197
12198 /*
12199 =head1 Unicode Support
12200
12201 =for apidoc sv_recode_to_utf8
12202
12203 The encoding is assumed to be an Encode object, on entry the PV
12204 of the sv is assumed to be octets in that encoding, and the sv
12205 will be converted into Unicode (and UTF-8).
12206
12207 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12208 is not a reference, nothing is done to the sv.  If the encoding is not
12209 an C<Encode::XS> Encoding object, bad things will happen.
12210 (See F<lib/encoding.pm> and L<Encode>).
12211
12212 The PV of the sv is returned.
12213
12214 =cut */
12215
12216 char *
12217 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12218 {
12219     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12220         SV *uni;
12221         STRLEN len;
12222         char *s;
12223         dSP;
12224         ENTER;
12225         SAVETMPS;
12226         save_re_context();
12227         PUSHMARK(sp);
12228         EXTEND(SP, 3);
12229         XPUSHs(encoding);
12230         XPUSHs(sv);
12231 /*
12232   NI-S 2002/07/09
12233   Passing sv_yes is wrong - it needs to be or'ed set of constants
12234   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12235   remove converted chars from source.
12236
12237   Both will default the value - let them.
12238
12239         XPUSHs(&PL_sv_yes);
12240 */
12241         PUTBACK;
12242         call_method("decode", G_SCALAR);
12243         SPAGAIN;
12244         uni = POPs;
12245         PUTBACK;
12246         s = SvPV(uni, len);
12247         if (s != SvPVX(sv)) {
12248             SvGROW(sv, len + 1);
12249             Move(s, SvPVX(sv), len, char);
12250             SvCUR_set(sv, len);
12251             SvPVX(sv)[len] = 0;
12252         }
12253         FREETMPS;
12254         LEAVE;
12255         SvUTF8_on(sv);
12256     }
12257     return SvPVX(sv);
12258 }
12259
12260 /*
12261 =for apidoc sv_cat_decode
12262
12263 The encoding is assumed to be an Encode object, the PV of the ssv is
12264 assumed to be octets in that encoding and decoding the input starts
12265 from the position which (PV + *offset) pointed to.  The dsv will be
12266 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
12267 when the string tstr appears in decoding output or the input ends on
12268 the PV of the ssv. The value which the offset points will be modified
12269 to the last input position on the ssv.
12270
12271 Returns TRUE if the terminator was found, else returns FALSE.
12272
12273 =cut */
12274
12275 bool
12276 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12277                    SV *ssv, int *offset, char *tstr, int tlen)
12278 {
12279     bool ret = FALSE;
12280     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12281         SV *offsv;
12282         dSP;
12283         ENTER;
12284         SAVETMPS;
12285         save_re_context();
12286         PUSHMARK(sp);
12287         EXTEND(SP, 6);
12288         XPUSHs(encoding);
12289         XPUSHs(dsv);
12290         XPUSHs(ssv);
12291         XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12292         XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12293         PUTBACK;
12294         call_method("cat_decode", G_SCALAR);
12295         SPAGAIN;
12296         ret = SvTRUE(TOPs);
12297         *offset = SvIV(offsv);
12298         PUTBACK;
12299         FREETMPS;
12300         LEAVE;
12301     }
12302     else
12303         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12304     return ret;
12305 }
12306