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_pvn_force(sv,lp);
7839     sv_utf8_downgrade(sv,0);
7840     *lp = SvCUR(sv);
7841     return SvPVX(sv);
7842 }
7843
7844 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
7845  * this function provided for binary compatibility only
7846  */
7847
7848 char *
7849 Perl_sv_pvutf8(pTHX_ SV *sv)
7850 {
7851     sv_utf8_upgrade(sv);
7852     return sv_pv(sv);
7853 }
7854
7855 /*
7856 =for apidoc sv_pvutf8
7857
7858 Use the C<SvPVutf8_nolen> macro instead
7859
7860 =for apidoc sv_pvutf8n
7861
7862 A private implementation of the C<SvPVutf8> macro for compilers
7863 which can't cope with complex macro expressions. Always use the macro
7864 instead.
7865
7866 =cut
7867 */
7868
7869 char *
7870 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
7871 {
7872     sv_utf8_upgrade(sv);
7873     return sv_pvn(sv,lp);
7874 }
7875
7876 /*
7877 =for apidoc sv_pvutf8n_force
7878
7879 A private implementation of the C<SvPVutf8_force> macro for compilers
7880 which can't cope with complex macro expressions. Always use the macro
7881 instead.
7882
7883 =cut
7884 */
7885
7886 char *
7887 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7888 {
7889     sv_pvn_force(sv,lp);
7890     sv_utf8_upgrade(sv);
7891     *lp = SvCUR(sv);
7892     return SvPVX(sv);
7893 }
7894
7895 /*
7896 =for apidoc sv_reftype
7897
7898 Returns a string describing what the SV is a reference to.
7899
7900 =cut
7901 */
7902
7903 char *
7904 Perl_sv_reftype(pTHX_ SV *sv, int ob)
7905 {
7906     if (ob && SvOBJECT(sv)) {
7907         if (HvNAME(SvSTASH(sv)))
7908             return HvNAME(SvSTASH(sv));
7909         else
7910             return "__ANON__";
7911     }
7912     else {
7913         switch (SvTYPE(sv)) {
7914         case SVt_NULL:
7915         case SVt_IV:
7916         case SVt_NV:
7917         case SVt_RV:
7918         case SVt_PV:
7919         case SVt_PVIV:
7920         case SVt_PVNV:
7921         case SVt_PVMG:
7922         case SVt_PVBM:
7923                                 if (SvVOK(sv))
7924                                     return "VSTRING";
7925                                 if (SvROK(sv))
7926                                     return "REF";
7927                                 else
7928                                     return "SCALAR";
7929
7930         case SVt_PVLV:          return SvROK(sv) ? "REF"
7931                                 /* tied lvalues should appear to be
7932                                  * scalars for backwards compatitbility */
7933                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7934                                     ? "SCALAR" : "LVALUE";
7935         case SVt_PVAV:          return "ARRAY";
7936         case SVt_PVHV:          return "HASH";
7937         case SVt_PVCV:          return "CODE";
7938         case SVt_PVGV:          return "GLOB";
7939         case SVt_PVFM:          return "FORMAT";
7940         case SVt_PVIO:          return "IO";
7941         default:                return "UNKNOWN";
7942         }
7943     }
7944 }
7945
7946 /*
7947 =for apidoc sv_isobject
7948
7949 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7950 object.  If the SV is not an RV, or if the object is not blessed, then this
7951 will return false.
7952
7953 =cut
7954 */
7955
7956 int
7957 Perl_sv_isobject(pTHX_ SV *sv)
7958 {
7959     if (!sv)
7960         return 0;
7961     if (SvGMAGICAL(sv))
7962         mg_get(sv);
7963     if (!SvROK(sv))
7964         return 0;
7965     sv = (SV*)SvRV(sv);
7966     if (!SvOBJECT(sv))
7967         return 0;
7968     return 1;
7969 }
7970
7971 /*
7972 =for apidoc sv_isa
7973
7974 Returns a boolean indicating whether the SV is blessed into the specified
7975 class.  This does not check for subtypes; use C<sv_derived_from> to verify
7976 an inheritance relationship.
7977
7978 =cut
7979 */
7980
7981 int
7982 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7983 {
7984     if (!sv)
7985         return 0;
7986     if (SvGMAGICAL(sv))
7987         mg_get(sv);
7988     if (!SvROK(sv))
7989         return 0;
7990     sv = (SV*)SvRV(sv);
7991     if (!SvOBJECT(sv))
7992         return 0;
7993     if (!HvNAME(SvSTASH(sv)))
7994         return 0;
7995
7996     return strEQ(HvNAME(SvSTASH(sv)), name);
7997 }
7998
7999 /*
8000 =for apidoc newSVrv
8001
8002 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
8003 it will be upgraded to one.  If C<classname> is non-null then the new SV will
8004 be blessed in the specified package.  The new SV is returned and its
8005 reference count is 1.
8006
8007 =cut
8008 */
8009
8010 SV*
8011 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8012 {
8013     SV *sv;
8014
8015     new_SV(sv);
8016
8017     SV_CHECK_THINKFIRST_COW_DROP(rv);
8018     SvAMAGIC_off(rv);
8019
8020     if (SvTYPE(rv) >= SVt_PVMG) {
8021         U32 refcnt = SvREFCNT(rv);
8022         SvREFCNT(rv) = 0;
8023         sv_clear(rv);
8024         SvFLAGS(rv) = 0;
8025         SvREFCNT(rv) = refcnt;
8026     }
8027
8028     if (SvTYPE(rv) < SVt_RV)
8029         sv_upgrade(rv, SVt_RV);
8030     else if (SvTYPE(rv) > SVt_RV) {
8031         (void)SvOOK_off(rv);
8032         if (SvPVX(rv) && SvLEN(rv))
8033             Safefree(SvPVX(rv));
8034         SvCUR_set(rv, 0);
8035         SvLEN_set(rv, 0);
8036     }
8037
8038     (void)SvOK_off(rv);
8039     SvRV(rv) = sv;
8040     SvROK_on(rv);
8041
8042     if (classname) {
8043         HV* stash = gv_stashpv(classname, TRUE);
8044         (void)sv_bless(rv, stash);
8045     }
8046     return sv;
8047 }
8048
8049 /*
8050 =for apidoc sv_setref_pv
8051
8052 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
8053 argument will be upgraded to an RV.  That RV will be modified to point to
8054 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8055 into the SV.  The C<classname> argument indicates the package for the
8056 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
8057 will have a reference count of 1, and the RV will be returned.
8058
8059 Do not use with other Perl types such as HV, AV, SV, CV, because those
8060 objects will become corrupted by the pointer copy process.
8061
8062 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8063
8064 =cut
8065 */
8066
8067 SV*
8068 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8069 {
8070     if (!pv) {
8071         sv_setsv(rv, &PL_sv_undef);
8072         SvSETMAGIC(rv);
8073     }
8074     else
8075         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8076     return rv;
8077 }
8078
8079 /*
8080 =for apidoc sv_setref_iv
8081
8082 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
8083 argument will be upgraded to an RV.  That RV will be modified to point to
8084 the new SV.  The C<classname> argument indicates the package for the
8085 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
8086 will have a reference count of 1, and the RV will be returned.
8087
8088 =cut
8089 */
8090
8091 SV*
8092 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8093 {
8094     sv_setiv(newSVrv(rv,classname), iv);
8095     return rv;
8096 }
8097
8098 /*
8099 =for apidoc sv_setref_uv
8100
8101 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
8102 argument will be upgraded to an RV.  That RV will be modified to point to
8103 the new SV.  The C<classname> argument indicates the package for the
8104 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
8105 will have a reference count of 1, and the RV will be returned.
8106
8107 =cut
8108 */
8109
8110 SV*
8111 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8112 {
8113     sv_setuv(newSVrv(rv,classname), uv);
8114     return rv;
8115 }
8116
8117 /*
8118 =for apidoc sv_setref_nv
8119
8120 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
8121 argument will be upgraded to an RV.  That RV will be modified to point to
8122 the new SV.  The C<classname> argument indicates the package for the
8123 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
8124 will have a reference count of 1, and the RV will be returned.
8125
8126 =cut
8127 */
8128
8129 SV*
8130 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8131 {
8132     sv_setnv(newSVrv(rv,classname), nv);
8133     return rv;
8134 }
8135
8136 /*
8137 =for apidoc sv_setref_pvn
8138
8139 Copies a string into a new SV, optionally blessing the SV.  The length of the
8140 string must be specified with C<n>.  The C<rv> argument will be upgraded to
8141 an RV.  That RV will be modified to point to the new SV.  The C<classname>
8142 argument indicates the package for the blessing.  Set C<classname> to
8143 C<Nullch> to avoid the blessing.  The new SV will have a reference count
8144 of 1, and the RV will be returned.
8145
8146 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8147
8148 =cut
8149 */
8150
8151 SV*
8152 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8153 {
8154     sv_setpvn(newSVrv(rv,classname), pv, n);
8155     return rv;
8156 }
8157
8158 /*
8159 =for apidoc sv_bless
8160
8161 Blesses an SV into a specified package.  The SV must be an RV.  The package
8162 must be designated by its stash (see C<gv_stashpv()>).  The reference count
8163 of the SV is unaffected.
8164
8165 =cut
8166 */
8167
8168 SV*
8169 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8170 {
8171     SV *tmpRef;
8172     if (!SvROK(sv))
8173         Perl_croak(aTHX_ "Can't bless non-reference value");
8174     tmpRef = SvRV(sv);
8175     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8176         if (SvREADONLY(tmpRef))
8177             Perl_croak(aTHX_ PL_no_modify);
8178         if (SvOBJECT(tmpRef)) {
8179             if (SvTYPE(tmpRef) != SVt_PVIO)
8180                 --PL_sv_objcount;
8181             SvREFCNT_dec(SvSTASH(tmpRef));
8182         }
8183     }
8184     SvOBJECT_on(tmpRef);
8185     if (SvTYPE(tmpRef) != SVt_PVIO)
8186         ++PL_sv_objcount;
8187     (void)SvUPGRADE(tmpRef, SVt_PVMG);
8188     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
8189
8190     if (Gv_AMG(stash))
8191         SvAMAGIC_on(sv);
8192     else
8193         SvAMAGIC_off(sv);
8194
8195     if(SvSMAGICAL(tmpRef))
8196         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8197             mg_set(tmpRef);
8198
8199
8200
8201     return sv;
8202 }
8203
8204 /* Downgrades a PVGV to a PVMG.
8205  */
8206
8207 STATIC void
8208 S_sv_unglob(pTHX_ SV *sv)
8209 {
8210     void *xpvmg;
8211
8212     assert(SvTYPE(sv) == SVt_PVGV);
8213     SvFAKE_off(sv);
8214     if (GvGP(sv))
8215         gp_free((GV*)sv);
8216     if (GvSTASH(sv)) {
8217         SvREFCNT_dec(GvSTASH(sv));
8218         GvSTASH(sv) = Nullhv;
8219     }
8220     sv_unmagic(sv, PERL_MAGIC_glob);
8221     Safefree(GvNAME(sv));
8222     GvMULTI_off(sv);
8223
8224     /* need to keep SvANY(sv) in the right arena */
8225     xpvmg = new_XPVMG();
8226     StructCopy(SvANY(sv), xpvmg, XPVMG);
8227     del_XPVGV(SvANY(sv));
8228     SvANY(sv) = xpvmg;
8229
8230     SvFLAGS(sv) &= ~SVTYPEMASK;
8231     SvFLAGS(sv) |= SVt_PVMG;
8232 }
8233
8234 /*
8235 =for apidoc sv_unref_flags
8236
8237 Unsets the RV status of the SV, and decrements the reference count of
8238 whatever was being referenced by the RV.  This can almost be thought of
8239 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
8240 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8241 (otherwise the decrementing is conditional on the reference count being
8242 different from one or the reference being a readonly SV).
8243 See C<SvROK_off>.
8244
8245 =cut
8246 */
8247
8248 void
8249 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8250 {
8251     SV* rv = SvRV(sv);
8252
8253     if (SvWEAKREF(sv)) {
8254         sv_del_backref(sv);
8255         SvWEAKREF_off(sv);
8256         SvRV(sv) = 0;
8257         return;
8258     }
8259     SvRV(sv) = 0;
8260     SvROK_off(sv);
8261     /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8262        assigned to as BEGIN {$a = \"Foo"} will fail.  */
8263     if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8264         SvREFCNT_dec(rv);
8265     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8266         sv_2mortal(rv);         /* Schedule for freeing later */
8267 }
8268
8269 /*
8270 =for apidoc sv_unref
8271
8272 Unsets the RV status of the SV, and decrements the reference count of
8273 whatever was being referenced by the RV.  This can almost be thought of
8274 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
8275 being zero.  See C<SvROK_off>.
8276
8277 =cut
8278 */
8279
8280 void
8281 Perl_sv_unref(pTHX_ SV *sv)
8282 {
8283     sv_unref_flags(sv, 0);
8284 }
8285
8286 /*
8287 =for apidoc sv_taint
8288
8289 Taint an SV. Use C<SvTAINTED_on> instead.
8290 =cut
8291 */
8292
8293 void
8294 Perl_sv_taint(pTHX_ SV *sv)
8295 {
8296     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8297 }
8298
8299 /*
8300 =for apidoc sv_untaint
8301
8302 Untaint an SV. Use C<SvTAINTED_off> instead.
8303 =cut
8304 */
8305
8306 void
8307 Perl_sv_untaint(pTHX_ SV *sv)
8308 {
8309     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8310         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8311         if (mg)
8312             mg->mg_len &= ~1;
8313     }
8314 }
8315
8316 /*
8317 =for apidoc sv_tainted
8318
8319 Test an SV for taintedness. Use C<SvTAINTED> instead.
8320 =cut
8321 */
8322
8323 bool
8324 Perl_sv_tainted(pTHX_ SV *sv)
8325 {
8326     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8327         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8328         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8329             return TRUE;
8330     }
8331     return FALSE;
8332 }
8333
8334 /*
8335 =for apidoc sv_setpviv
8336
8337 Copies an integer into the given SV, also updating its string value.
8338 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
8339
8340 =cut
8341 */
8342
8343 void
8344 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8345 {
8346     char buf[TYPE_CHARS(UV)];
8347     char *ebuf;
8348     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8349
8350     sv_setpvn(sv, ptr, ebuf - ptr);
8351 }
8352
8353 /*
8354 =for apidoc sv_setpviv_mg
8355
8356 Like C<sv_setpviv>, but also handles 'set' magic.
8357
8358 =cut
8359 */
8360
8361 void
8362 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8363 {
8364     char buf[TYPE_CHARS(UV)];
8365     char *ebuf;
8366     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8367
8368     sv_setpvn(sv, ptr, ebuf - ptr);
8369     SvSETMAGIC(sv);
8370 }
8371
8372 #if defined(PERL_IMPLICIT_CONTEXT)
8373
8374 /* pTHX_ magic can't cope with varargs, so this is a no-context
8375  * version of the main function, (which may itself be aliased to us).
8376  * Don't access this version directly.
8377  */
8378
8379 void
8380 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8381 {
8382     dTHX;
8383     va_list args;
8384     va_start(args, pat);
8385     sv_vsetpvf(sv, pat, &args);
8386     va_end(args);
8387 }
8388
8389 /* pTHX_ magic can't cope with varargs, so this is a no-context
8390  * version of the main function, (which may itself be aliased to us).
8391  * Don't access this version directly.
8392  */
8393
8394 void
8395 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8396 {
8397     dTHX;
8398     va_list args;
8399     va_start(args, pat);
8400     sv_vsetpvf_mg(sv, pat, &args);
8401     va_end(args);
8402 }
8403 #endif
8404
8405 /*
8406 =for apidoc sv_setpvf
8407
8408 Processes its arguments like C<sprintf> and sets an SV to the formatted
8409 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
8410
8411 =cut
8412 */
8413
8414 void
8415 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8416 {
8417     va_list args;
8418     va_start(args, pat);
8419     sv_vsetpvf(sv, pat, &args);
8420     va_end(args);
8421 }
8422
8423 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
8424
8425 void
8426 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8427 {
8428     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8429 }
8430
8431 /*
8432 =for apidoc sv_setpvf_mg
8433
8434 Like C<sv_setpvf>, but also handles 'set' magic.
8435
8436 =cut
8437 */
8438
8439 void
8440 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8441 {
8442     va_list args;
8443     va_start(args, pat);
8444     sv_vsetpvf_mg(sv, pat, &args);
8445     va_end(args);
8446 }
8447
8448 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
8449
8450 void
8451 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8452 {
8453     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8454     SvSETMAGIC(sv);
8455 }
8456
8457 #if defined(PERL_IMPLICIT_CONTEXT)
8458
8459 /* pTHX_ magic can't cope with varargs, so this is a no-context
8460  * version of the main function, (which may itself be aliased to us).
8461  * Don't access this version directly.
8462  */
8463
8464 void
8465 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8466 {
8467     dTHX;
8468     va_list args;
8469     va_start(args, pat);
8470     sv_vcatpvf(sv, pat, &args);
8471     va_end(args);
8472 }
8473
8474 /* pTHX_ magic can't cope with varargs, so this is a no-context
8475  * version of the main function, (which may itself be aliased to us).
8476  * Don't access this version directly.
8477  */
8478
8479 void
8480 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8481 {
8482     dTHX;
8483     va_list args;
8484     va_start(args, pat);
8485     sv_vcatpvf_mg(sv, pat, &args);
8486     va_end(args);
8487 }
8488 #endif
8489
8490 /*
8491 =for apidoc sv_catpvf
8492
8493 Processes its arguments like C<sprintf> and appends the formatted
8494 output to an SV.  If the appended data contains "wide" characters
8495 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8496 and characters >255 formatted with %c), the original SV might get
8497 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.
8498 C<SvSETMAGIC()> must typically be called after calling this function
8499 to handle 'set' magic.
8500
8501 =cut */
8502
8503 void
8504 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8505 {
8506     va_list args;
8507     va_start(args, pat);
8508     sv_vcatpvf(sv, pat, &args);
8509     va_end(args);
8510 }
8511
8512 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
8513
8514 void
8515 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8516 {
8517     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8518 }
8519
8520 /*
8521 =for apidoc sv_catpvf_mg
8522
8523 Like C<sv_catpvf>, but also handles 'set' magic.
8524
8525 =cut
8526 */
8527
8528 void
8529 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8530 {
8531     va_list args;
8532     va_start(args, pat);
8533     sv_vcatpvf_mg(sv, pat, &args);
8534     va_end(args);
8535 }
8536
8537 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
8538
8539 void
8540 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8541 {
8542     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8543     SvSETMAGIC(sv);
8544 }
8545
8546 /*
8547 =for apidoc sv_vsetpvfn
8548
8549 Works like C<vcatpvfn> but copies the text into the SV instead of
8550 appending it.
8551
8552 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
8553
8554 =cut
8555 */
8556
8557 void
8558 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8559 {
8560     sv_setpvn(sv, "", 0);
8561     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8562 }
8563
8564 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8565
8566 STATIC I32
8567 S_expect_number(pTHX_ char** pattern)
8568 {
8569     I32 var = 0;
8570     switch (**pattern) {
8571     case '1': case '2': case '3':
8572     case '4': case '5': case '6':
8573     case '7': case '8': case '9':
8574         while (isDIGIT(**pattern))
8575             var = var * 10 + (*(*pattern)++ - '0');
8576     }
8577     return var;
8578 }
8579 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8580
8581 static char *
8582 F0convert(NV nv, char *endbuf, STRLEN *len)
8583 {
8584     int neg = nv < 0;
8585     UV uv;
8586     char *p = endbuf;
8587
8588     if (neg)
8589         nv = -nv;
8590     if (nv < UV_MAX) {
8591         nv += 0.5;
8592         uv = (UV)nv;
8593         if (uv & 1 && uv == nv)
8594             uv--;                       /* Round to even */
8595         do {
8596             unsigned dig = uv % 10;
8597             *--p = '0' + dig;
8598         } while (uv /= 10);
8599         if (neg)
8600             *--p = '-';
8601         *len = endbuf - p;
8602         return p;
8603     }
8604     return Nullch;
8605 }
8606
8607
8608 /*
8609 =for apidoc sv_vcatpvfn
8610
8611 Processes its arguments like C<vsprintf> and appends the formatted output
8612 to an SV.  Uses an array of SVs if the C style variable argument list is
8613 missing (NULL).  When running with taint checks enabled, indicates via
8614 C<maybe_tainted> if results are untrustworthy (often due to the use of
8615 locales).
8616
8617 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
8618
8619 =cut
8620 */
8621
8622 void
8623 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8624 {
8625     char *p;
8626     char *q;
8627     char *patend;
8628     STRLEN origlen;
8629     I32 svix = 0;
8630     static char nullstr[] = "(null)";
8631     SV *argsv = Nullsv;
8632     bool has_utf8; /* has the result utf8? */
8633     bool pat_utf8; /* the pattern is in utf8? */
8634     SV *nsv = Nullsv;
8635     /* Times 4: a decimal digit takes more than 3 binary digits.
8636      * NV_DIG: mantissa takes than many decimal digits.
8637      * Plus 32: Playing safe. */
8638     char ebuf[IV_DIG * 4 + NV_DIG + 32];
8639     /* large enough for "%#.#f" --chip */
8640     /* what about long double NVs? --jhi */
8641
8642     has_utf8 = pat_utf8 = DO_UTF8(sv);
8643
8644     /* no matter what, this is a string now */
8645     (void)SvPV_force(sv, origlen);
8646
8647     /* special-case "", "%s", and "%_" */
8648     if (patlen == 0)
8649         return;
8650     if (patlen == 2 && pat[0] == '%') {
8651         switch (pat[1]) {
8652         case 's':
8653             if (args) {
8654                 char *s = va_arg(*args, char*);
8655                 sv_catpv(sv, s ? s : nullstr);
8656             }
8657             else if (svix < svmax) {
8658                 sv_catsv(sv, *svargs);
8659                 if (DO_UTF8(*svargs))
8660                     SvUTF8_on(sv);
8661             }
8662             return;
8663         case '_':
8664             if (args) {
8665                 argsv = va_arg(*args, SV*);
8666                 sv_catsv(sv, argsv);
8667                 if (DO_UTF8(argsv))
8668                     SvUTF8_on(sv);
8669                 return;
8670             }
8671             /* See comment on '_' below */
8672             break;
8673         }
8674     }
8675
8676 #ifndef USE_LONG_DOUBLE
8677     /* special-case "%.<number>[gf]" */
8678     if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8679          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8680         unsigned digits = 0;
8681         const char *pp;
8682
8683         pp = pat + 2;
8684         while (*pp >= '0' && *pp <= '9')
8685             digits = 10 * digits + (*pp++ - '0');
8686         if (pp - pat == (int)patlen - 1) {
8687             NV nv;
8688
8689             if (args)
8690                 nv = (NV)va_arg(*args, double);
8691             else if (svix < svmax)
8692                 nv = SvNV(*svargs);
8693             else
8694                 return;
8695             if (*pp == 'g') {
8696                 /* Add check for digits != 0 because it seems that some
8697                    gconverts are buggy in this case, and we don't yet have
8698                    a Configure test for this.  */
8699                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8700                      /* 0, point, slack */
8701                     Gconvert(nv, (int)digits, 0, ebuf);
8702                     sv_catpv(sv, ebuf);
8703                     if (*ebuf)  /* May return an empty string for digits==0 */
8704                         return;
8705                 }
8706             } else if (!digits) {
8707                 STRLEN l;
8708
8709                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8710                     sv_catpvn(sv, p, l);
8711                     return;
8712                 }
8713             }
8714         }
8715     }
8716 #endif /* !USE_LONG_DOUBLE */
8717
8718     if (!args && svix < svmax && DO_UTF8(*svargs))
8719         has_utf8 = TRUE;
8720
8721     patend = (char*)pat + patlen;
8722     for (p = (char*)pat; p < patend; p = q) {
8723         bool alt = FALSE;
8724         bool left = FALSE;
8725         bool vectorize = FALSE;
8726         bool vectorarg = FALSE;
8727         bool vec_utf8 = FALSE;
8728         char fill = ' ';
8729         char plus = 0;
8730         char intsize = 0;
8731         STRLEN width = 0;
8732         STRLEN zeros = 0;
8733         bool has_precis = FALSE;
8734         STRLEN precis = 0;
8735         I32 osvix = svix;
8736         bool is_utf8 = FALSE;  /* is this item utf8?   */
8737 #ifdef HAS_LDBL_SPRINTF_BUG
8738         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8739            with sfio - Allen <allens@cpan.org> */
8740         bool fix_ldbl_sprintf_bug = FALSE;
8741 #endif
8742
8743         char esignbuf[4];
8744         U8 utf8buf[UTF8_MAXLEN+1];
8745         STRLEN esignlen = 0;
8746
8747         char *eptr = Nullch;
8748         STRLEN elen = 0;
8749         SV *vecsv = Nullsv;
8750         U8 *vecstr = Null(U8*);
8751         STRLEN veclen = 0;
8752         char c = 0;
8753         int i;
8754         unsigned base = 0;
8755         IV iv = 0;
8756         UV uv = 0;
8757         /* we need a long double target in case HAS_LONG_DOUBLE but
8758            not USE_LONG_DOUBLE
8759         */
8760 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8761         long double nv;
8762 #else
8763         NV nv;
8764 #endif
8765         STRLEN have;
8766         STRLEN need;
8767         STRLEN gap;
8768         char *dotstr = ".";
8769         STRLEN dotstrlen = 1;
8770         I32 efix = 0; /* explicit format parameter index */
8771         I32 ewix = 0; /* explicit width index */
8772         I32 epix = 0; /* explicit precision index */
8773         I32 evix = 0; /* explicit vector index */
8774         bool asterisk = FALSE;
8775
8776         /* echo everything up to the next format specification */
8777         for (q = p; q < patend && *q != '%'; ++q) ;
8778         if (q > p) {
8779             if (has_utf8 && !pat_utf8)
8780                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8781             else
8782                 sv_catpvn(sv, p, q - p);
8783             p = q;
8784         }
8785         if (q++ >= patend)
8786             break;
8787
8788 /*
8789     We allow format specification elements in this order:
8790         \d+\$              explicit format parameter index
8791         [-+ 0#]+           flags
8792         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
8793         0                  flag (as above): repeated to allow "v02"
8794         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
8795         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8796         [hlqLV]            size
8797     [%bcdefginopsux_DFOUX] format (mandatory)
8798 */
8799         if (EXPECT_NUMBER(q, width)) {
8800             if (*q == '$') {
8801                 ++q;
8802                 efix = width;
8803             } else {
8804                 goto gotwidth;
8805             }
8806         }
8807
8808         /* FLAGS */
8809
8810         while (*q) {
8811             switch (*q) {
8812             case ' ':
8813             case '+':
8814                 plus = *q++;
8815                 continue;
8816
8817             case '-':
8818                 left = TRUE;
8819                 q++;
8820                 continue;
8821
8822             case '0':
8823                 fill = *q++;
8824                 continue;
8825
8826             case '#':
8827                 alt = TRUE;
8828                 q++;
8829                 continue;
8830
8831             default:
8832                 break;
8833             }
8834             break;
8835         }
8836
8837       tryasterisk:
8838         if (*q == '*') {
8839             q++;
8840             if (EXPECT_NUMBER(q, ewix))
8841                 if (*q++ != '$')
8842                     goto unknown;
8843             asterisk = TRUE;
8844         }
8845         if (*q == 'v') {
8846             q++;
8847             if (vectorize)
8848                 goto unknown;
8849             if ((vectorarg = asterisk)) {
8850                 evix = ewix;
8851                 ewix = 0;
8852                 asterisk = FALSE;
8853             }
8854             vectorize = TRUE;
8855             goto tryasterisk;
8856         }
8857
8858         if (!asterisk)
8859             if( *q == '0' )
8860                 fill = *q++;
8861             EXPECT_NUMBER(q, width);
8862
8863         if (vectorize) {
8864             if (vectorarg) {
8865                 if (args)
8866                     vecsv = va_arg(*args, SV*);
8867                 else
8868                     vecsv = (evix ? evix <= svmax : svix < svmax) ?
8869                         svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
8870                 dotstr = SvPVx(vecsv, dotstrlen);
8871                 if (DO_UTF8(vecsv))
8872                     is_utf8 = TRUE;
8873             }
8874             if (args) {
8875                 vecsv = va_arg(*args, SV*);
8876                 vecstr = (U8*)SvPVx(vecsv,veclen);
8877                 vec_utf8 = DO_UTF8(vecsv);
8878             }
8879             else if (efix ? efix <= svmax : svix < svmax) {
8880                 vecsv = svargs[efix ? efix-1 : svix++];
8881                 vecstr = (U8*)SvPVx(vecsv,veclen);
8882                 vec_utf8 = DO_UTF8(vecsv);
8883             }
8884             else {
8885                 vecstr = (U8*)"";
8886                 veclen = 0;
8887             }
8888         }
8889
8890         if (asterisk) {
8891             if (args)
8892                 i = va_arg(*args, int);
8893             else
8894                 i = (ewix ? ewix <= svmax : svix < svmax) ?
8895                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8896             left |= (i < 0);
8897             width = (i < 0) ? -i : i;
8898         }
8899       gotwidth:
8900
8901         /* PRECISION */
8902
8903         if (*q == '.') {
8904             q++;
8905             if (*q == '*') {
8906                 q++;
8907                 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8908                     goto unknown;
8909                 /* XXX: todo, support specified precision parameter */
8910                 if (epix)
8911                     goto unknown;
8912                 if (args)
8913                     i = va_arg(*args, int);
8914                 else
8915                     i = (ewix ? ewix <= svmax : svix < svmax)
8916                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8917                 precis = (i < 0) ? 0 : i;
8918             }
8919             else {
8920                 precis = 0;
8921                 while (isDIGIT(*q))
8922                     precis = precis * 10 + (*q++ - '0');
8923             }
8924             has_precis = TRUE;
8925         }
8926
8927         /* SIZE */
8928
8929         switch (*q) {
8930 #ifdef WIN32
8931         case 'I':                       /* Ix, I32x, and I64x */
8932 #  ifdef WIN64
8933             if (q[1] == '6' && q[2] == '4') {
8934                 q += 3;
8935                 intsize = 'q';
8936                 break;
8937             }
8938 #  endif
8939             if (q[1] == '3' && q[2] == '2') {
8940                 q += 3;
8941                 break;
8942             }
8943 #  ifdef WIN64
8944             intsize = 'q';
8945 #  endif
8946             q++;
8947             break;
8948 #endif
8949 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8950         case 'L':                       /* Ld */
8951             /* FALL THROUGH */
8952 #ifdef HAS_QUAD
8953         case 'q':                       /* qd */
8954 #endif
8955             intsize = 'q';
8956             q++;
8957             break;
8958 #endif
8959         case 'l':
8960 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8961             if (*(q + 1) == 'l') {      /* lld, llf */
8962                 intsize = 'q';
8963                 q += 2;
8964                 break;
8965              }
8966 #endif
8967             /* FALL THROUGH */
8968         case 'h':
8969             /* FALL THROUGH */
8970         case 'V':
8971             intsize = *q++;
8972             break;
8973         }
8974
8975         /* CONVERSION */
8976
8977         if (*q == '%') {
8978             eptr = q++;
8979             elen = 1;
8980             goto string;
8981         }
8982
8983         if (vectorize)
8984             argsv = vecsv;
8985         else if (!args)
8986             argsv = (efix ? efix <= svmax : svix < svmax) ?
8987                     svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8988
8989         switch (c = *q++) {
8990
8991             /* STRINGS */
8992
8993         case 'c':
8994             uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8995             if ((uv > 255 ||
8996                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8997                 && !IN_BYTES) {
8998                 eptr = (char*)utf8buf;
8999                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9000                 is_utf8 = TRUE;
9001             }
9002             else {
9003                 c = (char)uv;
9004                 eptr = &c;
9005                 elen = 1;
9006             }
9007             goto string;
9008
9009         case 's':
9010             if (args && !vectorize) {
9011                 eptr = va_arg(*args, char*);
9012                 if (eptr)
9013 #ifdef MACOS_TRADITIONAL
9014                   /* On MacOS, %#s format is used for Pascal strings */
9015                   if (alt)
9016                     elen = *eptr++;
9017                   else
9018 #endif
9019                     elen = strlen(eptr);
9020                 else {
9021                     eptr = nullstr;
9022                     elen = sizeof nullstr - 1;
9023                 }
9024             }
9025             else {
9026                 eptr = SvPVx(argsv, elen);
9027                 if (DO_UTF8(argsv)) {
9028                     if (has_precis && precis < elen) {
9029                         I32 p = precis;
9030                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9031                         precis = p;
9032                     }
9033                     if (width) { /* fudge width (can't fudge elen) */
9034                         width += elen - sv_len_utf8(argsv);
9035                     }
9036                     is_utf8 = TRUE;
9037                 }
9038             }
9039             goto string;
9040
9041         case '_':
9042             /*
9043              * The "%_" hack might have to be changed someday,
9044              * if ISO or ANSI decide to use '_' for something.
9045              * So we keep it hidden from users' code.
9046              */
9047             if (!args || vectorize)
9048                 goto unknown;
9049             argsv = va_arg(*args, SV*);
9050             eptr = SvPVx(argsv, elen);
9051             if (DO_UTF8(argsv))
9052                 is_utf8 = TRUE;
9053
9054         string:
9055             vectorize = FALSE;
9056             if (has_precis && elen > precis)
9057                 elen = precis;
9058             break;
9059
9060             /* INTEGERS */
9061
9062         case 'p':
9063             if (alt || vectorize)
9064                 goto unknown;
9065             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9066             base = 16;
9067             goto integer;
9068
9069         case 'D':
9070 #ifdef IV_IS_QUAD
9071             intsize = 'q';
9072 #else
9073             intsize = 'l';
9074 #endif
9075             /* FALL THROUGH */
9076         case 'd':
9077         case 'i':
9078             if (vectorize) {
9079                 STRLEN ulen;
9080                 if (!veclen)
9081                     continue;
9082                 if (vec_utf8)
9083                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9084                                         UTF8_ALLOW_ANYUV);
9085                 else {
9086                     uv = *vecstr;
9087                     ulen = 1;
9088                 }
9089                 vecstr += ulen;
9090                 veclen -= ulen;
9091                 if (plus)
9092                      esignbuf[esignlen++] = plus;
9093             }
9094             else if (args) {
9095                 switch (intsize) {
9096                 case 'h':       iv = (short)va_arg(*args, int); break;
9097                 case 'l':       iv = va_arg(*args, long); break;
9098                 case 'V':       iv = va_arg(*args, IV); break;
9099                 default:        iv = va_arg(*args, int); break;
9100 #ifdef HAS_QUAD
9101                 case 'q':       iv = va_arg(*args, Quad_t); break;
9102 #endif
9103                 }
9104             }
9105             else {
9106                 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9107                 switch (intsize) {
9108                 case 'h':       iv = (short)tiv; break;
9109                 case 'l':       iv = (long)tiv; break;
9110                 case 'V':
9111                 default:        iv = tiv; break;
9112 #ifdef HAS_QUAD
9113                 case 'q':       iv = (Quad_t)tiv; break;
9114 #endif
9115                 }
9116             }
9117             if ( !vectorize )   /* we already set uv above */
9118             {
9119                 if (iv >= 0) {
9120                     uv = iv;
9121                     if (plus)
9122                         esignbuf[esignlen++] = plus;
9123                 }
9124                 else {
9125                     uv = -iv;
9126                     esignbuf[esignlen++] = '-';
9127                 }
9128             }
9129             base = 10;
9130             goto integer;
9131
9132         case 'U':
9133 #ifdef IV_IS_QUAD
9134             intsize = 'q';
9135 #else
9136             intsize = 'l';
9137 #endif
9138             /* FALL THROUGH */
9139         case 'u':
9140             base = 10;
9141             goto uns_integer;
9142
9143         case 'b':
9144             base = 2;
9145             goto uns_integer;
9146
9147         case 'O':
9148 #ifdef IV_IS_QUAD
9149             intsize = 'q';
9150 #else
9151             intsize = 'l';
9152 #endif
9153             /* FALL THROUGH */
9154         case 'o':
9155             base = 8;
9156             goto uns_integer;
9157
9158         case 'X':
9159         case 'x':
9160             base = 16;
9161
9162         uns_integer:
9163             if (vectorize) {
9164                 STRLEN ulen;
9165         vector:
9166                 if (!veclen)
9167                     continue;
9168                 if (vec_utf8)
9169                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9170                                         UTF8_ALLOW_ANYUV);
9171                 else {
9172                     uv = *vecstr;
9173                     ulen = 1;
9174                 }
9175                 vecstr += ulen;
9176                 veclen -= ulen;
9177             }
9178             else if (args) {
9179                 switch (intsize) {
9180                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
9181                 case 'l':  uv = va_arg(*args, unsigned long); break;
9182                 case 'V':  uv = va_arg(*args, UV); break;
9183                 default:   uv = va_arg(*args, unsigned); break;
9184 #ifdef HAS_QUAD
9185                 case 'q':  uv = va_arg(*args, Uquad_t); break;
9186 #endif
9187                 }
9188             }
9189             else {
9190                 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9191                 switch (intsize) {
9192                 case 'h':       uv = (unsigned short)tuv; break;
9193                 case 'l':       uv = (unsigned long)tuv; break;
9194                 case 'V':
9195                 default:        uv = tuv; break;
9196 #ifdef HAS_QUAD
9197                 case 'q':       uv = (Uquad_t)tuv; break;
9198 #endif
9199                 }
9200             }
9201
9202         integer:
9203             eptr = ebuf + sizeof ebuf;
9204             switch (base) {
9205                 unsigned dig;
9206             case 16:
9207                 if (!uv)
9208                     alt = FALSE;
9209                 p = (char*)((c == 'X')
9210                             ? "0123456789ABCDEF" : "0123456789abcdef");
9211                 do {
9212                     dig = uv & 15;
9213                     *--eptr = p[dig];
9214                 } while (uv >>= 4);
9215                 if (alt) {
9216                     esignbuf[esignlen++] = '0';
9217                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
9218                 }
9219                 break;
9220             case 8:
9221                 do {
9222                     dig = uv & 7;
9223                     *--eptr = '0' + dig;
9224                 } while (uv >>= 3);
9225                 if (alt && *eptr != '0')
9226                     *--eptr = '0';
9227                 break;
9228             case 2:
9229                 do {
9230                     dig = uv & 1;
9231                     *--eptr = '0' + dig;
9232                 } while (uv >>= 1);
9233                 if (alt) {
9234                     esignbuf[esignlen++] = '0';
9235                     esignbuf[esignlen++] = 'b';
9236                 }
9237                 break;
9238             default:            /* it had better be ten or less */
9239 #if defined(PERL_Y2KWARN)
9240                 if (ckWARN(WARN_Y2K)) {
9241                     STRLEN n;
9242                     char *s = SvPV(sv,n);
9243                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
9244                         && (n == 2 || !isDIGIT(s[n-3])))
9245                     {
9246                         Perl_warner(aTHX_ packWARN(WARN_Y2K),
9247                                     "Possible Y2K bug: %%%c %s",
9248                                     c, "format string following '19'");
9249                     }
9250                 }
9251 #endif
9252                 do {
9253                     dig = uv % base;
9254                     *--eptr = '0' + dig;
9255                 } while (uv /= base);
9256                 break;
9257             }
9258             elen = (ebuf + sizeof ebuf) - eptr;
9259             if (has_precis) {
9260                 if (precis > elen)
9261                     zeros = precis - elen;
9262                 else if (precis == 0 && elen == 1 && *eptr == '0')
9263                     elen = 0;
9264             }
9265             break;
9266
9267             /* FLOATING POINT */
9268
9269         case 'F':
9270             c = 'f';            /* maybe %F isn't supported here */
9271             /* FALL THROUGH */
9272         case 'e': case 'E':
9273         case 'f':
9274         case 'g': case 'G':
9275
9276             /* This is evil, but floating point is even more evil */
9277
9278             /* for SV-style calling, we can only get NV
9279                for C-style calling, we assume %f is double;
9280                for simplicity we allow any of %Lf, %llf, %qf for long double
9281             */
9282             switch (intsize) {
9283             case 'V':
9284 #if defined(USE_LONG_DOUBLE)
9285                 intsize = 'q';
9286 #endif
9287                 break;
9288 /* [perl #20339] - we should accept and ignore %lf rather than die */
9289             case 'l':
9290                 /* FALL THROUGH */
9291             default:
9292 #if defined(USE_LONG_DOUBLE)
9293                 intsize = args ? 0 : 'q';
9294 #endif
9295                 break;
9296             case 'q':
9297 #if defined(HAS_LONG_DOUBLE)
9298                 break;
9299 #else
9300                 /* FALL THROUGH */
9301 #endif
9302             case 'h':
9303                 goto unknown;
9304             }
9305
9306             /* now we need (long double) if intsize == 'q', else (double) */
9307             nv = (args && !vectorize) ?
9308 #if LONG_DOUBLESIZE > DOUBLESIZE
9309                 intsize == 'q' ?
9310                     va_arg(*args, long double) :
9311                     va_arg(*args, double)
9312 #else
9313                     va_arg(*args, double)
9314 #endif
9315                 : SvNVx(argsv);
9316
9317             need = 0;
9318             vectorize = FALSE;
9319             if (c != 'e' && c != 'E') {
9320                 i = PERL_INT_MIN;
9321                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9322                    will cast our (long double) to (double) */
9323                 (void)Perl_frexp(nv, &i);
9324                 if (i == PERL_INT_MIN)
9325                     Perl_die(aTHX_ "panic: frexp");
9326                 if (i > 0)
9327                     need = BIT_DIGITS(i);
9328             }
9329             need += has_precis ? precis : 6; /* known default */
9330
9331             if (need < width)
9332                 need = width;
9333
9334 #ifdef HAS_LDBL_SPRINTF_BUG
9335             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9336                with sfio - Allen <allens@cpan.org> */
9337
9338 #  ifdef DBL_MAX
9339 #    define MY_DBL_MAX DBL_MAX
9340 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9341 #    if DOUBLESIZE >= 8
9342 #      define MY_DBL_MAX 1.7976931348623157E+308L
9343 #    else
9344 #      define MY_DBL_MAX 3.40282347E+38L
9345 #    endif
9346 #  endif
9347
9348 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9349 #    define MY_DBL_MAX_BUG 1L
9350 #  else
9351 #    define MY_DBL_MAX_BUG MY_DBL_MAX
9352 #  endif
9353
9354 #  ifdef DBL_MIN
9355 #    define MY_DBL_MIN DBL_MIN
9356 #  else  /* XXX guessing! -Allen */
9357 #    if DOUBLESIZE >= 8
9358 #      define MY_DBL_MIN 2.2250738585072014E-308L
9359 #    else
9360 #      define MY_DBL_MIN 1.17549435E-38L
9361 #    endif
9362 #  endif
9363
9364             if ((intsize == 'q') && (c == 'f') &&
9365                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9366                 (need < DBL_DIG)) {
9367                 /* it's going to be short enough that
9368                  * long double precision is not needed */
9369
9370                 if ((nv <= 0L) && (nv >= -0L))
9371                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9372                 else {
9373                     /* would use Perl_fp_class as a double-check but not
9374                      * functional on IRIX - see perl.h comments */
9375
9376                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9377                         /* It's within the range that a double can represent */
9378 #if defined(DBL_MAX) && !defined(DBL_MIN)
9379                         if ((nv >= ((long double)1/DBL_MAX)) ||
9380                             (nv <= (-(long double)1/DBL_MAX)))
9381 #endif
9382                         fix_ldbl_sprintf_bug = TRUE;
9383                     }
9384                 }
9385                 if (fix_ldbl_sprintf_bug == TRUE) {
9386                     double temp;
9387
9388                     intsize = 0;
9389                     temp = (double)nv;
9390                     nv = (NV)temp;
9391                 }
9392             }
9393
9394 #  undef MY_DBL_MAX
9395 #  undef MY_DBL_MAX_BUG
9396 #  undef MY_DBL_MIN
9397
9398 #endif /* HAS_LDBL_SPRINTF_BUG */
9399
9400             need += 20; /* fudge factor */
9401             if (PL_efloatsize < need) {
9402                 Safefree(PL_efloatbuf);
9403                 PL_efloatsize = need + 20; /* more fudge */
9404                 New(906, PL_efloatbuf, PL_efloatsize, char);
9405                 PL_efloatbuf[0] = '\0';
9406             }
9407
9408             if ( !(width || left || plus || alt) && fill != '0'
9409                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
9410                 /* See earlier comment about buggy Gconvert when digits,
9411                    aka precis is 0  */
9412                 if ( c == 'g' && precis) {
9413                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9414                     if (*PL_efloatbuf)  /* May return an empty string for digits==0 */
9415                         goto float_converted;
9416                 } else if ( c == 'f' && !precis) {
9417                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9418                         break;
9419                 }
9420             }
9421             eptr = ebuf + sizeof ebuf;
9422             *--eptr = '\0';
9423             *--eptr = c;
9424             /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9425 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9426             if (intsize == 'q') {
9427                 /* Copy the one or more characters in a long double
9428                  * format before the 'base' ([efgEFG]) character to
9429                  * the format string. */
9430                 static char const prifldbl[] = PERL_PRIfldbl;
9431                 char const *p = prifldbl + sizeof(prifldbl) - 3;
9432                 while (p >= prifldbl) { *--eptr = *p--; }
9433             }
9434 #endif
9435             if (has_precis) {
9436                 base = precis;
9437                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9438                 *--eptr = '.';
9439             }
9440             if (width) {
9441                 base = width;
9442                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9443             }
9444             if (fill == '0')
9445                 *--eptr = fill;
9446             if (left)
9447                 *--eptr = '-';
9448             if (plus)
9449                 *--eptr = plus;
9450             if (alt)
9451                 *--eptr = '#';
9452             *--eptr = '%';
9453
9454             /* No taint.  Otherwise we are in the strange situation
9455              * where printf() taints but print($float) doesn't.
9456              * --jhi */
9457 #if defined(HAS_LONG_DOUBLE)
9458             if (intsize == 'q')
9459                 (void)sprintf(PL_efloatbuf, eptr, nv);
9460             else
9461                 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
9462 #else
9463             (void)sprintf(PL_efloatbuf, eptr, nv);
9464 #endif
9465         float_converted:
9466             eptr = PL_efloatbuf;
9467             elen = strlen(PL_efloatbuf);
9468             break;
9469
9470             /* SPECIAL */
9471
9472         case 'n':
9473             i = SvCUR(sv) - origlen;
9474             if (args && !vectorize) {
9475                 switch (intsize) {
9476                 case 'h':       *(va_arg(*args, short*)) = i; break;
9477                 default:        *(va_arg(*args, int*)) = i; break;
9478                 case 'l':       *(va_arg(*args, long*)) = i; break;
9479                 case 'V':       *(va_arg(*args, IV*)) = i; break;
9480 #ifdef HAS_QUAD
9481                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
9482 #endif
9483                 }
9484             }
9485             else
9486                 sv_setuv_mg(argsv, (UV)i);
9487             vectorize = FALSE;
9488             continue;   /* not "break" */
9489
9490             /* UNKNOWN */
9491
9492         default:
9493       unknown:
9494             if (!args && ckWARN(WARN_PRINTF) &&
9495                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
9496                 SV *msg = sv_newmortal();
9497                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9498                           (PL_op->op_type == OP_PRTF) ? "" : "s");
9499                 if (c) {
9500                     if (isPRINT(c))
9501                         Perl_sv_catpvf(aTHX_ msg,
9502                                        "\"%%%c\"", c & 0xFF);
9503                     else
9504                         Perl_sv_catpvf(aTHX_ msg,
9505                                        "\"%%\\%03"UVof"\"",
9506                                        (UV)c & 0xFF);
9507                 } else
9508                     sv_catpv(msg, "end of string");
9509                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9510             }
9511
9512             /* output mangled stuff ... */
9513             if (c == '\0')
9514                 --q;
9515             eptr = p;
9516             elen = q - p;
9517
9518             /* ... right here, because formatting flags should not apply */
9519             SvGROW(sv, SvCUR(sv) + elen + 1);
9520             p = SvEND(sv);
9521             Copy(eptr, p, elen, char);
9522             p += elen;
9523             *p = '\0';
9524             SvCUR(sv) = p - SvPVX(sv);
9525             svix = osvix;
9526             continue;   /* not "break" */
9527         }
9528
9529         /* calculate width before utf8_upgrade changes it */
9530         have = esignlen + zeros + elen;
9531
9532         if (is_utf8 != has_utf8) {
9533              if (is_utf8) {
9534                   if (SvCUR(sv))
9535                        sv_utf8_upgrade(sv);
9536              }
9537              else {
9538                   SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
9539                   sv_utf8_upgrade(nsv);
9540                   eptr = SvPVX(nsv);
9541                   elen = SvCUR(nsv);
9542              }
9543              SvGROW(sv, SvCUR(sv) + elen + 1);
9544              p = SvEND(sv);
9545              *p = '\0';
9546         }
9547         /* Use memchr() instead of strchr(), as eptr is not guaranteed */
9548         /* to point to a null-terminated string.                       */
9549         if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
9550             (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
9551             Perl_warner(aTHX_ packWARN(WARN_PRINTF),
9552                 "Newline in left-justified string for %sprintf",
9553                         (PL_op->op_type == OP_PRTF) ? "" : "s");
9554
9555         need = (have > width ? have : width);
9556         gap = need - have;
9557
9558         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9559         p = SvEND(sv);
9560         if (esignlen && fill == '0') {
9561             for (i = 0; i < (int)esignlen; i++)
9562                 *p++ = esignbuf[i];
9563         }
9564         if (gap && !left) {
9565             memset(p, fill, gap);
9566             p += gap;
9567         }
9568         if (esignlen && fill != '0') {
9569             for (i = 0; i < (int)esignlen; i++)
9570                 *p++ = esignbuf[i];
9571         }
9572         if (zeros) {
9573             for (i = zeros; i; i--)
9574                 *p++ = '0';
9575         }
9576         if (elen) {
9577             Copy(eptr, p, elen, char);
9578             p += elen;
9579         }
9580         if (gap && left) {
9581             memset(p, ' ', gap);
9582             p += gap;
9583         }
9584         if (vectorize) {
9585             if (veclen) {
9586                 Copy(dotstr, p, dotstrlen, char);
9587                 p += dotstrlen;
9588             }
9589             else
9590                 vectorize = FALSE;              /* done iterating over vecstr */
9591         }
9592         if (is_utf8)
9593             has_utf8 = TRUE;
9594         if (has_utf8)
9595             SvUTF8_on(sv);
9596         *p = '\0';
9597         SvCUR(sv) = p - SvPVX(sv);
9598         if (vectorize) {
9599             esignlen = 0;
9600             goto vector;
9601         }
9602     }
9603 }
9604
9605 /* =========================================================================
9606
9607 =head1 Cloning an interpreter
9608
9609 All the macros and functions in this section are for the private use of
9610 the main function, perl_clone().
9611
9612 The foo_dup() functions make an exact copy of an existing foo thinngy.
9613 During the course of a cloning, a hash table is used to map old addresses
9614 to new addresses. The table is created and manipulated with the
9615 ptr_table_* functions.
9616
9617 =cut
9618
9619 ============================================================================*/
9620
9621
9622 #if defined(USE_ITHREADS)
9623
9624 #ifndef GpREFCNT_inc
9625 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9626 #endif
9627
9628
9629 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9630 #define av_dup(s,t)     (AV*)sv_dup((SV*)s,t)
9631 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9632 #define hv_dup(s,t)     (HV*)sv_dup((SV*)s,t)
9633 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9634 #define cv_dup(s,t)     (CV*)sv_dup((SV*)s,t)
9635 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9636 #define io_dup(s,t)     (IO*)sv_dup((SV*)s,t)
9637 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9638 #define gv_dup(s,t)     (GV*)sv_dup((SV*)s,t)
9639 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9640 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
9641 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
9642
9643
9644 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9645    regcomp.c. AMS 20010712 */
9646
9647 REGEXP *
9648 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
9649 {
9650     REGEXP *ret;
9651     int i, len, npar;
9652     struct reg_substr_datum *s;
9653
9654     if (!r)
9655         return (REGEXP *)NULL;
9656
9657     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9658         return ret;
9659
9660     len = r->offsets[0];
9661     npar = r->nparens+1;
9662
9663     Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9664     Copy(r->program, ret->program, len+1, regnode);
9665
9666     New(0, ret->startp, npar, I32);
9667     Copy(r->startp, ret->startp, npar, I32);
9668     New(0, ret->endp, npar, I32);
9669     Copy(r->startp, ret->startp, npar, I32);
9670
9671     New(0, ret->substrs, 1, struct reg_substr_data);
9672     for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9673         s->min_offset = r->substrs->data[i].min_offset;
9674         s->max_offset = r->substrs->data[i].max_offset;
9675         s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
9676         s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9677     }
9678
9679     ret->regstclass = NULL;
9680     if (r->data) {
9681         struct reg_data *d;
9682         int count = r->data->count;
9683
9684         Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
9685                 char, struct reg_data);
9686         New(0, d->what, count, U8);
9687
9688         d->count = count;
9689         for (i = 0; i < count; i++) {
9690             d->what[i] = r->data->what[i];
9691             switch (d->what[i]) {
9692             case 's':
9693                 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9694                 break;
9695             case 'p':
9696                 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9697                 break;
9698             case 'f':
9699                 /* This is cheating. */
9700                 New(0, d->data[i], 1, struct regnode_charclass_class);
9701                 StructCopy(r->data->data[i], d->data[i],
9702                             struct regnode_charclass_class);
9703                 ret->regstclass = (regnode*)d->data[i];
9704                 break;
9705             case 'o':
9706                 /* Compiled op trees are readonly, and can thus be
9707                    shared without duplication. */
9708                 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9709                 break;
9710             case 'n':
9711                 d->data[i] = r->data->data[i];
9712                 break;
9713             }
9714         }
9715
9716         ret->data = d;
9717     }
9718     else
9719         ret->data = NULL;
9720
9721     New(0, ret->offsets, 2*len+1, U32);
9722     Copy(r->offsets, ret->offsets, 2*len+1, U32);
9723
9724     ret->precomp        = SAVEPVN(r->precomp, r->prelen);
9725     ret->refcnt         = r->refcnt;
9726     ret->minlen         = r->minlen;
9727     ret->prelen         = r->prelen;
9728     ret->nparens        = r->nparens;
9729     ret->lastparen      = r->lastparen;
9730     ret->lastcloseparen = r->lastcloseparen;
9731     ret->reganch        = r->reganch;
9732
9733     ret->sublen         = r->sublen;
9734
9735     if (RX_MATCH_COPIED(ret))
9736         ret->subbeg  = SAVEPVN(r->subbeg, r->sublen);
9737     else
9738         ret->subbeg = Nullch;
9739 #ifdef PERL_COPY_ON_WRITE
9740     ret->saved_copy = Nullsv;
9741 #endif
9742
9743     ptr_table_store(PL_ptr_table, r, ret);
9744     return ret;
9745 }
9746
9747 /* duplicate a file handle */
9748
9749 PerlIO *
9750 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9751 {
9752     PerlIO *ret;
9753     if (!fp)
9754         return (PerlIO*)NULL;
9755
9756     /* look for it in the table first */
9757     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9758     if (ret)
9759         return ret;
9760
9761     /* create anew and remember what it is */
9762     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9763     ptr_table_store(PL_ptr_table, fp, ret);
9764     return ret;
9765 }
9766
9767 /* duplicate a directory handle */
9768
9769 DIR *
9770 Perl_dirp_dup(pTHX_ DIR *dp)
9771 {
9772     if (!dp)
9773         return (DIR*)NULL;
9774     /* XXX TODO */
9775     return dp;
9776 }
9777
9778 /* duplicate a typeglob */
9779
9780 GP *
9781 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9782 {
9783     GP *ret;
9784     if (!gp)
9785         return (GP*)NULL;
9786     /* look for it in the table first */
9787     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9788     if (ret)
9789         return ret;
9790
9791     /* create anew and remember what it is */
9792     Newz(0, ret, 1, GP);
9793     ptr_table_store(PL_ptr_table, gp, ret);
9794
9795     /* clone */
9796     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
9797     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
9798     ret->gp_io          = io_dup_inc(gp->gp_io, param);
9799     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
9800     ret->gp_av          = av_dup_inc(gp->gp_av, param);
9801     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
9802     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9803     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
9804     ret->gp_cvgen       = gp->gp_cvgen;
9805     ret->gp_flags       = gp->gp_flags;
9806     ret->gp_line        = gp->gp_line;
9807     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
9808     return ret;
9809 }
9810
9811 /* duplicate a chain of magic */
9812
9813 MAGIC *
9814 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9815 {
9816     MAGIC *mgprev = (MAGIC*)NULL;
9817     MAGIC *mgret;
9818     if (!mg)
9819         return (MAGIC*)NULL;
9820     /* look for it in the table first */
9821     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9822     if (mgret)
9823         return mgret;
9824
9825     for (; mg; mg = mg->mg_moremagic) {
9826         MAGIC *nmg;
9827         Newz(0, nmg, 1, MAGIC);
9828         if (mgprev)
9829             mgprev->mg_moremagic = nmg;
9830         else
9831             mgret = nmg;
9832         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
9833         nmg->mg_private = mg->mg_private;
9834         nmg->mg_type    = mg->mg_type;
9835         nmg->mg_flags   = mg->mg_flags;
9836         if (mg->mg_type == PERL_MAGIC_qr) {
9837             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9838         }
9839         else if(mg->mg_type == PERL_MAGIC_backref) {
9840             AV *av = (AV*) mg->mg_obj;
9841             SV **svp;
9842             I32 i;
9843             SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
9844             svp = AvARRAY(av);
9845             for (i = AvFILLp(av); i >= 0; i--) {
9846                 if (!svp[i]) continue;
9847                 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9848             }
9849         }
9850         else {
9851             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9852                               ? sv_dup_inc(mg->mg_obj, param)
9853                               : sv_dup(mg->mg_obj, param);
9854         }
9855         nmg->mg_len     = mg->mg_len;
9856         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
9857         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9858             if (mg->mg_len > 0) {
9859                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
9860                 if (mg->mg_type == PERL_MAGIC_overload_table &&
9861                         AMT_AMAGIC((AMT*)mg->mg_ptr))
9862                 {
9863                     AMT *amtp = (AMT*)mg->mg_ptr;
9864                     AMT *namtp = (AMT*)nmg->mg_ptr;
9865                     I32 i;
9866                     for (i = 1; i < NofAMmeth; i++) {
9867                         namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9868                     }
9869                 }
9870             }
9871             else if (mg->mg_len == HEf_SVKEY)
9872                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9873         }
9874         if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9875             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9876         }
9877         mgprev = nmg;
9878     }
9879     return mgret;
9880 }
9881
9882 /* create a new pointer-mapping table */
9883
9884 PTR_TBL_t *
9885 Perl_ptr_table_new(pTHX)
9886 {
9887     PTR_TBL_t *tbl;
9888     Newz(0, tbl, 1, PTR_TBL_t);
9889     tbl->tbl_max        = 511;
9890     tbl->tbl_items      = 0;
9891     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9892     return tbl;
9893 }
9894
9895 /* map an existing pointer using a table */
9896
9897 void *
9898 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
9899 {
9900     PTR_TBL_ENT_t *tblent;
9901     UV hash = PTR2UV(sv);
9902     assert(tbl);
9903     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9904     for (; tblent; tblent = tblent->next) {
9905         if (tblent->oldval == sv)
9906             return tblent->newval;
9907     }
9908     return (void*)NULL;
9909 }
9910
9911 /* add a new entry to a pointer-mapping table */
9912
9913 void
9914 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
9915 {
9916     PTR_TBL_ENT_t *tblent, **otblent;
9917     /* XXX this may be pessimal on platforms where pointers aren't good
9918      * hash values e.g. if they grow faster in the most significant
9919      * bits */
9920     UV hash = PTR2UV(oldv);
9921     bool i = 1;
9922
9923     assert(tbl);
9924     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9925     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
9926         if (tblent->oldval == oldv) {
9927             tblent->newval = newv;
9928             return;
9929         }
9930     }
9931     Newz(0, tblent, 1, PTR_TBL_ENT_t);
9932     tblent->oldval = oldv;
9933     tblent->newval = newv;
9934     tblent->next = *otblent;
9935     *otblent = tblent;
9936     tbl->tbl_items++;
9937     if (i && tbl->tbl_items > tbl->tbl_max)
9938         ptr_table_split(tbl);
9939 }
9940
9941 /* double the hash bucket size of an existing ptr table */
9942
9943 void
9944 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9945 {
9946     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9947     UV oldsize = tbl->tbl_max + 1;
9948     UV newsize = oldsize * 2;
9949     UV i;
9950
9951     Renew(ary, newsize, PTR_TBL_ENT_t*);
9952     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9953     tbl->tbl_max = --newsize;
9954     tbl->tbl_ary = ary;
9955     for (i=0; i < oldsize; i++, ary++) {
9956         PTR_TBL_ENT_t **curentp, **entp, *ent;
9957         if (!*ary)
9958             continue;
9959         curentp = ary + oldsize;
9960         for (entp = ary, ent = *ary; ent; ent = *entp) {
9961             if ((newsize & PTR2UV(ent->oldval)) != i) {
9962                 *entp = ent->next;
9963                 ent->next = *curentp;
9964                 *curentp = ent;
9965                 continue;
9966             }
9967             else
9968                 entp = &ent->next;
9969         }
9970     }
9971 }
9972
9973 /* remove all the entries from a ptr table */
9974
9975 void
9976 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9977 {
9978     register PTR_TBL_ENT_t **array;
9979     register PTR_TBL_ENT_t *entry;
9980     register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
9981     UV riter = 0;
9982     UV max;
9983
9984     if (!tbl || !tbl->tbl_items) {
9985         return;
9986     }
9987
9988     array = tbl->tbl_ary;
9989     entry = array[0];
9990     max = tbl->tbl_max;
9991
9992     for (;;) {
9993         if (entry) {
9994             oentry = entry;
9995             entry = entry->next;
9996             Safefree(oentry);
9997         }
9998         if (!entry) {
9999             if (++riter > max) {
10000                 break;
10001             }
10002             entry = array[riter];
10003         }
10004     }
10005
10006     tbl->tbl_items = 0;
10007 }
10008
10009 /* clear and free a ptr table */
10010
10011 void
10012 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10013 {
10014     if (!tbl) {
10015         return;
10016     }
10017     ptr_table_clear(tbl);
10018     Safefree(tbl->tbl_ary);
10019     Safefree(tbl);
10020 }
10021
10022 #ifdef DEBUGGING
10023 char *PL_watch_pvx;
10024 #endif
10025
10026 /* attempt to make everything in the typeglob readonly */
10027
10028 STATIC SV *
10029 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10030 {
10031     GV *gv = (GV*)sstr;
10032     SV *sv = &param->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10033
10034     if (GvIO(gv) || GvFORM(gv)) {
10035         GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10036     }
10037     else if (!GvCV(gv)) {
10038         GvCV(gv) = (CV*)sv;
10039     }
10040     else {
10041         /* CvPADLISTs cannot be shared */
10042         if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10043             GvUNIQUE_off(gv);
10044         }
10045     }
10046
10047     if (!GvUNIQUE(gv)) {
10048 #if 0
10049         PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10050                       HvNAME(GvSTASH(gv)), GvNAME(gv));
10051 #endif
10052         return Nullsv;
10053     }
10054
10055     /*
10056      * write attempts will die with
10057      * "Modification of a read-only value attempted"
10058      */
10059     if (!GvSV(gv)) {
10060         GvSV(gv) = sv;
10061     }
10062     else {
10063         SvREADONLY_on(GvSV(gv));
10064     }
10065
10066     if (!GvAV(gv)) {
10067         GvAV(gv) = (AV*)sv;
10068     }
10069     else {
10070         SvREADONLY_on(GvAV(gv));
10071     }
10072
10073     if (!GvHV(gv)) {
10074         GvHV(gv) = (HV*)sv;
10075     }
10076     else {
10077         SvREADONLY_on(GvHV(gv));
10078     }
10079
10080     return sstr; /* he_dup() will SvREFCNT_inc() */
10081 }
10082
10083 /* duplicate an SV of any type (including AV, HV etc) */
10084
10085 void
10086 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10087 {
10088     if (SvROK(sstr)) {
10089         SvRV(dstr) = SvWEAKREF(sstr)
10090                      ? sv_dup(SvRV(sstr), param)
10091                      : sv_dup_inc(SvRV(sstr), param);
10092     }
10093     else if (SvPVX(sstr)) {
10094         /* Has something there */
10095         if (SvLEN(sstr)) {
10096             /* Normal PV - clone whole allocated space */
10097             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
10098             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10099                 /* Not that normal - actually sstr is copy on write.
10100                    But we are a true, independant SV, so:  */
10101                 SvREADONLY_off(dstr);
10102                 SvFAKE_off(dstr);
10103             }
10104         }
10105         else {
10106             /* Special case - not normally malloced for some reason */
10107             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10108                 /* A "shared" PV - clone it as unshared string */
10109                 if(SvPADTMP(sstr)) {
10110                     /* However, some of them live in the pad
10111                        and they should not have these flags
10112                        turned off */
10113
10114                     SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
10115                                            SvUVX(sstr));
10116                     SvUVX(dstr) = SvUVX(sstr);
10117                 } else {
10118
10119                     SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
10120                     SvFAKE_off(dstr);
10121                     SvREADONLY_off(dstr);
10122                 }
10123             }
10124             else {
10125                 /* Some other special case - random pointer */
10126                 SvPVX(dstr) = SvPVX(sstr);
10127             }
10128         }
10129     }
10130     else {
10131         /* Copy the Null */
10132         SvPVX(dstr) = SvPVX(sstr);
10133     }
10134 }
10135
10136 SV *
10137 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10138 {
10139     SV *dstr;
10140
10141     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10142         return Nullsv;
10143     /* look for it in the table first */
10144     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10145     if (dstr)
10146         return dstr;
10147
10148     if(param->flags & CLONEf_JOIN_IN) {
10149         /** We are joining here so we don't want do clone
10150             something that is bad **/
10151
10152         if(SvTYPE(sstr) == SVt_PVHV &&
10153            HvNAME(sstr)) {
10154             /** don't clone stashes if they already exist **/
10155             HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10156             return (SV*) old_stash;
10157         }
10158     }
10159
10160     /* create anew and remember what it is */
10161     new_SV(dstr);
10162     ptr_table_store(PL_ptr_table, sstr, dstr);
10163
10164     /* clone */
10165     SvFLAGS(dstr)       = SvFLAGS(sstr);
10166     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
10167     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
10168
10169 #ifdef DEBUGGING
10170     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10171         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10172                       PL_watch_pvx, SvPVX(sstr));
10173 #endif
10174
10175     switch (SvTYPE(sstr)) {
10176     case SVt_NULL:
10177         SvANY(dstr)     = NULL;
10178         break;
10179     case SVt_IV:
10180         SvANY(dstr)     = new_XIV();
10181         SvIVX(dstr)     = SvIVX(sstr);
10182         break;
10183     case SVt_NV:
10184         SvANY(dstr)     = new_XNV();
10185         SvNVX(dstr)     = SvNVX(sstr);
10186         break;
10187     case SVt_RV:
10188         SvANY(dstr)     = new_XRV();
10189         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10190         break;
10191     case SVt_PV:
10192         SvANY(dstr)     = new_XPV();
10193         SvCUR(dstr)     = SvCUR(sstr);
10194         SvLEN(dstr)     = SvLEN(sstr);
10195         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10196         break;
10197     case SVt_PVIV:
10198         SvANY(dstr)     = new_XPVIV();
10199         SvCUR(dstr)     = SvCUR(sstr);
10200         SvLEN(dstr)     = SvLEN(sstr);
10201         SvIVX(dstr)     = SvIVX(sstr);
10202         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10203         break;
10204     case SVt_PVNV:
10205         SvANY(dstr)     = new_XPVNV();
10206         SvCUR(dstr)     = SvCUR(sstr);
10207         SvLEN(dstr)     = SvLEN(sstr);
10208         SvIVX(dstr)     = SvIVX(sstr);
10209         SvNVX(dstr)     = SvNVX(sstr);
10210         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10211         break;
10212     case SVt_PVMG:
10213         SvANY(dstr)     = new_XPVMG();
10214         SvCUR(dstr)     = SvCUR(sstr);
10215         SvLEN(dstr)     = SvLEN(sstr);
10216         SvIVX(dstr)     = SvIVX(sstr);
10217         SvNVX(dstr)     = SvNVX(sstr);
10218         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10219         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10220         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10221         break;
10222     case SVt_PVBM:
10223         SvANY(dstr)     = new_XPVBM();
10224         SvCUR(dstr)     = SvCUR(sstr);
10225         SvLEN(dstr)     = SvLEN(sstr);
10226         SvIVX(dstr)     = SvIVX(sstr);
10227         SvNVX(dstr)     = SvNVX(sstr);
10228         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10229         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10230         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10231         BmRARE(dstr)    = BmRARE(sstr);
10232         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
10233         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10234         break;
10235     case SVt_PVLV:
10236         SvANY(dstr)     = new_XPVLV();
10237         SvCUR(dstr)     = SvCUR(sstr);
10238         SvLEN(dstr)     = SvLEN(sstr);
10239         SvIVX(dstr)     = SvIVX(sstr);
10240         SvNVX(dstr)     = SvNVX(sstr);
10241         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10242         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10243         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10244         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
10245         LvTARGLEN(dstr) = LvTARGLEN(sstr);
10246         if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10247             LvTARG(dstr) = dstr;
10248         else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10249             LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10250         else
10251             LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10252         LvTYPE(dstr)    = LvTYPE(sstr);
10253         break;
10254     case SVt_PVGV:
10255         if (GvUNIQUE((GV*)sstr)) {
10256             SV *share;
10257             if ((share = gv_share(sstr, param))) {
10258                 del_SV(dstr);
10259                 dstr = share;
10260                 ptr_table_store(PL_ptr_table, sstr, dstr);
10261 #if 0
10262                 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10263                               HvNAME(GvSTASH(share)), GvNAME(share));
10264 #endif
10265                 break;
10266             }
10267         }
10268         SvANY(dstr)     = new_XPVGV();
10269         SvCUR(dstr)     = SvCUR(sstr);
10270         SvLEN(dstr)     = SvLEN(sstr);
10271         SvIVX(dstr)     = SvIVX(sstr);
10272         SvNVX(dstr)     = SvNVX(sstr);
10273         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10274         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10275         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10276         GvNAMELEN(dstr) = GvNAMELEN(sstr);
10277         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10278         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr), param);
10279         GvFLAGS(dstr)   = GvFLAGS(sstr);
10280         GvGP(dstr)      = gp_dup(GvGP(sstr), param);
10281         (void)GpREFCNT_inc(GvGP(dstr));
10282         break;
10283     case SVt_PVIO:
10284         SvANY(dstr)     = new_XPVIO();
10285         SvCUR(dstr)     = SvCUR(sstr);
10286         SvLEN(dstr)     = SvLEN(sstr);
10287         SvIVX(dstr)     = SvIVX(sstr);
10288         SvNVX(dstr)     = SvNVX(sstr);
10289         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10290         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10291         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10292         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10293         if (IoOFP(sstr) == IoIFP(sstr))
10294             IoOFP(dstr) = IoIFP(dstr);
10295         else
10296             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10297         /* PL_rsfp_filters entries have fake IoDIRP() */
10298         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10299             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
10300         else
10301             IoDIRP(dstr)        = IoDIRP(sstr);
10302         IoLINES(dstr)           = IoLINES(sstr);
10303         IoPAGE(dstr)            = IoPAGE(sstr);
10304         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
10305         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
10306         if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10307             /* I have no idea why fake dirp (rsfps)
10308                should be treaded differently but otherwise
10309                we end up with leaks -- sky*/
10310             IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(sstr), param);
10311             IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(sstr), param);
10312             IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10313         } else {
10314             IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(sstr), param);
10315             IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(sstr), param);
10316             IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(sstr), param);
10317         }
10318         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
10319         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
10320         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
10321         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
10322         IoTYPE(dstr)            = IoTYPE(sstr);
10323         IoFLAGS(dstr)           = IoFLAGS(sstr);
10324         break;
10325     case SVt_PVAV:
10326         SvANY(dstr)     = new_XPVAV();
10327         SvCUR(dstr)     = SvCUR(sstr);
10328         SvLEN(dstr)     = SvLEN(sstr);
10329         SvIVX(dstr)     = SvIVX(sstr);
10330         SvNVX(dstr)     = SvNVX(sstr);
10331         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10332         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10333         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10334         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10335         if (AvARRAY((AV*)sstr)) {
10336             SV **dst_ary, **src_ary;
10337             SSize_t items = AvFILLp((AV*)sstr) + 1;
10338
10339             src_ary = AvARRAY((AV*)sstr);
10340             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10341             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10342             SvPVX(dstr) = (char*)dst_ary;
10343             AvALLOC((AV*)dstr) = dst_ary;
10344             if (AvREAL((AV*)sstr)) {
10345                 while (items-- > 0)
10346                     *dst_ary++ = sv_dup_inc(*src_ary++, param);
10347             }
10348             else {
10349                 while (items-- > 0)
10350                     *dst_ary++ = sv_dup(*src_ary++, param);
10351             }
10352             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10353             while (items-- > 0) {
10354                 *dst_ary++ = &PL_sv_undef;
10355             }
10356         }
10357         else {
10358             SvPVX(dstr)         = Nullch;
10359             AvALLOC((AV*)dstr)  = (SV**)NULL;
10360         }
10361         break;
10362     case SVt_PVHV:
10363         SvANY(dstr)     = new_XPVHV();
10364         SvCUR(dstr)     = SvCUR(sstr);
10365         SvLEN(dstr)     = SvLEN(sstr);
10366         SvIVX(dstr)     = SvIVX(sstr);
10367         SvNVX(dstr)     = SvNVX(sstr);
10368         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10369         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10370         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
10371         if (HvARRAY((HV*)sstr)) {
10372             STRLEN i = 0;
10373             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10374             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10375             Newz(0, dxhv->xhv_array,
10376                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10377             while (i <= sxhv->xhv_max) {
10378                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10379                                                     (bool)!!HvSHAREKEYS(sstr),
10380                                                     param);
10381                 ++i;
10382             }
10383             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10384                                      (bool)!!HvSHAREKEYS(sstr), param);
10385         }
10386         else {
10387             SvPVX(dstr)         = Nullch;
10388             HvEITER((HV*)dstr)  = (HE*)NULL;
10389         }
10390         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
10391         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
10392     /* Record stashes for possible cloning in Perl_clone(). */
10393         if(HvNAME((HV*)dstr))
10394             av_push(param->stashes, dstr);
10395         break;
10396     case SVt_PVFM:
10397         SvANY(dstr)     = new_XPVFM();
10398         FmLINES(dstr)   = FmLINES(sstr);
10399         goto dup_pvcv;
10400         /* NOTREACHED */
10401     case SVt_PVCV:
10402         SvANY(dstr)     = new_XPVCV();
10403         dup_pvcv:
10404         SvCUR(dstr)     = SvCUR(sstr);
10405         SvLEN(dstr)     = SvLEN(sstr);
10406         SvIVX(dstr)     = SvIVX(sstr);
10407         SvNVX(dstr)     = SvNVX(sstr);
10408         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
10409         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
10410         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10411         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
10412         CvSTART(dstr)   = CvSTART(sstr);
10413         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
10414         CvXSUB(dstr)    = CvXSUB(sstr);
10415         CvXSUBANY(dstr) = CvXSUBANY(sstr);
10416         if (CvCONST(sstr)) {
10417             CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
10418                 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
10419                 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
10420         }
10421         /* don't dup if copying back - CvGV isn't refcounted, so the
10422          * duped GV may never be freed. A bit of a hack! DAPM */
10423         CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
10424                 Nullgv : gv_dup(CvGV(sstr), param) ;
10425         if (param->flags & CLONEf_COPY_STACKS) {
10426           CvDEPTH(dstr) = CvDEPTH(sstr);
10427         } else {
10428           CvDEPTH(dstr) = 0;
10429         }
10430         PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10431         CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
10432         CvOUTSIDE(dstr) =
10433                 CvWEAKOUTSIDE(sstr)
10434                         ? cv_dup(    CvOUTSIDE(sstr), param)
10435                         : cv_dup_inc(CvOUTSIDE(sstr), param);
10436         CvFLAGS(dstr)   = CvFLAGS(sstr);
10437         CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
10438         break;
10439     default:
10440         Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10441         break;
10442     }
10443
10444     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10445         ++PL_sv_objcount;
10446
10447     return dstr;
10448  }
10449
10450 /* duplicate a context */
10451
10452 PERL_CONTEXT *
10453 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10454 {
10455     PERL_CONTEXT *ncxs;
10456
10457     if (!cxs)
10458         return (PERL_CONTEXT*)NULL;
10459
10460     /* look for it in the table first */
10461     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10462     if (ncxs)
10463         return ncxs;
10464
10465     /* create anew and remember what it is */
10466     Newz(56, ncxs, max + 1, PERL_CONTEXT);
10467     ptr_table_store(PL_ptr_table, cxs, ncxs);
10468
10469     while (ix >= 0) {
10470         PERL_CONTEXT *cx = &cxs[ix];
10471         PERL_CONTEXT *ncx = &ncxs[ix];
10472         ncx->cx_type    = cx->cx_type;
10473         if (CxTYPE(cx) == CXt_SUBST) {
10474             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10475         }
10476         else {
10477             ncx->blk_oldsp      = cx->blk_oldsp;
10478             ncx->blk_oldcop     = cx->blk_oldcop;
10479             ncx->blk_oldretsp   = cx->blk_oldretsp;
10480             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
10481             ncx->blk_oldscopesp = cx->blk_oldscopesp;
10482             ncx->blk_oldpm      = cx->blk_oldpm;
10483             ncx->blk_gimme      = cx->blk_gimme;
10484             switch (CxTYPE(cx)) {
10485             case CXt_SUB:
10486                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
10487                                            ? cv_dup_inc(cx->blk_sub.cv, param)
10488                                            : cv_dup(cx->blk_sub.cv,param));
10489                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
10490                                            ? av_dup_inc(cx->blk_sub.argarray, param)
10491                                            : Nullav);
10492                 ncx->blk_sub.savearray  = av_dup_inc(cx->blk_sub.savearray, param);
10493                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
10494                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
10495                 ncx->blk_sub.lval       = cx->blk_sub.lval;
10496                 break;
10497             case CXt_EVAL:
10498                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10499                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10500                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10501                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10502                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text, param);
10503                 break;
10504             case CXt_LOOP:
10505                 ncx->blk_loop.label     = cx->blk_loop.label;
10506                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
10507                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
10508                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
10509                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
10510                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
10511                                            ? cx->blk_loop.iterdata
10512                                            : gv_dup((GV*)cx->blk_loop.iterdata, param));
10513                 ncx->blk_loop.oldcomppad
10514                     = (PAD*)ptr_table_fetch(PL_ptr_table,
10515                                             cx->blk_loop.oldcomppad);
10516                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave, param);
10517                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval, param);
10518                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary, param);
10519                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
10520                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
10521                 break;
10522             case CXt_FORMAT:
10523                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv, param);
10524                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv, param);
10525                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10526                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
10527                 break;
10528             case CXt_BLOCK:
10529             case CXt_NULL:
10530                 break;
10531             }
10532         }
10533         --ix;
10534     }
10535     return ncxs;
10536 }
10537
10538 /* duplicate a stack info structure */
10539
10540 PERL_SI *
10541 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10542 {
10543     PERL_SI *nsi;
10544
10545     if (!si)
10546         return (PERL_SI*)NULL;
10547
10548     /* look for it in the table first */
10549     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10550     if (nsi)
10551         return nsi;
10552
10553     /* create anew and remember what it is */
10554     Newz(56, nsi, 1, PERL_SI);
10555     ptr_table_store(PL_ptr_table, si, nsi);
10556
10557     nsi->si_stack       = av_dup_inc(si->si_stack, param);
10558     nsi->si_cxix        = si->si_cxix;
10559     nsi->si_cxmax       = si->si_cxmax;
10560     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10561     nsi->si_type        = si->si_type;
10562     nsi->si_prev        = si_dup(si->si_prev, param);
10563     nsi->si_next        = si_dup(si->si_next, param);
10564     nsi->si_markoff     = si->si_markoff;
10565
10566     return nsi;
10567 }
10568
10569 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
10570 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
10571 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
10572 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
10573 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
10574 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
10575 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
10576 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
10577 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
10578 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
10579 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
10580 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
10581 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10582 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10583
10584 /* XXXXX todo */
10585 #define pv_dup_inc(p)   SAVEPV(p)
10586 #define pv_dup(p)       SAVEPV(p)
10587 #define svp_dup_inc(p,pp)       any_dup(p,pp)
10588
10589 /* map any object to the new equivent - either something in the
10590  * ptr table, or something in the interpreter structure
10591  */
10592
10593 void *
10594 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
10595 {
10596     void *ret;
10597
10598     if (!v)
10599         return (void*)NULL;
10600
10601     /* look for it in the table first */
10602     ret = ptr_table_fetch(PL_ptr_table, v);
10603     if (ret)
10604         return ret;
10605
10606     /* see if it is part of the interpreter structure */
10607     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10608         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10609     else {
10610         ret = v;
10611     }
10612
10613     return ret;
10614 }
10615
10616 /* duplicate the save stack */
10617
10618 ANY *
10619 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10620 {
10621     ANY *ss     = proto_perl->Tsavestack;
10622     I32 ix      = proto_perl->Tsavestack_ix;
10623     I32 max     = proto_perl->Tsavestack_max;
10624     ANY *nss;
10625     SV *sv;
10626     GV *gv;
10627     AV *av;
10628     HV *hv;
10629     void* ptr;
10630     int intval;
10631     long longval;
10632     GP *gp;
10633     IV iv;
10634     I32 i;
10635     char *c = NULL;
10636     void (*dptr) (void*);
10637     void (*dxptr) (pTHX_ void*);
10638     OP *o;
10639
10640     Newz(54, nss, max, ANY);
10641
10642     while (ix > 0) {
10643         i = POPINT(ss,ix);
10644         TOPINT(nss,ix) = i;
10645         switch (i) {
10646         case SAVEt_ITEM:                        /* normal string */
10647             sv = (SV*)POPPTR(ss,ix);
10648             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10649             sv = (SV*)POPPTR(ss,ix);
10650             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10651             break;
10652         case SAVEt_SV:                          /* scalar reference */
10653             sv = (SV*)POPPTR(ss,ix);
10654             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10655             gv = (GV*)POPPTR(ss,ix);
10656             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10657             break;
10658         case SAVEt_GENERIC_PVREF:               /* generic char* */
10659             c = (char*)POPPTR(ss,ix);
10660             TOPPTR(nss,ix) = pv_dup(c);
10661             ptr = POPPTR(ss,ix);
10662             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10663             break;
10664         case SAVEt_SHARED_PVREF:                /* char* in shared space */
10665             c = (char*)POPPTR(ss,ix);
10666             TOPPTR(nss,ix) = savesharedpv(c);
10667             ptr = POPPTR(ss,ix);
10668             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10669             break;
10670         case SAVEt_GENERIC_SVREF:               /* generic sv */
10671         case SAVEt_SVREF:                       /* scalar reference */
10672             sv = (SV*)POPPTR(ss,ix);
10673             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10674             ptr = POPPTR(ss,ix);
10675             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10676             break;
10677         case SAVEt_AV:                          /* array reference */
10678             av = (AV*)POPPTR(ss,ix);
10679             TOPPTR(nss,ix) = av_dup_inc(av, param);
10680             gv = (GV*)POPPTR(ss,ix);
10681             TOPPTR(nss,ix) = gv_dup(gv, param);
10682             break;
10683         case SAVEt_HV:                          /* hash reference */
10684             hv = (HV*)POPPTR(ss,ix);
10685             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10686             gv = (GV*)POPPTR(ss,ix);
10687             TOPPTR(nss,ix) = gv_dup(gv, param);
10688             break;
10689         case SAVEt_INT:                         /* int reference */
10690             ptr = POPPTR(ss,ix);
10691             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10692             intval = (int)POPINT(ss,ix);
10693             TOPINT(nss,ix) = intval;
10694             break;
10695         case SAVEt_LONG:                        /* long reference */
10696             ptr = POPPTR(ss,ix);
10697             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10698             longval = (long)POPLONG(ss,ix);
10699             TOPLONG(nss,ix) = longval;
10700             break;
10701         case SAVEt_I32:                         /* I32 reference */
10702         case SAVEt_I16:                         /* I16 reference */
10703         case SAVEt_I8:                          /* I8 reference */
10704             ptr = POPPTR(ss,ix);
10705             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10706             i = POPINT(ss,ix);
10707             TOPINT(nss,ix) = i;
10708             break;
10709         case SAVEt_IV:                          /* IV reference */
10710             ptr = POPPTR(ss,ix);
10711             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10712             iv = POPIV(ss,ix);
10713             TOPIV(nss,ix) = iv;
10714             break;
10715         case SAVEt_SPTR:                        /* SV* reference */
10716             ptr = POPPTR(ss,ix);
10717             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10718             sv = (SV*)POPPTR(ss,ix);
10719             TOPPTR(nss,ix) = sv_dup(sv, param);
10720             break;
10721         case SAVEt_VPTR:                        /* random* reference */
10722             ptr = POPPTR(ss,ix);
10723             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10724             ptr = POPPTR(ss,ix);
10725             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10726             break;
10727         case SAVEt_PPTR:                        /* char* reference */
10728             ptr = POPPTR(ss,ix);
10729             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10730             c = (char*)POPPTR(ss,ix);
10731             TOPPTR(nss,ix) = pv_dup(c);
10732             break;
10733         case SAVEt_HPTR:                        /* HV* reference */
10734             ptr = POPPTR(ss,ix);
10735             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10736             hv = (HV*)POPPTR(ss,ix);
10737             TOPPTR(nss,ix) = hv_dup(hv, param);
10738             break;
10739         case SAVEt_APTR:                        /* AV* reference */
10740             ptr = POPPTR(ss,ix);
10741             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10742             av = (AV*)POPPTR(ss,ix);
10743             TOPPTR(nss,ix) = av_dup(av, param);
10744             break;
10745         case SAVEt_NSTAB:
10746             gv = (GV*)POPPTR(ss,ix);
10747             TOPPTR(nss,ix) = gv_dup(gv, param);
10748             break;
10749         case SAVEt_GP:                          /* scalar reference */
10750             gp = (GP*)POPPTR(ss,ix);
10751             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10752             (void)GpREFCNT_inc(gp);
10753             gv = (GV*)POPPTR(ss,ix);
10754             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10755             c = (char*)POPPTR(ss,ix);
10756             TOPPTR(nss,ix) = pv_dup(c);
10757             iv = POPIV(ss,ix);
10758             TOPIV(nss,ix) = iv;
10759             iv = POPIV(ss,ix);
10760             TOPIV(nss,ix) = iv;
10761             break;
10762         case SAVEt_FREESV:
10763         case SAVEt_MORTALIZESV:
10764             sv = (SV*)POPPTR(ss,ix);
10765             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10766             break;
10767         case SAVEt_FREEOP:
10768             ptr = POPPTR(ss,ix);
10769             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10770                 /* these are assumed to be refcounted properly */
10771                 switch (((OP*)ptr)->op_type) {
10772                 case OP_LEAVESUB:
10773                 case OP_LEAVESUBLV:
10774                 case OP_LEAVEEVAL:
10775                 case OP_LEAVE:
10776                 case OP_SCOPE:
10777                 case OP_LEAVEWRITE:
10778                     TOPPTR(nss,ix) = ptr;
10779                     o = (OP*)ptr;
10780                     OpREFCNT_inc(o);
10781                     break;
10782                 default:
10783                     TOPPTR(nss,ix) = Nullop;
10784                     break;
10785                 }
10786             }
10787             else
10788                 TOPPTR(nss,ix) = Nullop;
10789             break;
10790         case SAVEt_FREEPV:
10791             c = (char*)POPPTR(ss,ix);
10792             TOPPTR(nss,ix) = pv_dup_inc(c);
10793             break;
10794         case SAVEt_CLEARSV:
10795             longval = POPLONG(ss,ix);
10796             TOPLONG(nss,ix) = longval;
10797             break;
10798         case SAVEt_DELETE:
10799             hv = (HV*)POPPTR(ss,ix);
10800             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10801             c = (char*)POPPTR(ss,ix);
10802             TOPPTR(nss,ix) = pv_dup_inc(c);
10803             i = POPINT(ss,ix);
10804             TOPINT(nss,ix) = i;
10805             break;
10806         case SAVEt_DESTRUCTOR:
10807             ptr = POPPTR(ss,ix);
10808             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
10809             dptr = POPDPTR(ss,ix);
10810             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
10811             break;
10812         case SAVEt_DESTRUCTOR_X:
10813             ptr = POPPTR(ss,ix);
10814             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
10815             dxptr = POPDXPTR(ss,ix);
10816             TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
10817             break;
10818         case SAVEt_REGCONTEXT:
10819         case SAVEt_ALLOC:
10820             i = POPINT(ss,ix);
10821             TOPINT(nss,ix) = i;
10822             ix -= i;
10823             break;
10824         case SAVEt_STACK_POS:           /* Position on Perl stack */
10825             i = POPINT(ss,ix);
10826             TOPINT(nss,ix) = i;
10827             break;
10828         case SAVEt_AELEM:               /* array element */
10829             sv = (SV*)POPPTR(ss,ix);
10830             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10831             i = POPINT(ss,ix);
10832             TOPINT(nss,ix) = i;
10833             av = (AV*)POPPTR(ss,ix);
10834             TOPPTR(nss,ix) = av_dup_inc(av, param);
10835             break;
10836         case SAVEt_HELEM:               /* hash element */
10837             sv = (SV*)POPPTR(ss,ix);
10838             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10839             sv = (SV*)POPPTR(ss,ix);
10840             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10841             hv = (HV*)POPPTR(ss,ix);
10842             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10843             break;
10844         case SAVEt_OP:
10845             ptr = POPPTR(ss,ix);
10846             TOPPTR(nss,ix) = ptr;
10847             break;
10848         case SAVEt_HINTS:
10849             i = POPINT(ss,ix);
10850             TOPINT(nss,ix) = i;
10851             break;
10852         case SAVEt_COMPPAD:
10853             av = (AV*)POPPTR(ss,ix);
10854             TOPPTR(nss,ix) = av_dup(av, param);
10855             break;
10856         case SAVEt_PADSV:
10857             longval = (long)POPLONG(ss,ix);
10858             TOPLONG(nss,ix) = longval;
10859             ptr = POPPTR(ss,ix);
10860             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10861             sv = (SV*)POPPTR(ss,ix);
10862             TOPPTR(nss,ix) = sv_dup(sv, param);
10863             break;
10864         case SAVEt_BOOL:
10865             ptr = POPPTR(ss,ix);
10866             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10867             longval = (long)POPBOOL(ss,ix);
10868             TOPBOOL(nss,ix) = (bool)longval;
10869             break;
10870         case SAVEt_SET_SVFLAGS:
10871             i = POPINT(ss,ix);
10872             TOPINT(nss,ix) = i;
10873             i = POPINT(ss,ix);
10874             TOPINT(nss,ix) = i;
10875             sv = (SV*)POPPTR(ss,ix);
10876             TOPPTR(nss,ix) = sv_dup(sv, param);
10877             break;
10878         default:
10879             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10880         }
10881     }
10882
10883     return nss;
10884 }
10885
10886 /*
10887 =for apidoc perl_clone
10888
10889 Create and return a new interpreter by cloning the current one.
10890
10891 perl_clone takes these flags as parameters:
10892
10893 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10894 without it we only clone the data and zero the stacks,
10895 with it we copy the stacks and the new perl interpreter is
10896 ready to run at the exact same point as the previous one.
10897 The pseudo-fork code uses COPY_STACKS while the
10898 threads->new doesn't.
10899
10900 CLONEf_KEEP_PTR_TABLE
10901 perl_clone keeps a ptr_table with the pointer of the old
10902 variable as a key and the new variable as a value,
10903 this allows it to check if something has been cloned and not
10904 clone it again but rather just use the value and increase the
10905 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10906 the ptr_table using the function
10907 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10908 reason to keep it around is if you want to dup some of your own
10909 variable who are outside the graph perl scans, example of this
10910 code is in threads.xs create
10911
10912 CLONEf_CLONE_HOST
10913 This is a win32 thing, it is ignored on unix, it tells perls
10914 win32host code (which is c++) to clone itself, this is needed on
10915 win32 if you want to run two threads at the same time,
10916 if you just want to do some stuff in a separate perl interpreter
10917 and then throw it away and return to the original one,
10918 you don't need to do anything.
10919
10920 =cut
10921 */
10922
10923 /* XXX the above needs expanding by someone who actually understands it ! */
10924 EXTERN_C PerlInterpreter *
10925 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10926
10927 PerlInterpreter *
10928 perl_clone(PerlInterpreter *proto_perl, UV flags)
10929 {
10930 #ifdef PERL_IMPLICIT_SYS
10931
10932    /* perlhost.h so we need to call into it
10933    to clone the host, CPerlHost should have a c interface, sky */
10934
10935    if (flags & CLONEf_CLONE_HOST) {
10936        return perl_clone_host(proto_perl,flags);
10937    }
10938    return perl_clone_using(proto_perl, flags,
10939                             proto_perl->IMem,
10940                             proto_perl->IMemShared,
10941                             proto_perl->IMemParse,
10942                             proto_perl->IEnv,
10943                             proto_perl->IStdIO,
10944                             proto_perl->ILIO,
10945                             proto_perl->IDir,
10946                             proto_perl->ISock,
10947                             proto_perl->IProc);
10948 }
10949
10950 PerlInterpreter *
10951 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10952                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
10953                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10954                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10955                  struct IPerlDir* ipD, struct IPerlSock* ipS,
10956                  struct IPerlProc* ipP)
10957 {
10958     /* XXX many of the string copies here can be optimized if they're
10959      * constants; they need to be allocated as common memory and just
10960      * their pointers copied. */
10961
10962     IV i;
10963     CLONE_PARAMS clone_params;
10964     CLONE_PARAMS* param = &clone_params;
10965
10966     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10967     PERL_SET_THX(my_perl);
10968
10969 #  ifdef DEBUGGING
10970     Poison(my_perl, 1, PerlInterpreter);
10971     PL_markstack = 0;
10972     PL_scopestack = 0;
10973     PL_savestack = 0;
10974     PL_savestack_ix = 0;
10975     PL_savestack_max = -1;
10976     PL_retstack = 0;
10977     PL_sig_pending = 0;
10978     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10979 #  else /* !DEBUGGING */
10980     Zero(my_perl, 1, PerlInterpreter);
10981 #  endif        /* DEBUGGING */
10982
10983     /* host pointers */
10984     PL_Mem              = ipM;
10985     PL_MemShared        = ipMS;
10986     PL_MemParse         = ipMP;
10987     PL_Env              = ipE;
10988     PL_StdIO            = ipStd;
10989     PL_LIO              = ipLIO;
10990     PL_Dir              = ipD;
10991     PL_Sock             = ipS;
10992     PL_Proc             = ipP;
10993 #else           /* !PERL_IMPLICIT_SYS */
10994     IV i;
10995     CLONE_PARAMS clone_params;
10996     CLONE_PARAMS* param = &clone_params;
10997     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10998     PERL_SET_THX(my_perl);
10999
11000
11001
11002 #    ifdef DEBUGGING
11003     Poison(my_perl, 1, PerlInterpreter);
11004     PL_markstack = 0;
11005     PL_scopestack = 0;
11006     PL_savestack = 0;
11007     PL_savestack_ix = 0;
11008     PL_savestack_max = -1;
11009     PL_retstack = 0;
11010     PL_sig_pending = 0;
11011     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11012 #    else       /* !DEBUGGING */
11013     Zero(my_perl, 1, PerlInterpreter);
11014 #    endif      /* DEBUGGING */
11015 #endif          /* PERL_IMPLICIT_SYS */
11016     param->flags = flags;
11017     param->proto_perl = proto_perl;
11018
11019     /* arena roots */
11020     PL_xiv_arenaroot    = NULL;
11021     PL_xiv_root         = NULL;
11022     PL_xnv_arenaroot    = NULL;
11023     PL_xnv_root         = NULL;
11024     PL_xrv_arenaroot    = NULL;
11025     PL_xrv_root         = NULL;
11026     PL_xpv_arenaroot    = NULL;
11027     PL_xpv_root         = NULL;
11028     PL_xpviv_arenaroot  = NULL;
11029     PL_xpviv_root       = NULL;
11030     PL_xpvnv_arenaroot  = NULL;
11031     PL_xpvnv_root       = NULL;
11032     PL_xpvcv_arenaroot  = NULL;
11033     PL_xpvcv_root       = NULL;
11034     PL_xpvav_arenaroot  = NULL;
11035     PL_xpvav_root       = NULL;
11036     PL_xpvhv_arenaroot  = NULL;
11037     PL_xpvhv_root       = NULL;
11038     PL_xpvmg_arenaroot  = NULL;
11039     PL_xpvmg_root       = NULL;
11040     PL_xpvlv_arenaroot  = NULL;
11041     PL_xpvlv_root       = NULL;
11042     PL_xpvbm_arenaroot  = NULL;
11043     PL_xpvbm_root       = NULL;
11044     PL_he_arenaroot     = NULL;
11045     PL_he_root          = NULL;
11046     PL_nice_chunk       = NULL;
11047     PL_nice_chunk_size  = 0;
11048     PL_sv_count         = 0;
11049     PL_sv_objcount      = 0;
11050     PL_sv_root          = Nullsv;
11051     PL_sv_arenaroot     = Nullsv;
11052
11053     PL_debug            = proto_perl->Idebug;
11054
11055 #ifdef USE_REENTRANT_API
11056     /* XXX: things like -Dm will segfault here in perlio, but doing
11057      *  PERL_SET_CONTEXT(proto_perl);
11058      * breaks too many other things
11059      */
11060     Perl_reentrant_init(aTHX);
11061 #endif
11062
11063     /* create SV map for pointer relocation */
11064     PL_ptr_table = ptr_table_new();
11065
11066     /* initialize these special pointers as early as possible */
11067     SvANY(&PL_sv_undef)         = NULL;
11068     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
11069     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
11070     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11071
11072     SvANY(&PL_sv_no)            = new_XPVNV();
11073     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
11074     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11075     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
11076     SvCUR(&PL_sv_no)            = 0;
11077     SvLEN(&PL_sv_no)            = 1;
11078     SvNVX(&PL_sv_no)            = 0;
11079     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11080
11081     SvANY(&PL_sv_yes)           = new_XPVNV();
11082     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
11083     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11084     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
11085     SvCUR(&PL_sv_yes)           = 1;
11086     SvLEN(&PL_sv_yes)           = 2;
11087     SvNVX(&PL_sv_yes)           = 1;
11088     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11089
11090     /* create (a non-shared!) shared string table */
11091     PL_strtab           = newHV();
11092     HvSHAREKEYS_off(PL_strtab);
11093     hv_ksplit(PL_strtab, 512);
11094     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11095
11096     PL_compiling = proto_perl->Icompiling;
11097
11098     /* These two PVs will be free'd special way so must set them same way op.c does */
11099     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11100     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11101
11102     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
11103     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11104
11105     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11106     if (!specialWARN(PL_compiling.cop_warnings))
11107         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11108     if (!specialCopIO(PL_compiling.cop_io))
11109         PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11110     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11111
11112     /* pseudo environmental stuff */
11113     PL_origargc         = proto_perl->Iorigargc;
11114     PL_origargv         = proto_perl->Iorigargv;
11115
11116     param->stashes      = newAV();  /* Setup array of objects to call clone on */
11117
11118 #ifdef PERLIO_LAYERS
11119     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11120     PerlIO_clone(aTHX_ proto_perl, param);
11121 #endif
11122
11123     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
11124     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
11125     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
11126     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
11127     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
11128     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
11129
11130     /* switches */
11131     PL_minus_c          = proto_perl->Iminus_c;
11132     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
11133     PL_localpatches     = proto_perl->Ilocalpatches;
11134     PL_splitstr         = proto_perl->Isplitstr;
11135     PL_preprocess       = proto_perl->Ipreprocess;
11136     PL_minus_n          = proto_perl->Iminus_n;
11137     PL_minus_p          = proto_perl->Iminus_p;
11138     PL_minus_l          = proto_perl->Iminus_l;
11139     PL_minus_a          = proto_perl->Iminus_a;
11140     PL_minus_F          = proto_perl->Iminus_F;
11141     PL_doswitches       = proto_perl->Idoswitches;
11142     PL_dowarn           = proto_perl->Idowarn;
11143     PL_doextract        = proto_perl->Idoextract;
11144     PL_sawampersand     = proto_perl->Isawampersand;
11145     PL_unsafe           = proto_perl->Iunsafe;
11146     PL_inplace          = SAVEPV(proto_perl->Iinplace);
11147     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
11148     PL_perldb           = proto_perl->Iperldb;
11149     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11150     PL_exit_flags       = proto_perl->Iexit_flags;
11151
11152     /* magical thingies */
11153     /* XXX time(&PL_basetime) when asked for? */
11154     PL_basetime         = proto_perl->Ibasetime;
11155     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
11156
11157     PL_maxsysfd         = proto_perl->Imaxsysfd;
11158     PL_multiline        = proto_perl->Imultiline;
11159     PL_statusvalue      = proto_perl->Istatusvalue;
11160 #ifdef VMS
11161     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
11162 #endif
11163     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
11164
11165     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
11166     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
11167     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
11168
11169     /* Clone the regex array */
11170     PL_regex_padav = newAV();
11171     {
11172         I32 len = av_len((AV*)proto_perl->Iregex_padav);
11173         SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11174         av_push(PL_regex_padav,
11175                 sv_dup_inc(regexen[0],param));
11176         for(i = 1; i <= len; i++) {
11177             if(SvREPADTMP(regexen[i])) {
11178               av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11179             } else {
11180                 av_push(PL_regex_padav,
11181                     SvREFCNT_inc(
11182                         newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11183                              SvIVX(regexen[i])), param)))
11184                        ));
11185             }
11186         }
11187     }
11188     PL_regex_pad = AvARRAY(PL_regex_padav);
11189
11190     /* shortcuts to various I/O objects */
11191     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
11192     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
11193     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
11194     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
11195     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
11196     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
11197
11198     /* shortcuts to regexp stuff */
11199     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
11200
11201     /* shortcuts to misc objects */
11202     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
11203
11204     /* shortcuts to debugging objects */
11205     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
11206     PL_DBline           = gv_dup(proto_perl->IDBline, param);
11207     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
11208     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
11209     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
11210     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
11211     PL_DBassertion      = sv_dup(proto_perl->IDBassertion, param);
11212     PL_lineary          = av_dup(proto_perl->Ilineary, param);
11213     PL_dbargs           = av_dup(proto_perl->Idbargs, param);
11214
11215     /* symbol tables */
11216     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash, param);
11217     PL_curstash         = hv_dup(proto_perl->Tcurstash, param);
11218     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
11219     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
11220     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
11221
11222     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
11223     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
11224     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
11225     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
11226     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
11227     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
11228
11229     PL_sub_generation   = proto_perl->Isub_generation;
11230
11231     /* funky return mechanisms */
11232     PL_forkprocess      = proto_perl->Iforkprocess;
11233
11234     /* subprocess state */
11235     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
11236
11237     /* internal state */
11238     PL_tainting         = proto_perl->Itainting;
11239     PL_taint_warn       = proto_perl->Itaint_warn;
11240     PL_maxo             = proto_perl->Imaxo;
11241     if (proto_perl->Iop_mask)
11242         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11243     else
11244         PL_op_mask      = Nullch;
11245     /* PL_asserting        = proto_perl->Iasserting; */
11246
11247     /* current interpreter roots */
11248     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
11249     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
11250     PL_main_start       = proto_perl->Imain_start;
11251     PL_eval_root        = proto_perl->Ieval_root;
11252     PL_eval_start       = proto_perl->Ieval_start;
11253
11254     /* runtime control stuff */
11255     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11256     PL_copline          = proto_perl->Icopline;
11257
11258     PL_filemode         = proto_perl->Ifilemode;
11259     PL_lastfd           = proto_perl->Ilastfd;
11260     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
11261     PL_Argv             = NULL;
11262     PL_Cmd              = Nullch;
11263     PL_gensym           = proto_perl->Igensym;
11264     PL_preambled        = proto_perl->Ipreambled;
11265     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
11266     PL_laststatval      = proto_perl->Ilaststatval;
11267     PL_laststype        = proto_perl->Ilaststype;
11268     PL_mess_sv          = Nullsv;
11269
11270     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
11271     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
11272
11273     /* interpreter atexit processing */
11274     PL_exitlistlen      = proto_perl->Iexitlistlen;
11275     if (PL_exitlistlen) {
11276         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11277         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11278     }
11279     else
11280         PL_exitlist     = (PerlExitListEntry*)NULL;
11281     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
11282     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
11283     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11284
11285     PL_profiledata      = NULL;
11286     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<', param);
11287     /* PL_rsfp_filters entries have fake IoDIRP() */
11288     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters, param);
11289
11290     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
11291
11292     PAD_CLONE_VARS(proto_perl, param);
11293
11294 #ifdef HAVE_INTERP_INTERN
11295     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11296 #endif
11297
11298     /* more statics moved here */
11299     PL_generation       = proto_perl->Igeneration;
11300     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
11301
11302     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
11303     PL_in_clean_all     = proto_perl->Iin_clean_all;
11304
11305     PL_uid              = proto_perl->Iuid;
11306     PL_euid             = proto_perl->Ieuid;
11307     PL_gid              = proto_perl->Igid;
11308     PL_egid             = proto_perl->Iegid;
11309     PL_nomemok          = proto_perl->Inomemok;
11310     PL_an               = proto_perl->Ian;
11311     PL_evalseq          = proto_perl->Ievalseq;
11312     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
11313     PL_origalen         = proto_perl->Iorigalen;
11314     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
11315     PL_osname           = SAVEPV(proto_perl->Iosname);
11316     PL_sh_path_compat   = proto_perl->Ish_path_compat; /* XXX never deallocated */
11317     PL_sighandlerp      = proto_perl->Isighandlerp;
11318
11319
11320     PL_runops           = proto_perl->Irunops;
11321
11322     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11323
11324 #ifdef CSH
11325     PL_cshlen           = proto_perl->Icshlen;
11326     PL_cshname          = proto_perl->Icshname; /* XXX never deallocated */
11327 #endif
11328
11329     PL_lex_state        = proto_perl->Ilex_state;
11330     PL_lex_defer        = proto_perl->Ilex_defer;
11331     PL_lex_expect       = proto_perl->Ilex_expect;
11332     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
11333     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
11334     PL_lex_starts       = proto_perl->Ilex_starts;
11335     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff, param);
11336     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl, param);
11337     PL_lex_op           = proto_perl->Ilex_op;
11338     PL_lex_inpat        = proto_perl->Ilex_inpat;
11339     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
11340     PL_lex_brackets     = proto_perl->Ilex_brackets;
11341     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11342     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
11343     PL_lex_casemods     = proto_perl->Ilex_casemods;
11344     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11345     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
11346
11347     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11348     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11349     PL_nexttoke         = proto_perl->Inexttoke;
11350
11351     /* XXX This is probably masking the deeper issue of why
11352      * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11353      * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11354      * (A little debugging with a watchpoint on it may help.)
11355      */
11356     if (SvANY(proto_perl->Ilinestr)) {
11357         PL_linestr              = sv_dup_inc(proto_perl->Ilinestr, param);
11358         i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
11359         PL_bufptr               = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11360         i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
11361         PL_oldbufptr    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11362         i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
11363         PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11364         i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
11365         PL_linestart    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11366     }
11367     else {
11368         PL_linestr = NEWSV(65,79);
11369         sv_upgrade(PL_linestr,SVt_PVIV);
11370         sv_setpvn(PL_linestr,"",0);
11371         PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11372     }
11373     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11374     PL_pending_ident    = proto_perl->Ipending_ident;
11375     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
11376
11377     PL_expect           = proto_perl->Iexpect;
11378
11379     PL_multi_start      = proto_perl->Imulti_start;
11380     PL_multi_end        = proto_perl->Imulti_end;
11381     PL_multi_open       = proto_perl->Imulti_open;
11382     PL_multi_close      = proto_perl->Imulti_close;
11383
11384     PL_error_count      = proto_perl->Ierror_count;
11385     PL_subline          = proto_perl->Isubline;
11386     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
11387
11388     /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11389     if (SvANY(proto_perl->Ilinestr)) {
11390         i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
11391         PL_last_uni             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11392         i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
11393         PL_last_lop             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11394         PL_last_lop_op  = proto_perl->Ilast_lop_op;
11395     }
11396     else {
11397         PL_last_uni     = SvPVX(PL_linestr);
11398         PL_last_lop     = SvPVX(PL_linestr);
11399         PL_last_lop_op  = 0;
11400     }
11401     PL_in_my            = proto_perl->Iin_my;
11402     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash, param);
11403 #ifdef FCRYPT
11404     PL_cryptseen        = proto_perl->Icryptseen;
11405 #endif
11406
11407     PL_hints            = proto_perl->Ihints;
11408
11409     PL_amagic_generation        = proto_perl->Iamagic_generation;
11410
11411 #ifdef USE_LOCALE_COLLATE
11412     PL_collation_ix     = proto_perl->Icollation_ix;
11413     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
11414     PL_collation_standard       = proto_perl->Icollation_standard;
11415     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
11416     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
11417 #endif /* USE_LOCALE_COLLATE */
11418
11419 #ifdef USE_LOCALE_NUMERIC
11420     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
11421     PL_numeric_standard = proto_perl->Inumeric_standard;
11422     PL_numeric_local    = proto_perl->Inumeric_local;
11423     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11424 #endif /* !USE_LOCALE_NUMERIC */
11425
11426     /* utf8 character classes */
11427     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11428     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11429     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11430     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11431     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
11432     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11433     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
11434     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
11435     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
11436     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
11437     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
11438     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
11439     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11440     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
11441     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11442     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11443     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11444     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11445     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11446     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11447
11448     /* Did the locale setup indicate UTF-8? */
11449     PL_utf8locale       = proto_perl->Iutf8locale;
11450     /* Unicode features (see perlrun/-C) */
11451     PL_unicode          = proto_perl->Iunicode;
11452
11453     /* Pre-5.8 signals control */
11454     PL_signals          = proto_perl->Isignals;
11455
11456     /* times() ticks per second */
11457     PL_clocktick        = proto_perl->Iclocktick;
11458
11459     /* Recursion stopper for PerlIO_find_layer */
11460     PL_in_load_module   = proto_perl->Iin_load_module;
11461
11462     /* sort() routine */
11463     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
11464
11465     /* Not really needed/useful since the reenrant_retint is "volatile",
11466      * but do it for consistency's sake. */
11467     PL_reentrant_retint = proto_perl->Ireentrant_retint;
11468
11469     /* Hooks to shared SVs and locks. */
11470     PL_sharehook        = proto_perl->Isharehook;
11471     PL_lockhook         = proto_perl->Ilockhook;
11472     PL_unlockhook       = proto_perl->Iunlockhook;
11473     PL_threadhook       = proto_perl->Ithreadhook;
11474
11475     PL_runops_std       = proto_perl->Irunops_std;
11476     PL_runops_dbg       = proto_perl->Irunops_dbg;
11477
11478 #ifdef THREADS_HAVE_PIDS
11479     PL_ppid             = proto_perl->Ippid;
11480 #endif
11481
11482     /* swatch cache */
11483     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
11484     PL_last_swash_klen  = 0;
11485     PL_last_swash_key[0]= '\0';
11486     PL_last_swash_tmps  = (U8*)NULL;
11487     PL_last_swash_slen  = 0;
11488
11489     PL_glob_index       = proto_perl->Iglob_index;
11490     PL_srand_called     = proto_perl->Isrand_called;
11491     PL_hash_seed        = proto_perl->Ihash_seed;
11492     PL_rehash_seed      = proto_perl->Irehash_seed;
11493     PL_uudmap['M']      = 0;            /* reinits on demand */
11494     PL_bitcount         = Nullch;       /* reinits on demand */
11495
11496     if (proto_perl->Ipsig_pend) {
11497         Newz(0, PL_psig_pend, SIG_SIZE, int);
11498     }
11499     else {
11500         PL_psig_pend    = (int*)NULL;
11501     }
11502
11503     if (proto_perl->Ipsig_ptr) {
11504         Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
11505         Newz(0, PL_psig_name, SIG_SIZE, SV*);
11506         for (i = 1; i < SIG_SIZE; i++) {
11507             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11508             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11509         }
11510     }
11511     else {
11512         PL_psig_ptr     = (SV**)NULL;
11513         PL_psig_name    = (SV**)NULL;
11514     }
11515
11516     /* thrdvar.h stuff */
11517
11518     if (flags & CLONEf_COPY_STACKS) {
11519         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11520         PL_tmps_ix              = proto_perl->Ttmps_ix;
11521         PL_tmps_max             = proto_perl->Ttmps_max;
11522         PL_tmps_floor           = proto_perl->Ttmps_floor;
11523         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
11524         i = 0;
11525         while (i <= PL_tmps_ix) {
11526             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11527             ++i;
11528         }
11529
11530         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11531         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11532         Newz(54, PL_markstack, i, I32);
11533         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
11534                                                   - proto_perl->Tmarkstack);
11535         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
11536                                                   - proto_perl->Tmarkstack);
11537         Copy(proto_perl->Tmarkstack, PL_markstack,
11538              PL_markstack_ptr - PL_markstack + 1, I32);
11539
11540         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11541          * NOTE: unlike the others! */
11542         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
11543         PL_scopestack_max       = proto_perl->Tscopestack_max;
11544         Newz(54, PL_scopestack, PL_scopestack_max, I32);
11545         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11546
11547         /* next push_return() sets PL_retstack[PL_retstack_ix]
11548          * NOTE: unlike the others! */
11549         PL_retstack_ix          = proto_perl->Tretstack_ix;
11550         PL_retstack_max         = proto_perl->Tretstack_max;
11551         Newz(54, PL_retstack, PL_retstack_max, OP*);
11552         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
11553
11554         /* NOTE: si_dup() looks at PL_markstack */
11555         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo, param);
11556
11557         /* PL_curstack          = PL_curstackinfo->si_stack; */
11558         PL_curstack             = av_dup(proto_perl->Tcurstack, param);
11559         PL_mainstack            = av_dup(proto_perl->Tmainstack, param);
11560
11561         /* next PUSHs() etc. set *(PL_stack_sp+1) */
11562         PL_stack_base           = AvARRAY(PL_curstack);
11563         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
11564                                                    - proto_perl->Tstack_base);
11565         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
11566
11567         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11568          * NOTE: unlike the others! */
11569         PL_savestack_ix         = proto_perl->Tsavestack_ix;
11570         PL_savestack_max        = proto_perl->Tsavestack_max;
11571         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
11572         PL_savestack            = ss_dup(proto_perl, param);
11573     }
11574     else {
11575         init_stacks();
11576         ENTER;                  /* perl_destruct() wants to LEAVE; */
11577     }
11578
11579     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
11580     PL_top_env          = &PL_start_env;
11581
11582     PL_op               = proto_perl->Top;
11583
11584     PL_Sv               = Nullsv;
11585     PL_Xpv              = (XPV*)NULL;
11586     PL_na               = proto_perl->Tna;
11587
11588     PL_statbuf          = proto_perl->Tstatbuf;
11589     PL_statcache        = proto_perl->Tstatcache;
11590     PL_statgv           = gv_dup(proto_perl->Tstatgv, param);
11591     PL_statname         = sv_dup_inc(proto_perl->Tstatname, param);
11592 #ifdef HAS_TIMES
11593     PL_timesbuf         = proto_perl->Ttimesbuf;
11594 #endif
11595
11596     PL_tainted          = proto_perl->Ttainted;
11597     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
11598     PL_rs               = sv_dup_inc(proto_perl->Trs, param);
11599     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv, param);
11600     PL_ofs_sv           = sv_dup_inc(proto_perl->Tofs_sv, param);
11601     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv, param);
11602     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
11603     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget, param);
11604     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget, param);
11605     PL_formtarget       = sv_dup(proto_perl->Tformtarget, param);
11606
11607     PL_restartop        = proto_perl->Trestartop;
11608     PL_in_eval          = proto_perl->Tin_eval;
11609     PL_delaymagic       = proto_perl->Tdelaymagic;
11610     PL_dirty            = proto_perl->Tdirty;
11611     PL_localizing       = proto_perl->Tlocalizing;
11612
11613 #ifdef PERL_FLEXIBLE_EXCEPTIONS
11614     PL_protect          = proto_perl->Tprotect;
11615 #endif
11616     PL_errors           = sv_dup_inc(proto_perl->Terrors, param);
11617     PL_hv_fetch_ent_mh  = Nullhe;
11618     PL_modcount         = proto_perl->Tmodcount;
11619     PL_lastgotoprobe    = Nullop;
11620     PL_dumpindent       = proto_perl->Tdumpindent;
11621
11622     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11623     PL_sortstash        = hv_dup(proto_perl->Tsortstash, param);
11624     PL_firstgv          = gv_dup(proto_perl->Tfirstgv, param);
11625     PL_secondgv         = gv_dup(proto_perl->Tsecondgv, param);
11626     PL_sortcxix         = proto_perl->Tsortcxix;
11627     PL_efloatbuf        = Nullch;               /* reinits on demand */
11628     PL_efloatsize       = 0;                    /* reinits on demand */
11629
11630     /* regex stuff */
11631
11632     PL_screamfirst      = NULL;
11633     PL_screamnext       = NULL;
11634     PL_maxscream        = -1;                   /* reinits on demand */
11635     PL_lastscream       = Nullsv;
11636
11637     PL_watchaddr        = NULL;
11638     PL_watchok          = Nullch;
11639
11640     PL_regdummy         = proto_perl->Tregdummy;
11641     PL_regprecomp       = Nullch;
11642     PL_regnpar          = 0;
11643     PL_regsize          = 0;
11644     PL_colorset         = 0;            /* reinits PL_colors[] */
11645     /*PL_colors[6]      = {0,0,0,0,0,0};*/
11646     PL_reginput         = Nullch;
11647     PL_regbol           = Nullch;
11648     PL_regeol           = Nullch;
11649     PL_regstartp        = (I32*)NULL;
11650     PL_regendp          = (I32*)NULL;
11651     PL_reglastparen     = (U32*)NULL;
11652     PL_reglastcloseparen        = (U32*)NULL;
11653     PL_regtill          = Nullch;
11654     PL_reg_start_tmp    = (char**)NULL;
11655     PL_reg_start_tmpl   = 0;
11656     PL_regdata          = (struct reg_data*)NULL;
11657     PL_bostr            = Nullch;
11658     PL_reg_flags        = 0;
11659     PL_reg_eval_set     = 0;
11660     PL_regnarrate       = 0;
11661     PL_regprogram       = (regnode*)NULL;
11662     PL_regindent        = 0;
11663     PL_regcc            = (CURCUR*)NULL;
11664     PL_reg_call_cc      = (struct re_cc_state*)NULL;
11665     PL_reg_re           = (regexp*)NULL;
11666     PL_reg_ganch        = Nullch;
11667     PL_reg_sv           = Nullsv;
11668     PL_reg_match_utf8   = FALSE;
11669     PL_reg_magic        = (MAGIC*)NULL;
11670     PL_reg_oldpos       = 0;
11671     PL_reg_oldcurpm     = (PMOP*)NULL;
11672     PL_reg_curpm        = (PMOP*)NULL;
11673     PL_reg_oldsaved     = Nullch;
11674     PL_reg_oldsavedlen  = 0;
11675 #ifdef PERL_COPY_ON_WRITE
11676     PL_nrs              = Nullsv;
11677 #endif
11678     PL_reg_maxiter      = 0;
11679     PL_reg_leftiter     = 0;
11680     PL_reg_poscache     = Nullch;
11681     PL_reg_poscache_size= 0;
11682
11683     /* RE engine - function pointers */
11684     PL_regcompp         = proto_perl->Tregcompp;
11685     PL_regexecp         = proto_perl->Tregexecp;
11686     PL_regint_start     = proto_perl->Tregint_start;
11687     PL_regint_string    = proto_perl->Tregint_string;
11688     PL_regfree          = proto_perl->Tregfree;
11689
11690     PL_reginterp_cnt    = 0;
11691     PL_reg_starttry     = 0;
11692
11693     /* Pluggable optimizer */
11694     PL_peepp            = proto_perl->Tpeepp;
11695
11696     PL_stashcache       = newHV();
11697
11698     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11699         ptr_table_free(PL_ptr_table);
11700         PL_ptr_table = NULL;
11701     }
11702
11703     /* Call the ->CLONE method, if it exists, for each of the stashes
11704        identified by sv_dup() above.
11705     */
11706     while(av_len(param->stashes) != -1) {
11707         HV* stash = (HV*) av_shift(param->stashes);
11708         GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11709         if (cloner && GvCV(cloner)) {
11710             dSP;
11711             ENTER;
11712             SAVETMPS;
11713             PUSHMARK(SP);
11714            XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
11715             PUTBACK;
11716             call_sv((SV*)GvCV(cloner), G_DISCARD);
11717             FREETMPS;
11718             LEAVE;
11719         }
11720     }
11721
11722     SvREFCNT_dec(param->stashes);
11723
11724     return my_perl;
11725 }
11726
11727 #endif /* USE_ITHREADS */
11728
11729 /*
11730 =head1 Unicode Support
11731
11732 =for apidoc sv_recode_to_utf8
11733
11734 The encoding is assumed to be an Encode object, on entry the PV
11735 of the sv is assumed to be octets in that encoding, and the sv
11736 will be converted into Unicode (and UTF-8).
11737
11738 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11739 is not a reference, nothing is done to the sv.  If the encoding is not
11740 an C<Encode::XS> Encoding object, bad things will happen.
11741 (See F<lib/encoding.pm> and L<Encode>).
11742
11743 The PV of the sv is returned.
11744
11745 =cut */
11746
11747 char *
11748 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11749 {
11750     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11751         SV *uni;
11752         STRLEN len;
11753         char *s;
11754         dSP;
11755         ENTER;
11756         SAVETMPS;
11757         save_re_context();
11758         PUSHMARK(sp);
11759         EXTEND(SP, 3);
11760         XPUSHs(encoding);
11761         XPUSHs(sv);
11762 /*
11763   NI-S 2002/07/09
11764   Passing sv_yes is wrong - it needs to be or'ed set of constants
11765   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11766   remove converted chars from source.
11767
11768   Both will default the value - let them.
11769
11770         XPUSHs(&PL_sv_yes);
11771 */
11772         PUTBACK;
11773         call_method("decode", G_SCALAR);
11774         SPAGAIN;
11775         uni = POPs;
11776         PUTBACK;
11777         s = SvPV(uni, len);
11778         if (s != SvPVX(sv)) {
11779             SvGROW(sv, len + 1);
11780             Move(s, SvPVX(sv), len, char);
11781             SvCUR_set(sv, len);
11782             SvPVX(sv)[len] = 0;
11783         }
11784         FREETMPS;
11785         LEAVE;
11786         SvUTF8_on(sv);
11787     }
11788     return SvPVX(sv);
11789 }
11790
11791 /*
11792 =for apidoc sv_cat_decode
11793
11794 The encoding is assumed to be an Encode object, the PV of the ssv is
11795 assumed to be octets in that encoding and decoding the input starts
11796 from the position which (PV + *offset) pointed to.  The dsv will be
11797 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
11798 when the string tstr appears in decoding output or the input ends on
11799 the PV of the ssv. The value which the offset points will be modified
11800 to the last input position on the ssv.
11801
11802 Returns TRUE if the terminator was found, else returns FALSE.
11803
11804 =cut */
11805
11806 bool
11807 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11808                    SV *ssv, int *offset, char *tstr, int tlen)
11809 {
11810     bool ret = FALSE;
11811     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11812         SV *offsv;
11813         dSP;
11814         ENTER;
11815         SAVETMPS;
11816         save_re_context();
11817         PUSHMARK(sp);
11818         EXTEND(SP, 6);
11819         XPUSHs(encoding);
11820         XPUSHs(dsv);
11821         XPUSHs(ssv);
11822         XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11823         XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11824         PUTBACK;
11825         call_method("cat_decode", G_SCALAR);
11826         SPAGAIN;
11827         ret = SvTRUE(TOPs);
11828         *offset = SvIV(offsv);
11829         PUTBACK;
11830         FREETMPS;
11831         LEAVE;
11832     }
11833     else
11834         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11835     return ret;
11836 }
11837