sv.c

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