sv.c

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