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