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