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