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