sv.c

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