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