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