sv.c

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