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