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