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