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