sv.c

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