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