sv.c

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