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