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