sv.c

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