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