sv.c

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