sv.c

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