sv.c

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