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