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