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                                         break;
3010                                     }
3011                                 }
3012                             }
3013
3014                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3015                             Copy("(?", mg->mg_ptr, 2, char);
3016                             Copy(reflags, mg->mg_ptr+2, left, char);
3017                             Copy(":", mg->mg_ptr+left+2, 1, char);
3018                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3019                             if (need_newline)
3020                                 mg->mg_ptr[mg->mg_len - 2] = '\n';
3021                             mg->mg_ptr[mg->mg_len - 1] = ')';
3022                             mg->mg_ptr[mg->mg_len] = 0;
3023                         }
3024                         PL_reginterp_cnt += re->program[0].next_off;
3025
3026                         if (re->reganch & ROPT_UTF8)
3027                             SvUTF8_on(origsv);
3028                         else
3029                             SvUTF8_off(origsv);
3030                         *lp = mg->mg_len;
3031                         return mg->mg_ptr;
3032                     }
3033                                         /* Fall through */
3034                 case SVt_NULL:
3035                 case SVt_IV:
3036                 case SVt_NV:
3037                 case SVt_RV:
3038                 case SVt_PV:
3039                 case SVt_PVIV:
3040                 case SVt_PVNV:
3041                 case SVt_PVBM:  if (SvROK(sv))
3042                                     s = "REF";
3043                                 else
3044                                     s = "SCALAR";               break;
3045                 case SVt_PVLV:  s = "LVALUE";                   break;
3046                 case SVt_PVAV:  s = "ARRAY";                    break;
3047                 case SVt_PVHV:  s = "HASH";                     break;
3048                 case SVt_PVCV:  s = "CODE";                     break;
3049                 case SVt_PVGV:  s = "GLOB";                     break;
3050                 case SVt_PVFM:  s = "FORMAT";                   break;
3051                 case SVt_PVIO:  s = "IO";                       break;
3052                 default:        s = "UNKNOWN";                  break;
3053                 }
3054                 tsv = NEWSV(0,0);
3055                 if (SvOBJECT(sv))
3056                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
3057                 else
3058                     sv_setpv(tsv, s);
3059                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3060                 goto tokensaveref;
3061             }
3062             *lp = strlen(s);
3063             return s;
3064         }
3065         if (SvREADONLY(sv) && !SvOK(sv)) {
3066             if (ckWARN(WARN_UNINITIALIZED))
3067                 report_uninit();
3068             *lp = 0;
3069             return "";
3070         }
3071     }
3072     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3073         /* I'm assuming that if both IV and NV are equally valid then
3074            converting the IV is going to be more efficient */
3075         U32 isIOK = SvIOK(sv);
3076         U32 isUIOK = SvIsUV(sv);
3077         char buf[TYPE_CHARS(UV)];
3078         char *ebuf, *ptr;
3079
3080         if (SvTYPE(sv) < SVt_PVIV)
3081             sv_upgrade(sv, SVt_PVIV);
3082         if (isUIOK)
3083             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3084         else
3085             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3086         SvGROW(sv, (STRLEN)(ebuf - ptr + 1));   /* inlined from sv_setpvn */
3087         Move(ptr,SvPVX(sv),ebuf - ptr,char);
3088         SvCUR_set(sv, ebuf - ptr);
3089         s = SvEND(sv);
3090         *s = '\0';
3091         if (isIOK)
3092             SvIOK_on(sv);
3093         else
3094             SvIOKp_on(sv);
3095         if (isUIOK)
3096             SvIsUV_on(sv);
3097     }
3098     else if (SvNOKp(sv)) {
3099         if (SvTYPE(sv) < SVt_PVNV)
3100             sv_upgrade(sv, SVt_PVNV);
3101         /* The +20 is pure guesswork.  Configure test needed. --jhi */
3102         SvGROW(sv, NV_DIG + 20);
3103         s = SvPVX(sv);
3104         olderrno = errno;       /* some Xenix systems wipe out errno here */
3105 #ifdef apollo
3106         if (SvNVX(sv) == 0.0)
3107             (void)strcpy(s,"0");
3108         else
3109 #endif /*apollo*/
3110         {
3111             Gconvert(SvNVX(sv), NV_DIG, 0, s);
3112         }
3113         errno = olderrno;
3114 #ifdef FIXNEGATIVEZERO
3115         if (*s == '-' && s[1] == '0' && !s[2])
3116             strcpy(s,"0");
3117 #endif
3118         while (*s) s++;
3119 #ifdef hcx
3120         if (s[-1] == '.')
3121             *--s = '\0';
3122 #endif
3123     }
3124     else {
3125         if (ckWARN(WARN_UNINITIALIZED)
3126             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3127             report_uninit();
3128         *lp = 0;
3129         if (SvTYPE(sv) < SVt_PV)
3130             /* Typically the caller expects that sv_any is not NULL now.  */
3131             sv_upgrade(sv, SVt_PV);
3132         return "";
3133     }
3134     *lp = s - SvPVX(sv);
3135     SvCUR_set(sv, *lp);
3136     SvPOK_on(sv);
3137     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3138                           PTR2UV(sv),SvPVX(sv)));
3139     return SvPVX(sv);
3140
3141   tokensave:
3142     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
3143         /* Sneaky stuff here */
3144
3145       tokensaveref:
3146         if (!tsv)
3147             tsv = newSVpv(tmpbuf, 0);
3148         sv_2mortal(tsv);
3149         *lp = SvCUR(tsv);
3150         return SvPVX(tsv);
3151     }
3152     else {
3153         STRLEN len;
3154         char *t;
3155
3156         if (tsv) {
3157             sv_2mortal(tsv);
3158             t = SvPVX(tsv);
3159             len = SvCUR(tsv);
3160         }
3161         else {
3162             t = tmpbuf;
3163             len = strlen(tmpbuf);
3164         }
3165 #ifdef FIXNEGATIVEZERO
3166         if (len == 2 && t[0] == '-' && t[1] == '0') {
3167             t = "0";
3168             len = 1;
3169         }
3170 #endif
3171         (void)SvUPGRADE(sv, SVt_PV);
3172         *lp = len;
3173         s = SvGROW(sv, len + 1);
3174         SvCUR_set(sv, len);
3175         (void)strcpy(s, t);
3176         SvPOKp_on(sv);
3177         return s;
3178     }
3179 }
3180
3181 /*
3182 =for apidoc sv_copypv
3183
3184 Copies a stringified representation of the source SV into the
3185 destination SV.  Automatically performs any necessary mg_get and
3186 coercion of numeric values into strings.  Guaranteed to preserve
3187 UTF-8 flag even from overloaded objects.  Similar in nature to
3188 sv_2pv[_flags] but operates directly on an SV instead of just the
3189 string.  Mostly uses sv_2pv_flags to do its work, except when that
3190 would lose the UTF-8'ness of the PV.
3191
3192 =cut
3193 */
3194
3195 void
3196 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3197 {
3198     STRLEN len;
3199     char *s;
3200     s = SvPV(ssv,len);
3201     sv_setpvn(dsv,s,len);
3202     if (SvUTF8(ssv))
3203         SvUTF8_on(dsv);
3204     else
3205         SvUTF8_off(dsv);
3206 }
3207
3208 /*
3209 =for apidoc sv_2pvbyte_nolen
3210
3211 Return a pointer to the byte-encoded representation of the SV.
3212 May cause the SV to be downgraded from UTF8 as a side-effect.
3213
3214 Usually accessed via the C<SvPVbyte_nolen> macro.
3215
3216 =cut
3217 */
3218
3219 char *
3220 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3221 {
3222     STRLEN n_a;
3223     return sv_2pvbyte(sv, &n_a);
3224 }
3225
3226 /*
3227 =for apidoc sv_2pvbyte
3228
3229 Return a pointer to the byte-encoded representation of the SV, and set *lp
3230 to its length.  May cause the SV to be downgraded from UTF8 as a
3231 side-effect.
3232
3233 Usually accessed via the C<SvPVbyte> macro.
3234
3235 =cut
3236 */
3237
3238 char *
3239 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3240 {
3241     sv_utf8_downgrade(sv,0);
3242     return SvPV(sv,*lp);
3243 }
3244
3245 /*
3246 =for apidoc sv_2pvutf8_nolen
3247
3248 Return a pointer to the UTF8-encoded representation of the SV.
3249 May cause the SV to be upgraded to UTF8 as a side-effect.
3250
3251 Usually accessed via the C<SvPVutf8_nolen> macro.
3252
3253 =cut
3254 */
3255
3256 char *
3257 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3258 {
3259     STRLEN n_a;
3260     return sv_2pvutf8(sv, &n_a);
3261 }
3262
3263 /*
3264 =for apidoc sv_2pvutf8
3265
3266 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3267 to its length.  May cause the SV to be upgraded to UTF8 as a side-effect.
3268
3269 Usually accessed via the C<SvPVutf8> macro.
3270
3271 =cut
3272 */
3273
3274 char *
3275 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3276 {
3277     sv_utf8_upgrade(sv);
3278     return SvPV(sv,*lp);
3279 }
3280
3281 /*
3282 =for apidoc sv_2bool
3283
3284 This function is only called on magical items, and is only used by
3285 sv_true() or its macro equivalent.
3286
3287 =cut
3288 */
3289
3290 bool
3291 Perl_sv_2bool(pTHX_ register SV *sv)
3292 {
3293     if (SvGMAGICAL(sv))
3294         mg_get(sv);
3295
3296     if (!SvOK(sv))
3297         return 0;
3298     if (SvROK(sv)) {
3299         SV* tmpsv;
3300         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3301                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3302             return (bool)SvTRUE(tmpsv);
3303       return SvRV(sv) != 0;
3304     }
3305     if (SvPOKp(sv)) {
3306         register XPV* Xpvtmp;
3307         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3308                 (*Xpvtmp->xpv_pv > '0' ||
3309                 Xpvtmp->xpv_cur > 1 ||
3310                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3311             return 1;
3312         else
3313             return 0;
3314     }
3315     else {
3316         if (SvIOKp(sv))
3317             return SvIVX(sv) != 0;
3318         else {
3319             if (SvNOKp(sv))
3320                 return SvNVX(sv) != 0.0;
3321             else
3322                 return FALSE;
3323         }
3324     }
3325 }
3326
3327 /*
3328 =for apidoc sv_utf8_upgrade
3329
3330 Convert the PV of an SV to its UTF8-encoded form.
3331 Forces the SV to string form if it is not already.
3332 Always sets the SvUTF8 flag to avoid future validity checks even
3333 if all the bytes have hibit clear.
3334
3335 This is not as a general purpose byte encoding to Unicode interface:
3336 use the Encode extension for that.
3337
3338 =for apidoc sv_utf8_upgrade_flags
3339
3340 Convert the PV of an SV to its UTF8-encoded form.
3341 Forces the SV to string form if it is not already.
3342 Always sets the SvUTF8 flag to avoid future validity checks even
3343 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3344 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3345 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3346
3347 This is not as a general purpose byte encoding to Unicode interface:
3348 use the Encode extension for that.
3349
3350 =cut
3351 */
3352
3353 STRLEN
3354 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3355 {
3356     U8 *s, *t, *e;
3357     int  hibit = 0;
3358
3359     if (!sv)
3360         return 0;
3361
3362     if (!SvPOK(sv)) {
3363         STRLEN len = 0;
3364         (void) sv_2pv_flags(sv,&len, flags);
3365         if (!SvPOK(sv))
3366              return len;
3367     }
3368
3369     if (SvUTF8(sv))
3370         return SvCUR(sv);
3371
3372     if (SvIsCOW(sv)) {
3373         sv_force_normal_flags(sv, 0);
3374     }
3375
3376     if (PL_encoding)
3377         sv_recode_to_utf8(sv, PL_encoding);
3378     else { /* Assume Latin-1/EBCDIC */
3379          /* This function could be much more efficient if we
3380           * had a FLAG in SVs to signal if there are any hibit
3381           * chars in the PV.  Given that there isn't such a flag
3382           * make the loop as fast as possible. */
3383          s = (U8 *) SvPVX(sv);
3384          e = (U8 *) SvEND(sv);
3385          t = s;
3386          while (t < e) {
3387               U8 ch = *t++;
3388               if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3389                    break;
3390          }
3391          if (hibit) {
3392               STRLEN len;
3393
3394               len = SvCUR(sv) + 1; /* Plus the \0 */
3395               SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3396               SvCUR(sv) = len - 1;
3397               if (SvLEN(sv) != 0)
3398                    Safefree(s); /* No longer using what was there before. */
3399               SvLEN(sv) = len; /* No longer know the real size. */
3400          }
3401          /* Mark as UTF-8 even if no hibit - saves scanning loop */
3402          SvUTF8_on(sv);
3403     }
3404     return SvCUR(sv);
3405 }
3406
3407 /*
3408 =for apidoc sv_utf8_downgrade
3409
3410 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3411 This may not be possible if the PV contains non-byte encoding characters;
3412 if this is the case, either returns false or, if C<fail_ok> is not
3413 true, croaks.
3414
3415 This is not as a general purpose Unicode to byte encoding interface:
3416 use the Encode extension for that.
3417
3418 =cut
3419 */
3420
3421 bool
3422 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3423 {
3424     if (SvPOK(sv) && SvUTF8(sv)) {
3425         if (SvCUR(sv)) {
3426             U8 *s;
3427             STRLEN len;
3428
3429             if (SvIsCOW(sv)) {
3430                 sv_force_normal_flags(sv, 0);
3431             }
3432             s = (U8 *) SvPV(sv, len);
3433             if (!utf8_to_bytes(s, &len)) {
3434                 if (fail_ok)
3435                     return FALSE;
3436                 else {
3437                     if (PL_op)
3438                         Perl_croak(aTHX_ "Wide character in %s",
3439                                    OP_DESC(PL_op));
3440                     else
3441                         Perl_croak(aTHX_ "Wide character");
3442                 }
3443             }
3444             SvCUR(sv) = len;
3445         }
3446     }
3447     SvUTF8_off(sv);
3448     return TRUE;
3449 }
3450
3451 /*
3452 =for apidoc sv_utf8_encode
3453
3454 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3455 flag so that it looks like octets again. Used as a building block
3456 for encode_utf8 in Encode.xs
3457
3458 =cut
3459 */
3460
3461 void
3462 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3463 {
3464     (void) sv_utf8_upgrade(sv);
3465     SvUTF8_off(sv);
3466 }
3467
3468 /*
3469 =for apidoc sv_utf8_decode
3470
3471 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3472 turn off SvUTF8 if needed so that we see characters. Used as a building block
3473 for decode_utf8 in Encode.xs
3474
3475 =cut
3476 */
3477
3478 bool
3479 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3480 {
3481     if (SvPOK(sv)) {
3482         U8 *c;
3483         U8 *e;
3484
3485         /* The octets may have got themselves encoded - get them back as
3486          * bytes
3487          */
3488         if (!sv_utf8_downgrade(sv, TRUE))
3489             return FALSE;
3490
3491         /* it is actually just a matter of turning the utf8 flag on, but
3492          * we want to make sure everything inside is valid utf8 first.
3493          */
3494         c = (U8 *) SvPVX(sv);
3495         if (!is_utf8_string(c, SvCUR(sv)+1))
3496             return FALSE;
3497         e = (U8 *) SvEND(sv);
3498         while (c < e) {
3499             U8 ch = *c++;
3500             if (!UTF8_IS_INVARIANT(ch)) {
3501                 SvUTF8_on(sv);
3502                 break;
3503             }
3504         }
3505     }
3506     return TRUE;
3507 }
3508
3509 /*
3510 =for apidoc sv_setsv
3511
3512 Copies the contents of the source SV C<ssv> into the destination SV
3513 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3514 function if the source SV needs to be reused. Does not handle 'set' magic.
3515 Loosely speaking, it performs a copy-by-value, obliterating any previous
3516 content of the destination.
3517
3518 You probably want to use one of the assortment of wrappers, such as
3519 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3520 C<SvSetMagicSV_nosteal>.
3521
3522 =for apidoc sv_setsv_flags
3523
3524 Copies the contents of the source SV C<ssv> into the destination SV
3525 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3526 function if the source SV needs to be reused. Does not handle 'set' magic.
3527 Loosely speaking, it performs a copy-by-value, obliterating any previous
3528 content of the destination.
3529 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3530 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3531 implemented in terms of this function.
3532
3533 You probably want to use one of the assortment of wrappers, such as
3534 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3535 C<SvSetMagicSV_nosteal>.
3536
3537 This is the primary function for copying scalars, and most other
3538 copy-ish functions and macros use this underneath.
3539
3540 =cut
3541 */
3542
3543 void
3544 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3545 {
3546     register U32 sflags;
3547     register int dtype;
3548     register int stype;
3549
3550     if (sstr == dstr)
3551         return;
3552     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3553     if (!sstr)
3554         sstr = &PL_sv_undef;
3555     stype = SvTYPE(sstr);
3556     dtype = SvTYPE(dstr);
3557
3558     SvAMAGIC_off(dstr);
3559     if ( SvVOK(dstr) )
3560     {
3561         /* need to nuke the magic */
3562         mg_free(dstr);
3563         SvRMAGICAL_off(dstr);
3564     }
3565
3566     /* There's a lot of redundancy below but we're going for speed here */
3567
3568     switch (stype) {
3569     case SVt_NULL:
3570       undef_sstr:
3571         if (dtype != SVt_PVGV) {
3572             (void)SvOK_off(dstr);
3573             return;
3574         }
3575         break;
3576     case SVt_IV:
3577         if (SvIOK(sstr)) {
3578             switch (dtype) {
3579             case SVt_NULL:
3580                 sv_upgrade(dstr, SVt_IV);
3581                 break;
3582             case SVt_NV:
3583                 sv_upgrade(dstr, SVt_PVNV);
3584                 break;
3585             case SVt_RV:
3586             case SVt_PV:
3587                 sv_upgrade(dstr, SVt_PVIV);
3588                 break;
3589             }
3590             (void)SvIOK_only(dstr);
3591             SvIVX(dstr) = SvIVX(sstr);
3592             if (SvIsUV(sstr))
3593                 SvIsUV_on(dstr);
3594             if (SvTAINTED(sstr))
3595                 SvTAINT(dstr);
3596             return;
3597         }
3598         goto undef_sstr;
3599
3600     case SVt_NV:
3601         if (SvNOK(sstr)) {
3602             switch (dtype) {
3603             case SVt_NULL:
3604             case SVt_IV:
3605                 sv_upgrade(dstr, SVt_NV);
3606                 break;
3607             case SVt_RV:
3608             case SVt_PV:
3609             case SVt_PVIV:
3610                 sv_upgrade(dstr, SVt_PVNV);
3611                 break;
3612             }
3613             SvNVX(dstr) = SvNVX(sstr);
3614             (void)SvNOK_only(dstr);
3615             if (SvTAINTED(sstr))
3616                 SvTAINT(dstr);
3617             return;
3618         }
3619         goto undef_sstr;
3620
3621     case SVt_RV:
3622         if (dtype < SVt_RV)
3623             sv_upgrade(dstr, SVt_RV);
3624         else if (dtype == SVt_PVGV &&
3625                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3626             sstr = SvRV(sstr);
3627             if (sstr == dstr) {
3628                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3629                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3630                 {
3631                     GvIMPORTED_on(dstr);
3632                 }
3633                 GvMULTI_on(dstr);
3634                 return;
3635             }
3636             goto glob_assign;
3637         }
3638         break;
3639     case SVt_PV:
3640     case SVt_PVFM:
3641         if (dtype < SVt_PV)
3642             sv_upgrade(dstr, SVt_PV);
3643         break;
3644     case SVt_PVIV:
3645         if (dtype < SVt_PVIV)
3646             sv_upgrade(dstr, SVt_PVIV);
3647         break;
3648     case SVt_PVNV:
3649         if (dtype < SVt_PVNV)
3650             sv_upgrade(dstr, SVt_PVNV);
3651         break;
3652     case SVt_PVAV:
3653     case SVt_PVHV:
3654     case SVt_PVCV:
3655     case SVt_PVIO:
3656         if (PL_op)
3657             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3658                 OP_NAME(PL_op));
3659         else
3660             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3661         break;
3662
3663     case SVt_PVGV:
3664         if (dtype <= SVt_PVGV) {
3665   glob_assign:
3666             if (dtype != SVt_PVGV) {
3667                 char *name = GvNAME(sstr);
3668                 STRLEN len = GvNAMELEN(sstr);
3669                 sv_upgrade(dstr, SVt_PVGV);
3670                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3671                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3672                 GvNAME(dstr) = savepvn(name, len);
3673                 GvNAMELEN(dstr) = len;
3674                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3675             }
3676             /* ahem, death to those who redefine active sort subs */
3677             else if (PL_curstackinfo->si_type == PERLSI_SORT
3678                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3679                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3680                       GvNAME(dstr));
3681
3682 #ifdef GV_UNIQUE_CHECK
3683                 if (GvUNIQUE((GV*)dstr)) {
3684                     Perl_croak(aTHX_ PL_no_modify);
3685                 }
3686 #endif
3687
3688             (void)SvOK_off(dstr);
3689             GvINTRO_off(dstr);          /* one-shot flag */
3690             gp_free((GV*)dstr);
3691             GvGP(dstr) = gp_ref(GvGP(sstr));
3692             if (SvTAINTED(sstr))
3693                 SvTAINT(dstr);
3694             if (GvIMPORTED(dstr) != GVf_IMPORTED
3695                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3696             {
3697                 GvIMPORTED_on(dstr);
3698             }
3699             GvMULTI_on(dstr);
3700             return;
3701         }
3702         /* FALL THROUGH */
3703
3704     default:
3705         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3706             mg_get(sstr);
3707             if ((int)SvTYPE(sstr) != stype) {
3708                 stype = SvTYPE(sstr);
3709                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3710                     goto glob_assign;
3711             }
3712         }
3713         if (stype == SVt_PVLV)
3714             (void)SvUPGRADE(dstr, SVt_PVNV);
3715         else
3716             (void)SvUPGRADE(dstr, (U32)stype);
3717     }
3718
3719     sflags = SvFLAGS(sstr);
3720
3721     if (sflags & SVf_ROK) {
3722         if (dtype >= SVt_PV) {
3723             if (dtype == SVt_PVGV) {
3724                 SV *sref = SvREFCNT_inc(SvRV(sstr));
3725                 SV *dref = 0;
3726                 int intro = GvINTRO(dstr);
3727
3728 #ifdef GV_UNIQUE_CHECK
3729                 if (GvUNIQUE((GV*)dstr)) {
3730                     Perl_croak(aTHX_ PL_no_modify);
3731                 }
3732 #endif
3733
3734                 if (intro) {
3735                     GvINTRO_off(dstr);  /* one-shot flag */
3736                     GvLINE(dstr) = CopLINE(PL_curcop);
3737                     GvEGV(dstr) = (GV*)dstr;
3738                 }
3739                 GvMULTI_on(dstr);
3740                 switch (SvTYPE(sref)) {
3741                 case SVt_PVAV:
3742                     if (intro)
3743                         SAVESPTR(GvAV(dstr));
3744                     else
3745                         dref = (SV*)GvAV(dstr);
3746                     GvAV(dstr) = (AV*)sref;
3747                     if (!GvIMPORTED_AV(dstr)
3748                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3749                     {
3750                         GvIMPORTED_AV_on(dstr);
3751                     }
3752                     break;
3753                 case SVt_PVHV:
3754                     if (intro)
3755                         SAVESPTR(GvHV(dstr));
3756                     else
3757                         dref = (SV*)GvHV(dstr);
3758                     GvHV(dstr) = (HV*)sref;
3759                     if (!GvIMPORTED_HV(dstr)
3760                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3761                     {
3762                         GvIMPORTED_HV_on(dstr);
3763                     }
3764                     break;
3765                 case SVt_PVCV:
3766                     if (intro) {
3767                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3768                             SvREFCNT_dec(GvCV(dstr));
3769                             GvCV(dstr) = Nullcv;
3770                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3771                             PL_sub_generation++;
3772                         }
3773                         SAVESPTR(GvCV(dstr));
3774                     }
3775                     else
3776                         dref = (SV*)GvCV(dstr);
3777                     if (GvCV(dstr) != (CV*)sref) {
3778                         CV* cv = GvCV(dstr);
3779                         if (cv) {
3780                             if (!GvCVGEN((GV*)dstr) &&
3781                                 (CvROOT(cv) || CvXSUB(cv)))
3782                             {
3783                                 /* ahem, death to those who redefine
3784                                  * active sort subs */
3785                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3786                                       PL_sortcop == CvSTART(cv))
3787                                     Perl_croak(aTHX_
3788                                     "Can't redefine active sort subroutine %s",
3789                                           GvENAME((GV*)dstr));
3790                                 /* Redefining a sub - warning is mandatory if
3791                                    it was a const and its value changed. */
3792                                 if (ckWARN(WARN_REDEFINE)
3793                                     || (CvCONST(cv)
3794                                         && (!CvCONST((CV*)sref)
3795                                             || sv_cmp(cv_const_sv(cv),
3796                                                       cv_const_sv((CV*)sref)))))
3797                                 {
3798                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3799                                         CvCONST(cv)
3800                                         ? "Constant subroutine %s::%s redefined"
3801                                         : "Subroutine %s::%s redefined",
3802                                         HvNAME(GvSTASH((GV*)dstr)),
3803                                         GvENAME((GV*)dstr));
3804                                 }
3805                             }
3806                             if (!intro)
3807                                 cv_ckproto(cv, (GV*)dstr,
3808                                         SvPOK(sref) ? SvPVX(sref) : Nullch);
3809                         }
3810                         GvCV(dstr) = (CV*)sref;
3811                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3812                         GvASSUMECV_on(dstr);
3813                         PL_sub_generation++;
3814                     }
3815                     if (!GvIMPORTED_CV(dstr)
3816                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3817                     {
3818                         GvIMPORTED_CV_on(dstr);
3819                     }
3820                     break;
3821                 case SVt_PVIO:
3822                     if (intro)
3823                         SAVESPTR(GvIOp(dstr));
3824                     else
3825                         dref = (SV*)GvIOp(dstr);
3826                     GvIOp(dstr) = (IO*)sref;
3827                     break;
3828                 case SVt_PVFM:
3829                     if (intro)
3830                         SAVESPTR(GvFORM(dstr));
3831                     else
3832                         dref = (SV*)GvFORM(dstr);
3833                     GvFORM(dstr) = (CV*)sref;
3834                     break;
3835                 default:
3836                     if (intro)
3837                         SAVESPTR(GvSV(dstr));
3838                     else
3839                         dref = (SV*)GvSV(dstr);
3840                     GvSV(dstr) = sref;
3841                     if (!GvIMPORTED_SV(dstr)
3842                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3843                     {
3844                         GvIMPORTED_SV_on(dstr);
3845                     }
3846                     break;
3847                 }
3848                 if (dref)
3849                     SvREFCNT_dec(dref);
3850                 if (intro)
3851                     SAVEFREESV(sref);
3852                 if (SvTAINTED(sstr))
3853                     SvTAINT(dstr);
3854                 return;
3855             }
3856             if (SvPVX(dstr)) {
3857                 (void)SvOOK_off(dstr);          /* backoff */
3858                 if (SvLEN(dstr))
3859                     Safefree(SvPVX(dstr));
3860                 SvLEN(dstr)=SvCUR(dstr)=0;
3861             }
3862         }
3863         (void)SvOK_off(dstr);
3864         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3865         SvROK_on(dstr);
3866         if (sflags & SVp_NOK) {
3867             SvNOKp_on(dstr);
3868             /* Only set the public OK flag if the source has public OK.  */
3869             if (sflags & SVf_NOK)
3870                 SvFLAGS(dstr) |= SVf_NOK;
3871             SvNVX(dstr) = SvNVX(sstr);
3872         }
3873         if (sflags & SVp_IOK) {
3874             (void)SvIOKp_on(dstr);
3875             if (sflags & SVf_IOK)
3876                 SvFLAGS(dstr) |= SVf_IOK;
3877             if (sflags & SVf_IVisUV)
3878                 SvIsUV_on(dstr);
3879             SvIVX(dstr) = SvIVX(sstr);
3880         }
3881         if (SvAMAGIC(sstr)) {
3882             SvAMAGIC_on(dstr);
3883         }
3884     }
3885     else if (sflags & SVp_POK) {
3886         bool isSwipe = 0;
3887
3888         /*
3889          * Check to see if we can just swipe the string.  If so, it's a
3890          * possible small lose on short strings, but a big win on long ones.
3891          * It might even be a win on short strings if SvPVX(dstr)
3892          * has to be allocated and SvPVX(sstr) has to be freed.
3893          */
3894
3895         if (
3896 #ifdef PERL_COPY_ON_WRITE
3897             (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3898             &&
3899 #endif
3900             !(isSwipe =
3901                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
3902                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
3903                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
3904                  SvLEN(sstr)    &&        /* and really is a string */
3905                                 /* and won't be needed again, potentially */
3906               !(PL_op && PL_op->op_type == OP_AASSIGN))
3907 #ifdef PERL_COPY_ON_WRITE
3908             && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3909                  && SvTYPE(sstr) >= SVt_PVIV)
3910 #endif
3911             ) {
3912             /* Failed the swipe test, and it's not a shared hash key either.
3913                Have to copy the string.  */
3914             STRLEN len = SvCUR(sstr);
3915             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3916             Move(SvPVX(sstr),SvPVX(dstr),len,char);
3917             SvCUR_set(dstr, len);
3918             *SvEND(dstr) = '\0';
3919             (void)SvPOK_only(dstr);
3920         } else {
3921             /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
3922                be true in here.  */
3923 #ifdef PERL_COPY_ON_WRITE
3924             /* Either it's a shared hash key, or it's suitable for
3925                copy-on-write or we can swipe the string.  */
3926             if (DEBUG_C_TEST) {
3927                 PerlIO_printf(Perl_debug_log,
3928                               "Copy on write: sstr --> dstr\n");
3929                 sv_dump(sstr);
3930                 sv_dump(dstr);
3931             }
3932             if (!isSwipe) {
3933                 /* I believe I should acquire a global SV mutex if
3934                    it's a COW sv (not a shared hash key) to stop
3935                    it going un copy-on-write.
3936                    If the source SV has gone un copy on write between up there
3937                    and down here, then (assert() that) it is of the correct
3938                    form to make it copy on write again */
3939                 if ((sflags & (SVf_FAKE | SVf_READONLY))
3940                     != (SVf_FAKE | SVf_READONLY)) {
3941                     SvREADONLY_on(sstr);
3942                     SvFAKE_on(sstr);
3943                     /* Make the source SV into a loop of 1.
3944                        (about to become 2) */
3945                     SV_COW_NEXT_SV_SET(sstr, sstr);
3946                 }
3947             }
3948 #endif
3949             /* Initial code is common.  */
3950             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
3951                 if (SvOOK(dstr)) {
3952                     SvFLAGS(dstr) &= ~SVf_OOK;
3953                     Safefree(SvPVX(dstr) - SvIVX(dstr));
3954                 }
3955                 else if (SvLEN(dstr))
3956                     Safefree(SvPVX(dstr));
3957             }
3958             (void)SvPOK_only(dstr);
3959
3960 #ifdef PERL_COPY_ON_WRITE
3961             if (!isSwipe) {
3962                 /* making another shared SV.  */
3963                 STRLEN cur = SvCUR(sstr);
3964                 STRLEN len = SvLEN(sstr);
3965                 if (len) {
3966                     /* SvIsCOW_normal */
3967                     /* splice us in between source and next-after-source.  */
3968                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3969                     SV_COW_NEXT_SV_SET(sstr, dstr);
3970                     SvPV_set(dstr, SvPVX(sstr));
3971                 } else {
3972                     /* SvIsCOW_shared_hash */
3973                     UV hash = SvUVX(sstr);
3974                     DEBUG_C(PerlIO_printf(Perl_debug_log,
3975                                           "Copy on write: Sharing hash\n"));
3976                     SvPV_set(dstr,
3977                              sharepvn(SvPVX(sstr),
3978                                       (sflags & SVf_UTF8?-cur:cur), hash));
3979                     SvUVX(dstr) = hash;
3980                 }
3981                 SvLEN(dstr) = len;
3982                 SvCUR(dstr) = cur;
3983                 SvREADONLY_on(dstr);
3984                 SvFAKE_on(dstr);
3985                 /* Relesase a global SV mutex.  */
3986             }
3987             else
3988 #endif
3989                 {       /* Passes the swipe test.  */
3990                 SvPV_set(dstr, SvPVX(sstr));
3991                 SvLEN_set(dstr, SvLEN(sstr));
3992                 SvCUR_set(dstr, SvCUR(sstr));
3993
3994                 SvTEMP_off(dstr);
3995                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
3996                 SvPV_set(sstr, Nullch);
3997                 SvLEN_set(sstr, 0);
3998                 SvCUR_set(sstr, 0);
3999                 SvTEMP_off(sstr);
4000             }
4001         }
4002         if (sflags & SVf_UTF8)
4003             SvUTF8_on(dstr);
4004         /*SUPPRESS 560*/
4005         if (sflags & SVp_NOK) {
4006             SvNOKp_on(dstr);
4007             if (sflags & SVf_NOK)
4008                 SvFLAGS(dstr) |= SVf_NOK;
4009             SvNVX(dstr) = SvNVX(sstr);
4010         }
4011         if (sflags & SVp_IOK) {
4012             (void)SvIOKp_on(dstr);
4013             if (sflags & SVf_IOK)
4014                 SvFLAGS(dstr) |= SVf_IOK;
4015             if (sflags & SVf_IVisUV)
4016                 SvIsUV_on(dstr);
4017             SvIVX(dstr) = SvIVX(sstr);
4018         }
4019         if (SvVOK(sstr)) {
4020             MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4021             sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4022                         smg->mg_ptr, smg->mg_len);
4023             SvRMAGICAL_on(dstr);
4024         }
4025     }
4026     else if (sflags & SVp_IOK) {
4027         if (sflags & SVf_IOK)
4028             (void)SvIOK_only(dstr);
4029         else {
4030             (void)SvOK_off(dstr);
4031             (void)SvIOKp_on(dstr);
4032         }
4033         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4034         if (sflags & SVf_IVisUV)
4035             SvIsUV_on(dstr);
4036         SvIVX(dstr) = SvIVX(sstr);
4037         if (sflags & SVp_NOK) {
4038             if (sflags & SVf_NOK)
4039                 (void)SvNOK_on(dstr);
4040             else
4041                 (void)SvNOKp_on(dstr);
4042             SvNVX(dstr) = SvNVX(sstr);
4043         }
4044     }
4045     else if (sflags & SVp_NOK) {
4046         if (sflags & SVf_NOK)
4047             (void)SvNOK_only(dstr);
4048         else {
4049             (void)SvOK_off(dstr);
4050             SvNOKp_on(dstr);
4051         }
4052         SvNVX(dstr) = SvNVX(sstr);
4053     }
4054     else {
4055         if (dtype == SVt_PVGV) {
4056             if (ckWARN(WARN_MISC))
4057                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4058         }
4059         else
4060             (void)SvOK_off(dstr);
4061     }
4062     if (SvTAINTED(sstr))
4063         SvTAINT(dstr);
4064 }
4065
4066 /*
4067 =for apidoc sv_setsv_mg
4068
4069 Like C<sv_setsv>, but also handles 'set' magic.
4070
4071 =cut
4072 */
4073
4074 void
4075 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4076 {
4077     sv_setsv(dstr,sstr);
4078     SvSETMAGIC(dstr);
4079 }
4080
4081 /*
4082 =for apidoc sv_setpvn
4083
4084 Copies a string into an SV.  The C<len> parameter indicates the number of
4085 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4086
4087 =cut
4088 */
4089
4090 void
4091 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4092 {
4093     register char *dptr;
4094
4095     SV_CHECK_THINKFIRST_COW_DROP(sv);
4096     if (!ptr) {
4097         (void)SvOK_off(sv);
4098         return;
4099     }
4100     else {
4101         /* len is STRLEN which is unsigned, need to copy to signed */
4102         IV iv = len;
4103         if (iv < 0)
4104             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4105     }
4106     (void)SvUPGRADE(sv, SVt_PV);
4107
4108     SvGROW(sv, len + 1);
4109     dptr = SvPVX(sv);
4110     Move(ptr,dptr,len,char);
4111     dptr[len] = '\0';
4112     SvCUR_set(sv, len);
4113     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4114     SvTAINT(sv);
4115 }
4116
4117 /*
4118 =for apidoc sv_setpvn_mg
4119
4120 Like C<sv_setpvn>, but also handles 'set' magic.
4121
4122 =cut
4123 */
4124
4125 void
4126 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4127 {
4128     sv_setpvn(sv,ptr,len);
4129     SvSETMAGIC(sv);
4130 }
4131
4132 /*
4133 =for apidoc sv_setpv
4134
4135 Copies a string into an SV.  The string must be null-terminated.  Does not
4136 handle 'set' magic.  See C<sv_setpv_mg>.
4137
4138 =cut
4139 */
4140
4141 void
4142 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4143 {
4144     register STRLEN len;
4145
4146     SV_CHECK_THINKFIRST_COW_DROP(sv);
4147     if (!ptr) {
4148         (void)SvOK_off(sv);
4149         return;
4150     }
4151     len = strlen(ptr);
4152     (void)SvUPGRADE(sv, SVt_PV);
4153
4154     SvGROW(sv, len + 1);
4155     Move(ptr,SvPVX(sv),len+1,char);
4156     SvCUR_set(sv, len);
4157     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4158     SvTAINT(sv);
4159 }
4160
4161 /*
4162 =for apidoc sv_setpv_mg
4163
4164 Like C<sv_setpv>, but also handles 'set' magic.
4165
4166 =cut
4167 */
4168
4169 void
4170 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4171 {
4172     sv_setpv(sv,ptr);
4173     SvSETMAGIC(sv);
4174 }
4175
4176 /*
4177 =for apidoc sv_usepvn
4178
4179 Tells an SV to use C<ptr> to find its string value.  Normally the string is
4180 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4181 The C<ptr> should point to memory that was allocated by C<malloc>.  The
4182 string length, C<len>, must be supplied.  This function will realloc the
4183 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4184 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
4185 See C<sv_usepvn_mg>.
4186
4187 =cut
4188 */
4189
4190 void
4191 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4192 {
4193     SV_CHECK_THINKFIRST_COW_DROP(sv);
4194     (void)SvUPGRADE(sv, SVt_PV);
4195     if (!ptr) {
4196         (void)SvOK_off(sv);
4197         return;
4198     }
4199     (void)SvOOK_off(sv);
4200     if (SvPVX(sv) && SvLEN(sv))
4201         Safefree(SvPVX(sv));
4202     Renew(ptr, len+1, char);
4203     SvPVX(sv) = ptr;
4204     SvCUR_set(sv, len);
4205     SvLEN_set(sv, len+1);
4206     *SvEND(sv) = '\0';
4207     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4208     SvTAINT(sv);
4209 }
4210
4211 /*
4212 =for apidoc sv_usepvn_mg
4213
4214 Like C<sv_usepvn>, but also handles 'set' magic.
4215
4216 =cut
4217 */
4218
4219 void
4220 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4221 {
4222     sv_usepvn(sv,ptr,len);
4223     SvSETMAGIC(sv);
4224 }
4225
4226 #ifdef PERL_COPY_ON_WRITE
4227 /* Need to do this *after* making the SV normal, as we need the buffer
4228    pointer to remain valid until after we've copied it.  If we let go too early,
4229    another thread could invalidate it by unsharing last of the same hash key
4230    (which it can do by means other than releasing copy-on-write Svs)
4231    or by changing the other copy-on-write SVs in the loop.  */
4232 STATIC void
4233 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4234                  U32 hash, SV *after)
4235 {
4236     if (len) { /* this SV was SvIsCOW_normal(sv) */
4237          /* we need to find the SV pointing to us.  */
4238         SV *current = SV_COW_NEXT_SV(after);
4239
4240         if (current == sv) {
4241             /* The SV we point to points back to us (there were only two of us
4242                in the loop.)
4243                Hence other SV is no longer copy on write either.  */
4244             SvFAKE_off(after);
4245             SvREADONLY_off(after);
4246         } else {
4247             /* We need to follow the pointers around the loop.  */
4248             SV *next;
4249             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4250                 assert (next);
4251                 current = next;
4252                  /* don't loop forever if the structure is bust, and we have
4253                     a pointer into a closed loop.  */
4254                 assert (current != after);
4255                 assert (SvPVX(current) == pvx);
4256             }
4257             /* Make the SV before us point to the SV after us.  */
4258             SV_COW_NEXT_SV_SET(current, after);
4259         }
4260     } else {
4261         unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4262     }
4263 }
4264
4265 int
4266 Perl_sv_release_IVX(pTHX_ register SV *sv)
4267 {
4268     if (SvIsCOW(sv))
4269         sv_force_normal_flags(sv, 0);
4270     return SvOOK_off(sv);
4271 }
4272 #endif
4273 /*
4274 =for apidoc sv_force_normal_flags
4275
4276 Undo various types of fakery on an SV: if the PV is a shared string, make
4277 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4278 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4279 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4280 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4281 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4282 set to some other value. In addtion, the C<flags> parameter gets passed to
4283 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4284 with flags set to 0.
4285
4286 =cut
4287 */
4288
4289 void
4290 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4291 {
4292 #ifdef PERL_COPY_ON_WRITE
4293     if (SvREADONLY(sv)) {
4294         /* At this point I believe I should acquire a global SV mutex.  */
4295         if (SvFAKE(sv)) {
4296             char *pvx = SvPVX(sv);
4297             STRLEN len = SvLEN(sv);
4298             STRLEN cur = SvCUR(sv);
4299             U32 hash = SvUVX(sv);
4300             SV *next = SV_COW_NEXT_SV(sv);   /* next COW sv in the loop. */
4301             if (DEBUG_C_TEST) {
4302                 PerlIO_printf(Perl_debug_log,
4303                               "Copy on write: Force normal %ld\n",
4304                               (long) flags);
4305                 sv_dump(sv);
4306             }
4307             SvFAKE_off(sv);
4308             SvREADONLY_off(sv);
4309             /* This SV doesn't own the buffer, so need to New() a new one:  */
4310             SvPVX(sv) = 0;
4311             SvLEN(sv) = 0;
4312             if (flags & SV_COW_DROP_PV) {
4313                 /* OK, so we don't need to copy our buffer.  */
4314                 SvPOK_off(sv);
4315             } else {
4316                 SvGROW(sv, cur + 1);
4317                 Move(pvx,SvPVX(sv),cur,char);
4318                 SvCUR(sv) = cur;
4319                 *SvEND(sv) = '\0';
4320             }
4321             sv_release_COW(sv, pvx, cur, len, hash, next);
4322             if (DEBUG_C_TEST) {
4323                 sv_dump(sv);
4324             }
4325         }
4326         else if (PL_curcop != &PL_compiling)
4327             Perl_croak(aTHX_ PL_no_modify);
4328         /* At this point I believe that I can drop the global SV mutex.  */
4329     }
4330 #else
4331     if (SvREADONLY(sv)) {
4332         if (SvFAKE(sv)) {
4333             char *pvx = SvPVX(sv);
4334             STRLEN len = SvCUR(sv);
4335             U32 hash   = SvUVX(sv);
4336             SvGROW(sv, len + 1);
4337             Move(pvx,SvPVX(sv),len,char);
4338             *SvEND(sv) = '\0';
4339             SvFAKE_off(sv);
4340             SvREADONLY_off(sv);
4341             unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4342         }
4343         else if (PL_curcop != &PL_compiling)
4344             Perl_croak(aTHX_ PL_no_modify);
4345     }
4346 #endif
4347     if (SvROK(sv))
4348         sv_unref_flags(sv, flags);
4349     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4350         sv_unglob(sv);
4351 }
4352
4353 /*
4354 =for apidoc sv_force_normal
4355
4356 Undo various types of fakery on an SV: if the PV is a shared string, make
4357 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4358 an xpvmg. See also C<sv_force_normal_flags>.
4359
4360 =cut
4361 */
4362
4363 void
4364 Perl_sv_force_normal(pTHX_ register SV *sv)
4365 {
4366     sv_force_normal_flags(sv, 0);
4367 }
4368
4369 /*
4370 =for apidoc sv_chop
4371
4372 Efficient removal of characters from the beginning of the string buffer.
4373 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4374 the string buffer.  The C<ptr> becomes the first character of the adjusted
4375 string. Uses the "OOK hack".
4376
4377 =cut
4378 */
4379
4380 void
4381 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4382 {
4383     register STRLEN delta;
4384
4385     if (!ptr || !SvPOKp(sv))
4386         return;
4387     SV_CHECK_THINKFIRST(sv);
4388     if (SvTYPE(sv) < SVt_PVIV)
4389         sv_upgrade(sv,SVt_PVIV);
4390
4391     if (!SvOOK(sv)) {
4392         if (!SvLEN(sv)) { /* make copy of shared string */
4393             char *pvx = SvPVX(sv);
4394             STRLEN len = SvCUR(sv);
4395             SvGROW(sv, len + 1);
4396             Move(pvx,SvPVX(sv),len,char);
4397             *SvEND(sv) = '\0';
4398         }
4399         SvIVX(sv) = 0;
4400         SvFLAGS(sv) |= SVf_OOK;
4401     }
4402     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4403     delta = ptr - SvPVX(sv);
4404     SvLEN(sv) -= delta;
4405     SvCUR(sv) -= delta;
4406     SvPVX(sv) += delta;
4407     SvIVX(sv) += delta;
4408 }
4409
4410 /*
4411 =for apidoc sv_catpvn
4412
4413 Concatenates the string onto the end of the string which is in the SV.  The
4414 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4415 status set, then the bytes appended should be valid UTF8.
4416 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4417
4418 =for apidoc sv_catpvn_flags
4419
4420 Concatenates the string onto the end of the string which is in the SV.  The
4421 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4422 status set, then the bytes appended should be valid UTF8.
4423 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4424 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4425 in terms of this function.
4426
4427 =cut
4428 */
4429
4430 void
4431 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4432 {
4433     STRLEN dlen;
4434     char *dstr;
4435
4436     dstr = SvPV_force_flags(dsv, dlen, flags);
4437     SvGROW(dsv, dlen + slen + 1);
4438     if (sstr == dstr)
4439         sstr = SvPVX(dsv);
4440     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4441     SvCUR(dsv) += slen;
4442     *SvEND(dsv) = '\0';
4443     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4444     SvTAINT(dsv);
4445 }
4446
4447 /*
4448 =for apidoc sv_catpvn_mg
4449
4450 Like C<sv_catpvn>, but also handles 'set' magic.
4451
4452 =cut
4453 */
4454
4455 void
4456 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4457 {
4458     sv_catpvn(sv,ptr,len);
4459     SvSETMAGIC(sv);
4460 }
4461
4462 /*
4463 =for apidoc sv_catsv
4464
4465 Concatenates the string from SV C<ssv> onto the end of the string in
4466 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4467 not 'set' magic.  See C<sv_catsv_mg>.
4468
4469 =for apidoc sv_catsv_flags
4470
4471 Concatenates the string from SV C<ssv> onto the end of the string in
4472 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4473 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4474 and C<sv_catsv_nomg> are implemented in terms of this function.
4475
4476 =cut */
4477
4478 void
4479 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4480 {
4481     char *spv;
4482     STRLEN slen;
4483     if (!ssv)
4484         return;
4485     if ((spv = SvPV(ssv, slen))) {
4486         /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4487             gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4488             Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4489             get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4490             dsv->sv_flags doesn't have that bit set.
4491                 Andy Dougherty  12 Oct 2001
4492         */
4493         I32 sutf8 = DO_UTF8(ssv);
4494         I32 dutf8;
4495
4496         if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4497             mg_get(dsv);
4498         dutf8 = DO_UTF8(dsv);
4499
4500         if (dutf8 != sutf8) {
4501             if (dutf8) {
4502                 /* Not modifying source SV, so taking a temporary copy. */
4503                 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4504
4505                 sv_utf8_upgrade(csv);
4506                 spv = SvPV(csv, slen);
4507             }
4508             else
4509                 sv_utf8_upgrade_nomg(dsv);
4510         }
4511         sv_catpvn_nomg(dsv, spv, slen);
4512     }
4513 }
4514
4515 /*
4516 =for apidoc sv_catsv_mg
4517
4518 Like C<sv_catsv>, but also handles 'set' magic.
4519
4520 =cut
4521 */
4522
4523 void
4524 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4525 {
4526     sv_catsv(dsv,ssv);
4527     SvSETMAGIC(dsv);
4528 }
4529
4530 /*
4531 =for apidoc sv_catpv
4532
4533 Concatenates the string onto the end of the string which is in the SV.
4534 If the SV has the UTF8 status set, then the bytes appended should be
4535 valid UTF8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4536
4537 =cut */
4538
4539 void
4540 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4541 {
4542     register STRLEN len;
4543     STRLEN tlen;
4544     char *junk;
4545
4546     if (!ptr)
4547         return;
4548     junk = SvPV_force(sv, tlen);
4549     len = strlen(ptr);
4550     SvGROW(sv, tlen + len + 1);
4551     if (ptr == junk)
4552         ptr = SvPVX(sv);
4553     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4554     SvCUR(sv) += len;
4555     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4556     SvTAINT(sv);
4557 }
4558
4559 /*
4560 =for apidoc sv_catpv_mg
4561
4562 Like C<sv_catpv>, but also handles 'set' magic.
4563
4564 =cut
4565 */
4566
4567 void
4568 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4569 {
4570     sv_catpv(sv,ptr);
4571     SvSETMAGIC(sv);
4572 }
4573
4574 /*
4575 =for apidoc newSV
4576
4577 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4578 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4579 macro.
4580
4581 =cut
4582 */
4583
4584 SV *
4585 Perl_newSV(pTHX_ STRLEN len)
4586 {
4587     register SV *sv;
4588
4589     new_SV(sv);
4590     if (len) {
4591         sv_upgrade(sv, SVt_PV);
4592         SvGROW(sv, len + 1);
4593     }
4594     return sv;
4595 }
4596 /*
4597 =for apidoc sv_magicext
4598
4599 Adds magic to an SV, upgrading it if necessary. Applies the
4600 supplied vtable and returns pointer to the magic added.
4601
4602 Note that sv_magicext will allow things that sv_magic will not.
4603 In particular you can add magic to SvREADONLY SVs and and more than
4604 one instance of the same 'how'
4605
4606 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
4607 if C<namelen> is zero then C<name> is stored as-is and - as another special
4608 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
4609 an C<SV*> and has its REFCNT incremented
4610
4611 (This is now used as a subroutine by sv_magic.)
4612
4613 =cut
4614 */
4615 MAGIC *
4616 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4617                  const char* name, I32 namlen)
4618 {
4619     MAGIC* mg;
4620
4621     if (SvTYPE(sv) < SVt_PVMG) {
4622         (void)SvUPGRADE(sv, SVt_PVMG);
4623     }
4624     Newz(702,mg, 1, MAGIC);
4625     mg->mg_moremagic = SvMAGIC(sv);
4626     SvMAGIC(sv) = mg;
4627
4628     /* Some magic sontains a reference loop, where the sv and object refer to
4629        each other.  To prevent a reference loop that would prevent such
4630        objects being freed, we look for such loops and if we find one we
4631        avoid incrementing the object refcount.
4632
4633        Note we cannot do this to avoid self-tie loops as intervening RV must
4634        have its REFCNT incremented to keep it in existence - instead we could
4635        special case them in sv_free() -- NI-S
4636
4637     */
4638     if (!obj || obj == sv ||
4639         how == PERL_MAGIC_arylen ||
4640         how == PERL_MAGIC_qr ||
4641         (SvTYPE(obj) == SVt_PVGV &&
4642             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4643             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4644             GvFORM(obj) == (CV*)sv)))
4645     {
4646         mg->mg_obj = obj;
4647     }
4648     else {
4649         mg->mg_obj = SvREFCNT_inc(obj);
4650         mg->mg_flags |= MGf_REFCOUNTED;
4651     }
4652     mg->mg_type = how;
4653     mg->mg_len = namlen;
4654     if (name) {
4655         if (namlen > 0)
4656             mg->mg_ptr = savepvn(name, namlen);
4657         else if (namlen == HEf_SVKEY)
4658             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4659         else
4660             mg->mg_ptr = (char *) name;
4661     }
4662     mg->mg_virtual = vtable;
4663
4664     mg_magical(sv);
4665     if (SvGMAGICAL(sv))
4666         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4667     return mg;
4668 }
4669
4670 /*
4671 =for apidoc sv_magic
4672
4673 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4674 then adds a new magic item of type C<how> to the head of the magic list.
4675
4676 =cut
4677 */
4678
4679 void
4680 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4681 {
4682     MAGIC* mg;
4683     MGVTBL *vtable = 0;
4684
4685 #ifdef PERL_COPY_ON_WRITE
4686     if (SvIsCOW(sv))
4687         sv_force_normal_flags(sv, 0);
4688 #endif
4689     if (SvREADONLY(sv)) {
4690         if (PL_curcop != &PL_compiling
4691             && how != PERL_MAGIC_regex_global
4692             && how != PERL_MAGIC_bm
4693             && how != PERL_MAGIC_fm
4694             && how != PERL_MAGIC_sv
4695            )
4696         {
4697             Perl_croak(aTHX_ PL_no_modify);
4698         }
4699     }
4700     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4701         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4702             /* sv_magic() refuses to add a magic of the same 'how' as an
4703                existing one
4704              */
4705             if (how == PERL_MAGIC_taint)
4706                 mg->mg_len |= 1;
4707             return;
4708         }
4709     }
4710
4711     switch (how) {
4712     case PERL_MAGIC_sv:
4713         vtable = &PL_vtbl_sv;
4714         break;
4715     case PERL_MAGIC_overload:
4716         vtable = &PL_vtbl_amagic;
4717         break;
4718     case PERL_MAGIC_overload_elem:
4719         vtable = &PL_vtbl_amagicelem;
4720         break;
4721     case PERL_MAGIC_overload_table:
4722         vtable = &PL_vtbl_ovrld;
4723         break;
4724     case PERL_MAGIC_bm:
4725         vtable = &PL_vtbl_bm;
4726         break;
4727     case PERL_MAGIC_regdata:
4728         vtable = &PL_vtbl_regdata;
4729         break;
4730     case PERL_MAGIC_regdatum:
4731         vtable = &PL_vtbl_regdatum;
4732         break;
4733     case PERL_MAGIC_env:
4734         vtable = &PL_vtbl_env;
4735         break;
4736     case PERL_MAGIC_fm:
4737         vtable = &PL_vtbl_fm;
4738         break;
4739     case PERL_MAGIC_envelem:
4740         vtable = &PL_vtbl_envelem;
4741         break;
4742     case PERL_MAGIC_regex_global:
4743         vtable = &PL_vtbl_mglob;
4744         break;
4745     case PERL_MAGIC_isa:
4746         vtable = &PL_vtbl_isa;
4747         break;
4748     case PERL_MAGIC_isaelem:
4749         vtable = &PL_vtbl_isaelem;
4750         break;
4751     case PERL_MAGIC_nkeys:
4752         vtable = &PL_vtbl_nkeys;
4753         break;
4754     case PERL_MAGIC_dbfile:
4755         vtable = 0;
4756         break;
4757     case PERL_MAGIC_dbline:
4758         vtable = &PL_vtbl_dbline;
4759         break;
4760 #ifdef USE_5005THREADS
4761     case PERL_MAGIC_mutex:
4762         vtable = &PL_vtbl_mutex;
4763         break;
4764 #endif /* USE_5005THREADS */
4765 #ifdef USE_LOCALE_COLLATE
4766     case PERL_MAGIC_collxfrm:
4767         vtable = &PL_vtbl_collxfrm;
4768         break;
4769 #endif /* USE_LOCALE_COLLATE */
4770     case PERL_MAGIC_tied:
4771         vtable = &PL_vtbl_pack;
4772         break;
4773     case PERL_MAGIC_tiedelem:
4774     case PERL_MAGIC_tiedscalar:
4775         vtable = &PL_vtbl_packelem;
4776         break;
4777     case PERL_MAGIC_qr:
4778         vtable = &PL_vtbl_regexp;
4779         break;
4780     case PERL_MAGIC_sig:
4781         vtable = &PL_vtbl_sig;
4782         break;
4783     case PERL_MAGIC_sigelem:
4784         vtable = &PL_vtbl_sigelem;
4785         break;
4786     case PERL_MAGIC_taint:
4787         vtable = &PL_vtbl_taint;
4788         break;
4789     case PERL_MAGIC_uvar:
4790         vtable = &PL_vtbl_uvar;
4791         break;
4792     case PERL_MAGIC_vec:
4793         vtable = &PL_vtbl_vec;
4794         break;
4795     case PERL_MAGIC_vstring:
4796         vtable = 0;
4797         break;
4798     case PERL_MAGIC_substr:
4799         vtable = &PL_vtbl_substr;
4800         break;
4801     case PERL_MAGIC_defelem:
4802         vtable = &PL_vtbl_defelem;
4803         break;
4804     case PERL_MAGIC_glob:
4805         vtable = &PL_vtbl_glob;
4806         break;
4807     case PERL_MAGIC_arylen:
4808         vtable = &PL_vtbl_arylen;
4809         break;
4810     case PERL_MAGIC_pos:
4811         vtable = &PL_vtbl_pos;
4812         break;
4813     case PERL_MAGIC_backref:
4814         vtable = &PL_vtbl_backref;
4815         break;
4816     case PERL_MAGIC_ext:
4817         /* Reserved for use by extensions not perl internals.           */
4818         /* Useful for attaching extension internal data to perl vars.   */
4819         /* Note that multiple extensions may clash if magical scalars   */
4820         /* etc holding private data from one are passed to another.     */
4821         break;
4822     default:
4823         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4824     }
4825
4826     /* Rest of work is done else where */
4827     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4828
4829     switch (how) {
4830     case PERL_MAGIC_taint:
4831         mg->mg_len = 1;
4832         break;
4833     case PERL_MAGIC_ext:
4834     case PERL_MAGIC_dbfile:
4835         SvRMAGICAL_on(sv);
4836         break;
4837     }
4838 }
4839
4840 /*
4841 =for apidoc sv_unmagic
4842
4843 Removes all magic of type C<type> from an SV.
4844
4845 =cut
4846 */
4847
4848 int
4849 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4850 {
4851     MAGIC* mg;
4852     MAGIC** mgp;
4853     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4854         return 0;
4855     mgp = &SvMAGIC(sv);
4856     for (mg = *mgp; mg; mg = *mgp) {
4857         if (mg->mg_type == type) {
4858             MGVTBL* vtbl = mg->mg_virtual;
4859             *mgp = mg->mg_moremagic;
4860             if (vtbl && vtbl->svt_free)
4861                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4862             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4863                 if (mg->mg_len > 0)
4864                     Safefree(mg->mg_ptr);
4865                 else if (mg->mg_len == HEf_SVKEY)
4866                     SvREFCNT_dec((SV*)mg->mg_ptr);
4867             }
4868             if (mg->mg_flags & MGf_REFCOUNTED)
4869                 SvREFCNT_dec(mg->mg_obj);
4870             Safefree(mg);
4871         }
4872         else
4873             mgp = &mg->mg_moremagic;
4874     }
4875     if (!SvMAGIC(sv)) {
4876         SvMAGICAL_off(sv);
4877        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4878     }
4879
4880     return 0;
4881 }
4882
4883 /*
4884 =for apidoc sv_rvweaken
4885
4886 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4887 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4888 push a back-reference to this RV onto the array of backreferences
4889 associated with that magic.
4890
4891 =cut
4892 */
4893
4894 SV *
4895 Perl_sv_rvweaken(pTHX_ SV *sv)
4896 {
4897     SV *tsv;
4898     if (!SvOK(sv))  /* let undefs pass */
4899         return sv;
4900     if (!SvROK(sv))
4901         Perl_croak(aTHX_ "Can't weaken a nonreference");
4902     else if (SvWEAKREF(sv)) {
4903         if (ckWARN(WARN_MISC))
4904             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4905         return sv;
4906     }
4907     tsv = SvRV(sv);
4908     sv_add_backref(tsv, sv);
4909     SvWEAKREF_on(sv);
4910     SvREFCNT_dec(tsv);
4911     return sv;
4912 }
4913
4914 /* Give tsv backref magic if it hasn't already got it, then push a
4915  * back-reference to sv onto the array associated with the backref magic.
4916  */
4917
4918 STATIC void
4919 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4920 {
4921     AV *av;
4922     MAGIC *mg;
4923     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4924         av = (AV*)mg->mg_obj;
4925     else {
4926         av = newAV();
4927         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4928         SvREFCNT_dec(av);           /* for sv_magic */
4929     }
4930     av_push(av,sv);
4931 }
4932
4933 /* delete a back-reference to ourselves from the backref magic associated
4934  * with the SV we point to.
4935  */
4936
4937 STATIC void
4938 S_sv_del_backref(pTHX_ SV *sv)
4939 {
4940     AV *av;
4941     SV **svp;
4942     I32 i;
4943     SV *tsv = SvRV(sv);
4944     MAGIC *mg = NULL;
4945     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4946         Perl_croak(aTHX_ "panic: del_backref");
4947     av = (AV *)mg->mg_obj;
4948     svp = AvARRAY(av);
4949     i = AvFILLp(av);
4950     while (i >= 0) {
4951         if (svp[i] == sv) {
4952             svp[i] = &PL_sv_undef; /* XXX */
4953         }
4954         i--;
4955     }
4956 }
4957
4958 /*
4959 =for apidoc sv_insert
4960
4961 Inserts a string at the specified offset/length within the SV. Similar to
4962 the Perl substr() function.
4963
4964 =cut
4965 */
4966
4967 void
4968 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4969 {
4970     register char *big;
4971     register char *mid;
4972     register char *midend;
4973     register char *bigend;
4974     register I32 i;
4975     STRLEN curlen;
4976
4977
4978     if (!bigstr)
4979         Perl_croak(aTHX_ "Can't modify non-existent substring");
4980     SvPV_force(bigstr, curlen);
4981     (void)SvPOK_only_UTF8(bigstr);
4982     if (offset + len > curlen) {
4983         SvGROW(bigstr, offset+len+1);
4984         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4985         SvCUR_set(bigstr, offset+len);
4986     }
4987
4988     SvTAINT(bigstr);
4989     i = littlelen - len;
4990     if (i > 0) {                        /* string might grow */
4991         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4992         mid = big + offset + len;
4993         midend = bigend = big + SvCUR(bigstr);
4994         bigend += i;
4995         *bigend = '\0';
4996         while (midend > mid)            /* shove everything down */
4997             *--bigend = *--midend;
4998         Move(little,big+offset,littlelen,char);
4999         SvCUR(bigstr) += i;
5000         SvSETMAGIC(bigstr);
5001         return;
5002     }
5003     else if (i == 0) {
5004         Move(little,SvPVX(bigstr)+offset,len,char);
5005         SvSETMAGIC(bigstr);
5006         return;
5007     }
5008
5009     big = SvPVX(bigstr);
5010     mid = big + offset;
5011     midend = mid + len;
5012     bigend = big + SvCUR(bigstr);
5013
5014     if (midend > bigend)
5015         Perl_croak(aTHX_ "panic: sv_insert");
5016
5017     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5018         if (littlelen) {
5019             Move(little, mid, littlelen,char);
5020             mid += littlelen;
5021         }
5022         i = bigend - midend;
5023         if (i > 0) {
5024             Move(midend, mid, i,char);
5025             mid += i;
5026         }
5027         *mid = '\0';
5028         SvCUR_set(bigstr, mid - big);
5029     }
5030     /*SUPPRESS 560*/
5031     else if ((i = mid - big)) { /* faster from front */
5032         midend -= littlelen;
5033         mid = midend;
5034         sv_chop(bigstr,midend-i);
5035         big += i;
5036         while (i--)
5037             *--midend = *--big;
5038         if (littlelen)
5039             Move(little, mid, littlelen,char);
5040     }
5041     else if (littlelen) {
5042         midend -= littlelen;
5043         sv_chop(bigstr,midend);
5044         Move(little,midend,littlelen,char);
5045     }
5046     else {
5047         sv_chop(bigstr,midend);
5048     }
5049     SvSETMAGIC(bigstr);
5050 }
5051
5052 /*
5053 =for apidoc sv_replace
5054
5055 Make the first argument a copy of the second, then delete the original.
5056 The target SV physically takes over ownership of the body of the source SV
5057 and inherits its flags; however, the target keeps any magic it owns,
5058 and any magic in the source is discarded.
5059 Note that this is a rather specialist SV copying operation; most of the
5060 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5061
5062 =cut
5063 */
5064
5065 void
5066 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5067 {
5068     U32 refcnt = SvREFCNT(sv);
5069     SV_CHECK_THINKFIRST_COW_DROP(sv);
5070     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5071         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5072     if (SvMAGICAL(sv)) {
5073         if (SvMAGICAL(nsv))
5074             mg_free(nsv);
5075         else
5076             sv_upgrade(nsv, SVt_PVMG);
5077         SvMAGIC(nsv) = SvMAGIC(sv);
5078         SvFLAGS(nsv) |= SvMAGICAL(sv);
5079         SvMAGICAL_off(sv);
5080         SvMAGIC(sv) = 0;
5081     }
5082     SvREFCNT(sv) = 0;
5083     sv_clear(sv);
5084     assert(!SvREFCNT(sv));
5085     StructCopy(nsv,sv,SV);
5086 #ifdef PERL_COPY_ON_WRITE
5087     if (SvIsCOW_normal(nsv)) {
5088         /* We need to follow the pointers around the loop to make the
5089            previous SV point to sv, rather than nsv.  */
5090         SV *next;
5091         SV *current = nsv;
5092         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5093             assert(next);
5094             current = next;
5095             assert(SvPVX(current) == SvPVX(nsv));
5096         }
5097         /* Make the SV before us point to the SV after us.  */
5098         if (DEBUG_C_TEST) {
5099             PerlIO_printf(Perl_debug_log, "previous is\n");
5100             sv_dump(current);
5101             PerlIO_printf(Perl_debug_log,
5102                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5103                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5104         }
5105         SV_COW_NEXT_SV_SET(current, sv);
5106     }
5107 #endif
5108     SvREFCNT(sv) = refcnt;
5109     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5110     del_SV(nsv);
5111 }
5112
5113 /*
5114 =for apidoc sv_clear
5115
5116 Clear an SV: call any destructors, free up any memory used by the body,
5117 and free the body itself. The SV's head is I<not> freed, although
5118 its type is set to all 1's so that it won't inadvertently be assumed
5119 to be live during global destruction etc.
5120 This function should only be called when REFCNT is zero. Most of the time
5121 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5122 instead.
5123
5124 =cut
5125 */
5126
5127 void
5128 Perl_sv_clear(pTHX_ register SV *sv)
5129 {
5130     HV* stash;
5131     assert(sv);
5132     assert(SvREFCNT(sv) == 0);
5133
5134     if (SvOBJECT(sv)) {
5135         if (PL_defstash) {              /* Still have a symbol table? */
5136             dSP;
5137             CV* destructor;
5138             SV tmpref;
5139
5140             Zero(&tmpref, 1, SV);
5141             sv_upgrade(&tmpref, SVt_RV);
5142             SvROK_on(&tmpref);
5143             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
5144             SvREFCNT(&tmpref) = 1;
5145
5146             do {
5147                 stash = SvSTASH(sv);
5148                 destructor = StashHANDLER(stash,DESTROY);
5149                 if (destructor) {
5150                     ENTER;
5151                     PUSHSTACKi(PERLSI_DESTROY);
5152                     SvRV(&tmpref) = SvREFCNT_inc(sv);
5153                     EXTEND(SP, 2);
5154                     PUSHMARK(SP);
5155                     PUSHs(&tmpref);
5156                     PUTBACK;
5157                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
5158                     SvREFCNT(sv)--;
5159                     POPSTACK;
5160                     SPAGAIN;
5161                     LEAVE;
5162                 }
5163             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5164
5165             del_XRV(SvANY(&tmpref));
5166
5167             if (SvREFCNT(sv)) {
5168                 if (PL_in_clean_objs)
5169                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5170                           HvNAME(stash));
5171                 /* DESTROY gave object new lease on life */
5172                 return;
5173             }
5174         }
5175
5176         if (SvOBJECT(sv)) {
5177             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
5178             SvOBJECT_off(sv);   /* Curse the object. */
5179             if (SvTYPE(sv) != SVt_PVIO)
5180                 --PL_sv_objcount;       /* XXX Might want something more general */
5181         }
5182     }
5183     if (SvTYPE(sv) >= SVt_PVMG) {
5184         if (SvMAGIC(sv))
5185             mg_free(sv);
5186         if (SvFLAGS(sv) & SVpad_TYPED)
5187             SvREFCNT_dec(SvSTASH(sv));
5188     }
5189     stash = NULL;
5190     switch (SvTYPE(sv)) {
5191     case SVt_PVIO:
5192         if (IoIFP(sv) &&
5193             IoIFP(sv) != PerlIO_stdin() &&
5194             IoIFP(sv) != PerlIO_stdout() &&
5195             IoIFP(sv) != PerlIO_stderr())
5196         {
5197             io_close((IO*)sv, FALSE);
5198         }
5199         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5200             PerlDir_close(IoDIRP(sv));
5201         IoDIRP(sv) = (DIR*)NULL;
5202         Safefree(IoTOP_NAME(sv));
5203         Safefree(IoFMT_NAME(sv));
5204         Safefree(IoBOTTOM_NAME(sv));
5205         /* FALL THROUGH */
5206     case SVt_PVBM:
5207         goto freescalar;
5208     case SVt_PVCV:
5209     case SVt_PVFM:
5210         cv_undef((CV*)sv);
5211         goto freescalar;
5212     case SVt_PVHV:
5213         hv_undef((HV*)sv);
5214         break;
5215     case SVt_PVAV:
5216         av_undef((AV*)sv);
5217         break;
5218     case SVt_PVLV:
5219         SvREFCNT_dec(LvTARG(sv));
5220         goto freescalar;
5221     case SVt_PVGV:
5222         gp_free((GV*)sv);
5223         Safefree(GvNAME(sv));
5224         /* cannot decrease stash refcount yet, as we might recursively delete
5225            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5226            of stash until current sv is completely gone.
5227            -- JohnPC, 27 Mar 1998 */
5228         stash = GvSTASH(sv);
5229         /* FALL THROUGH */
5230     case SVt_PVMG:
5231     case SVt_PVNV:
5232     case SVt_PVIV:
5233       freescalar:
5234         (void)SvOOK_off(sv);
5235         /* FALL THROUGH */
5236     case SVt_PV:
5237     case SVt_RV:
5238         if (SvROK(sv)) {
5239             if (SvWEAKREF(sv))
5240                 sv_del_backref(sv);
5241             else
5242                 SvREFCNT_dec(SvRV(sv));
5243         }
5244 #ifdef PERL_COPY_ON_WRITE
5245         else if (SvPVX(sv)) {
5246             if (SvIsCOW(sv)) {
5247                 /* I believe I need to grab the global SV mutex here and
5248                    then recheck the COW status.  */
5249                 if (DEBUG_C_TEST) {
5250                     PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5251                     sv_dump(sv);
5252                 }
5253                 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
5254                                  SvUVX(sv), SV_COW_NEXT_SV(sv));
5255                 /* And drop it here.  */
5256                 SvFAKE_off(sv);
5257             } else if (SvLEN(sv)) {
5258                 Safefree(SvPVX(sv));
5259             }
5260         }
5261 #else
5262         else if (SvPVX(sv) && SvLEN(sv))
5263             Safefree(SvPVX(sv));
5264         else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5265             unsharepvn(SvPVX(sv),
5266                        SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5267                        SvUVX(sv));
5268             SvFAKE_off(sv);
5269         }
5270 #endif
5271         break;
5272 /*
5273     case SVt_NV:
5274     case SVt_IV:
5275     case SVt_NULL:
5276         break;
5277 */
5278     }
5279
5280     switch (SvTYPE(sv)) {
5281     case SVt_NULL:
5282         break;
5283     case SVt_IV:
5284         del_XIV(SvANY(sv));
5285         break;
5286     case SVt_NV:
5287         del_XNV(SvANY(sv));
5288         break;
5289     case SVt_RV:
5290         del_XRV(SvANY(sv));
5291         break;
5292     case SVt_PV:
5293         del_XPV(SvANY(sv));
5294         break;
5295     case SVt_PVIV:
5296         del_XPVIV(SvANY(sv));
5297         break;
5298     case SVt_PVNV:
5299         del_XPVNV(SvANY(sv));
5300         break;
5301     case SVt_PVMG:
5302         del_XPVMG(SvANY(sv));
5303         break;
5304     case SVt_PVLV:
5305         del_XPVLV(SvANY(sv));
5306         break;
5307     case SVt_PVAV:
5308         del_XPVAV(SvANY(sv));
5309         break;
5310     case SVt_PVHV:
5311         del_XPVHV(SvANY(sv));
5312         break;
5313     case SVt_PVCV:
5314         del_XPVCV(SvANY(sv));
5315         break;
5316     case SVt_PVGV:
5317         del_XPVGV(SvANY(sv));
5318         /* code duplication for increased performance. */
5319         SvFLAGS(sv) &= SVf_BREAK;
5320         SvFLAGS(sv) |= SVTYPEMASK;
5321         /* decrease refcount of the stash that owns this GV, if any */
5322         if (stash)
5323             SvREFCNT_dec(stash);
5324         return; /* not break, SvFLAGS reset already happened */
5325     case SVt_PVBM:
5326         del_XPVBM(SvANY(sv));
5327         break;
5328     case SVt_PVFM:
5329         del_XPVFM(SvANY(sv));
5330         break;
5331     case SVt_PVIO:
5332         del_XPVIO(SvANY(sv));
5333         break;
5334     }
5335     SvFLAGS(sv) &= SVf_BREAK;
5336     SvFLAGS(sv) |= SVTYPEMASK;
5337 }
5338
5339 /*
5340 =for apidoc sv_newref
5341
5342 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5343 instead.
5344
5345 =cut
5346 */
5347
5348 SV *
5349 Perl_sv_newref(pTHX_ SV *sv)
5350 {
5351     if (sv)
5352         ATOMIC_INC(SvREFCNT(sv));
5353     return sv;
5354 }
5355
5356 /*
5357 =for apidoc sv_free
5358
5359 Decrement an SV's reference count, and if it drops to zero, call
5360 C<sv_clear> to invoke destructors and free up any memory used by
5361 the body; finally, deallocate the SV's head itself.
5362 Normally called via a wrapper macro C<SvREFCNT_dec>.
5363
5364 =cut
5365 */
5366
5367 void
5368 Perl_sv_free(pTHX_ SV *sv)
5369 {
5370     int refcount_is_zero;
5371
5372     if (!sv)
5373         return;
5374     if (SvREFCNT(sv) == 0) {
5375         if (SvFLAGS(sv) & SVf_BREAK)
5376             /* this SV's refcnt has been artificially decremented to
5377              * trigger cleanup */
5378             return;
5379         if (PL_in_clean_all) /* All is fair */
5380             return;
5381         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5382             /* make sure SvREFCNT(sv)==0 happens very seldom */
5383             SvREFCNT(sv) = (~(U32)0)/2;
5384             return;
5385         }
5386         if (ckWARN_d(WARN_INTERNAL))
5387             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
5388         return;
5389     }
5390     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5391     if (!refcount_is_zero)
5392         return;
5393 #ifdef DEBUGGING
5394     if (SvTEMP(sv)) {
5395         if (ckWARN_d(WARN_DEBUGGING))
5396             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5397                         "Attempt to free temp prematurely: SV 0x%"UVxf,
5398                         PTR2UV(sv));
5399         return;
5400     }
5401 #endif
5402     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5403         /* make sure SvREFCNT(sv)==0 happens very seldom */
5404         SvREFCNT(sv) = (~(U32)0)/2;
5405         return;
5406     }
5407     sv_clear(sv);
5408     if (! SvREFCNT(sv))
5409         del_SV(sv);
5410 }
5411
5412 /*
5413 =for apidoc sv_len
5414
5415 Returns the length of the string in the SV. Handles magic and type
5416 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5417
5418 =cut
5419 */
5420
5421 STRLEN
5422 Perl_sv_len(pTHX_ register SV *sv)
5423 {
5424     STRLEN len;
5425
5426     if (!sv)
5427         return 0;
5428
5429     if (SvGMAGICAL(sv))
5430         len = mg_length(sv);
5431     else
5432         (void)SvPV(sv, len);
5433     return len;
5434 }
5435
5436 /*
5437 =for apidoc sv_len_utf8
5438
5439 Returns the number of characters in the string in an SV, counting wide
5440 UTF8 bytes as a single character. Handles magic and type coercion.
5441
5442 =cut
5443 */
5444
5445 STRLEN
5446 Perl_sv_len_utf8(pTHX_ register SV *sv)
5447 {
5448     if (!sv)
5449         return 0;
5450
5451     if (SvGMAGICAL(sv))
5452         return mg_length(sv);
5453     else
5454     {
5455         STRLEN len;
5456         U8 *s = (U8*)SvPV(sv, len);
5457
5458         return Perl_utf8_length(aTHX_ s, s + len);
5459     }
5460 }
5461
5462 /*
5463 =for apidoc sv_pos_u2b
5464
5465 Converts the value pointed to by offsetp from a count of UTF8 chars from
5466 the start of the string, to a count of the equivalent number of bytes; if
5467 lenp is non-zero, it does the same to lenp, but this time starting from
5468 the offset, rather than from the start of the string. Handles magic and
5469 type coercion.
5470
5471 =cut
5472 */
5473
5474 void
5475 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5476 {
5477     U8 *start;
5478     U8 *s;
5479     U8 *send;
5480     I32 uoffset = *offsetp;
5481     STRLEN len;
5482
5483     if (!sv)
5484         return;
5485
5486     start = s = (U8*)SvPV(sv, len);
5487     send = s + len;
5488     while (s < send && uoffset--)
5489         s += UTF8SKIP(s);
5490     if (s >= send)
5491         s = send;
5492     *offsetp = s - start;
5493     if (lenp) {
5494         I32 ulen = *lenp;
5495         start = s;
5496         while (s < send && ulen--)
5497             s += UTF8SKIP(s);
5498         if (s >= send)
5499             s = send;
5500         *lenp = s - start;
5501     }
5502     return;
5503 }
5504
5505 /*
5506 =for apidoc sv_pos_b2u
5507
5508 Converts the value pointed to by offsetp from a count of bytes from the
5509 start of the string, to a count of the equivalent number of UTF8 chars.
5510 Handles magic and type coercion.
5511
5512 =cut
5513 */
5514
5515 void
5516 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5517 {
5518     U8 *s;
5519     U8 *send;
5520     STRLEN len;
5521
5522     if (!sv)
5523         return;
5524
5525     s = (U8*)SvPV(sv, len);
5526     if ((I32)len < *offsetp)
5527         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5528     send = s + *offsetp;
5529     len = 0;
5530     while (s < send) {
5531         STRLEN n = 1;
5532         /* Call utf8n_to_uvchr() to validate the sequence
5533          * (unless a simple non-UTF character) */
5534         if (!UTF8_IS_INVARIANT(*s))
5535             utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5536         if (n > 0) {
5537             s += n;
5538             len++;
5539         }
5540         else
5541             break;
5542     }
5543     *offsetp = len;
5544     return;
5545 }
5546
5547 /*
5548 =for apidoc sv_eq
5549
5550 Returns a boolean indicating whether the strings in the two SVs are
5551 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5552 coerce its args to strings if necessary.
5553
5554 =cut
5555 */
5556
5557 I32
5558 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5559 {
5560     char *pv1;
5561     STRLEN cur1;
5562     char *pv2;
5563     STRLEN cur2;
5564     I32  eq     = 0;
5565     char *tpv   = Nullch;
5566     SV* svrecode = Nullsv;
5567
5568     if (!sv1) {
5569         pv1 = "";
5570         cur1 = 0;
5571     }
5572     else
5573         pv1 = SvPV(sv1, cur1);
5574
5575     if (!sv2){
5576         pv2 = "";
5577         cur2 = 0;
5578     }
5579     else
5580         pv2 = SvPV(sv2, cur2);
5581
5582     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5583         /* Differing utf8ness.
5584          * Do not UTF8size the comparands as a side-effect. */
5585          if (PL_encoding) {
5586               if (SvUTF8(sv1)) {
5587                    svrecode = newSVpvn(pv2, cur2);
5588                    sv_recode_to_utf8(svrecode, PL_encoding);
5589                    pv2 = SvPV(svrecode, cur2);
5590               }
5591               else {
5592                    svrecode = newSVpvn(pv1, cur1);
5593                    sv_recode_to_utf8(svrecode, PL_encoding);
5594                    pv1 = SvPV(svrecode, cur1);
5595               }
5596               /* Now both are in UTF-8. */
5597               if (cur1 != cur2)
5598                    return FALSE;
5599          }
5600          else {
5601               bool is_utf8 = TRUE;
5602
5603               if (SvUTF8(sv1)) {
5604                    /* sv1 is the UTF-8 one,
5605                     * if is equal it must be downgrade-able */
5606                    char *pv = (char*)bytes_from_utf8((U8*)pv1,
5607                                                      &cur1, &is_utf8);
5608                    if (pv != pv1)
5609                         pv1 = tpv = pv;
5610               }
5611               else {
5612                    /* sv2 is the UTF-8 one,
5613                     * if is equal it must be downgrade-able */
5614                    char *pv = (char *)bytes_from_utf8((U8*)pv2,
5615                                                       &cur2, &is_utf8);
5616                    if (pv != pv2)
5617                         pv2 = tpv = pv;
5618               }
5619               if (is_utf8) {
5620                    /* Downgrade not possible - cannot be eq */
5621                    return FALSE;
5622               }
5623          }
5624     }
5625
5626     if (cur1 == cur2)
5627         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
5628
5629     if (svrecode)
5630          SvREFCNT_dec(svrecode);
5631
5632     if (tpv)
5633         Safefree(tpv);
5634
5635     return eq;
5636 }
5637
5638 /*
5639 =for apidoc sv_cmp
5640
5641 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
5642 string in C<sv1> is less than, equal to, or greater than the string in
5643 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5644 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
5645
5646 =cut
5647 */
5648
5649 I32
5650 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5651 {
5652     STRLEN cur1, cur2;
5653     char *pv1, *pv2, *tpv = Nullch;
5654     I32  cmp;
5655     SV *svrecode = Nullsv;
5656
5657     if (!sv1) {
5658         pv1 = "";
5659         cur1 = 0;
5660     }
5661     else
5662         pv1 = SvPV(sv1, cur1);
5663
5664     if (!sv2) {
5665         pv2 = "";
5666         cur2 = 0;
5667     }
5668     else
5669         pv2 = SvPV(sv2, cur2);
5670
5671     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5672         /* Differing utf8ness.
5673          * Do not UTF8size the comparands as a side-effect. */
5674         if (SvUTF8(sv1)) {
5675             if (PL_encoding) {
5676                  svrecode = newSVpvn(pv2, cur2);
5677                  sv_recode_to_utf8(svrecode, PL_encoding);
5678                  pv2 = SvPV(svrecode, cur2);
5679             }
5680             else {
5681                  pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5682             }
5683         }
5684         else {
5685             if (PL_encoding) {
5686                  svrecode = newSVpvn(pv1, cur1);
5687                  sv_recode_to_utf8(svrecode, PL_encoding);
5688                  pv1 = SvPV(svrecode, cur1);
5689             }
5690             else {
5691                  pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5692             }
5693         }
5694     }
5695
5696     if (!cur1) {
5697         cmp = cur2 ? -1 : 0;
5698     } else if (!cur2) {
5699         cmp = 1;
5700     } else {
5701         I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5702
5703         if (retval) {
5704             cmp = retval < 0 ? -1 : 1;
5705         } else if (cur1 == cur2) {
5706             cmp = 0;
5707         } else {
5708             cmp = cur1 < cur2 ? -1 : 1;
5709         }
5710     }
5711
5712     if (svrecode)
5713          SvREFCNT_dec(svrecode);
5714
5715     if (tpv)
5716         Safefree(tpv);
5717
5718     return cmp;
5719 }
5720
5721 /*
5722 =for apidoc sv_cmp_locale
5723
5724 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5725 'use bytes' aware, handles get magic, and will coerce its args to strings
5726 if necessary.  See also C<sv_cmp_locale>.  See also C<sv_cmp>.
5727
5728 =cut
5729 */
5730
5731 I32
5732 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5733 {
5734 #ifdef USE_LOCALE_COLLATE
5735
5736     char *pv1, *pv2;
5737     STRLEN len1, len2;
5738     I32 retval;
5739
5740     if (PL_collation_standard)
5741         goto raw_compare;
5742
5743     len1 = 0;
5744     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5745     len2 = 0;
5746     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5747
5748     if (!pv1 || !len1) {
5749         if (pv2 && len2)
5750             return -1;
5751         else
5752             goto raw_compare;
5753     }
5754     else {
5755         if (!pv2 || !len2)
5756             return 1;
5757     }
5758
5759     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5760
5761     if (retval)
5762         return retval < 0 ? -1 : 1;
5763
5764     /*
5765      * When the result of collation is equality, that doesn't mean
5766      * that there are no differences -- some locales exclude some
5767      * characters from consideration.  So to avoid false equalities,
5768      * we use the raw string as a tiebreaker.
5769      */
5770
5771   raw_compare:
5772     /* FALL THROUGH */
5773
5774 #endif /* USE_LOCALE_COLLATE */
5775
5776     return sv_cmp(sv1, sv2);
5777 }
5778
5779
5780 #ifdef USE_LOCALE_COLLATE
5781
5782 /*
5783 =for apidoc sv_collxfrm
5784
5785 Add Collate Transform magic to an SV if it doesn't already have it.
5786
5787 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5788 scalar data of the variable, but transformed to such a format that a normal
5789 memory comparison can be used to compare the data according to the locale
5790 settings.
5791
5792 =cut
5793 */
5794
5795 char *
5796 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5797 {
5798     MAGIC *mg;
5799
5800     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5801     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5802         char *s, *xf;
5803         STRLEN len, xlen;
5804
5805         if (mg)
5806             Safefree(mg->mg_ptr);
5807         s = SvPV(sv, len);
5808         if ((xf = mem_collxfrm(s, len, &xlen))) {
5809             if (SvREADONLY(sv)) {
5810                 SAVEFREEPV(xf);
5811                 *nxp = xlen;
5812                 return xf + sizeof(PL_collation_ix);
5813             }
5814             if (! mg) {
5815                 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5816                 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5817                 assert(mg);
5818             }
5819             mg->mg_ptr = xf;
5820             mg->mg_len = xlen;
5821         }
5822         else {
5823             if (mg) {
5824                 mg->mg_ptr = NULL;
5825                 mg->mg_len = -1;
5826             }
5827         }
5828     }
5829     if (mg && mg->mg_ptr) {
5830         *nxp = mg->mg_len;
5831         return mg->mg_ptr + sizeof(PL_collation_ix);
5832     }
5833     else {
5834         *nxp = 0;
5835         return NULL;
5836     }
5837 }
5838
5839 #endif /* USE_LOCALE_COLLATE */
5840
5841 /*
5842 =for apidoc sv_gets
5843
5844 Get a line from the filehandle and store it into the SV, optionally
5845 appending to the currently-stored string.
5846
5847 =cut
5848 */
5849
5850 char *
5851 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5852 {
5853     char *rsptr;
5854     STRLEN rslen;
5855     register STDCHAR rslast;
5856     register STDCHAR *bp;
5857     register I32 cnt;
5858     I32 i = 0;
5859     I32 rspara = 0;
5860
5861     SV_CHECK_THINKFIRST_COW_DROP(sv);
5862     /* XXX. If you make this PVIV, then copy on write can copy scalars read
5863        from <>.
5864        However, perlbench says it's slower, because the existing swipe code
5865        is faster than copy on write.
5866        Swings and roundabouts.  */
5867     (void)SvUPGRADE(sv, SVt_PV);
5868
5869     SvSCREAM_off(sv);
5870
5871     if (PL_curcop == &PL_compiling) {
5872         /* we always read code in line mode */
5873         rsptr = "\n";
5874         rslen = 1;
5875     }
5876     else if (RsSNARF(PL_rs)) {
5877         rsptr = NULL;
5878         rslen = 0;
5879     }
5880     else if (RsRECORD(PL_rs)) {
5881       I32 recsize, bytesread;
5882       char *buffer;
5883
5884       /* Grab the size of the record we're getting */
5885       recsize = SvIV(SvRV(PL_rs));
5886       (void)SvPOK_only(sv);    /* Validate pointer */
5887       buffer = SvGROW(sv, (STRLEN)(recsize + 1));
5888       /* Go yank in */
5889 #ifdef VMS
5890       /* VMS wants read instead of fread, because fread doesn't respect */
5891       /* RMS record boundaries. This is not necessarily a good thing to be */
5892       /* doing, but we've got no other real choice */
5893       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5894 #else
5895       bytesread = PerlIO_read(fp, buffer, recsize);
5896 #endif
5897       SvCUR_set(sv, bytesread);
5898       buffer[bytesread] = '\0';
5899       if (PerlIO_isutf8(fp))
5900         SvUTF8_on(sv);
5901       else
5902         SvUTF8_off(sv);
5903       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5904     }
5905     else if (RsPARA(PL_rs)) {
5906         rsptr = "\n\n";
5907         rslen = 2;
5908         rspara = 1;
5909     }
5910     else {
5911         /* Get $/ i.e. PL_rs into same encoding as stream wants */
5912         if (PerlIO_isutf8(fp)) {
5913             rsptr = SvPVutf8(PL_rs, rslen);
5914         }
5915         else {
5916             if (SvUTF8(PL_rs)) {
5917                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5918                     Perl_croak(aTHX_ "Wide character in $/");
5919                 }
5920             }
5921             rsptr = SvPV(PL_rs, rslen);
5922         }
5923     }
5924
5925     rslast = rslen ? rsptr[rslen - 1] : '\0';
5926
5927     if (rspara) {               /* have to do this both before and after */
5928         do {                    /* to make sure file boundaries work right */
5929             if (PerlIO_eof(fp))
5930                 return 0;
5931             i = PerlIO_getc(fp);
5932             if (i != '\n') {
5933                 if (i == -1)
5934                     return 0;
5935                 PerlIO_ungetc(fp,i);
5936                 break;
5937             }
5938         } while (i != EOF);
5939     }
5940
5941     /* See if we know enough about I/O mechanism to cheat it ! */
5942
5943     /* This used to be #ifdef test - it is made run-time test for ease
5944        of abstracting out stdio interface. One call should be cheap
5945        enough here - and may even be a macro allowing compile
5946        time optimization.
5947      */
5948
5949     if (PerlIO_fast_gets(fp)) {
5950
5951     /*
5952      * We're going to steal some values from the stdio struct
5953      * and put EVERYTHING in the innermost loop into registers.
5954      */
5955     register STDCHAR *ptr;
5956     STRLEN bpx;
5957     I32 shortbuffered;
5958
5959 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5960     /* An ungetc()d char is handled separately from the regular
5961      * buffer, so we getc() it back out and stuff it in the buffer.
5962      */
5963     i = PerlIO_getc(fp);
5964     if (i == EOF) return 0;
5965     *(--((*fp)->_ptr)) = (unsigned char) i;
5966     (*fp)->_cnt++;
5967 #endif
5968
5969     /* Here is some breathtakingly efficient cheating */
5970
5971     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
5972     (void)SvPOK_only(sv);               /* validate pointer */
5973     if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */
5974         if (cnt > 80 && (I32)SvLEN(sv) > append) {
5975             shortbuffered = cnt - SvLEN(sv) + append + 1;
5976             cnt -= shortbuffered;
5977         }
5978         else {
5979             shortbuffered = 0;
5980             /* remember that cnt can be negative */
5981             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
5982         }
5983     }
5984     else
5985         shortbuffered = 0;
5986     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
5987     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5988     DEBUG_P(PerlIO_printf(Perl_debug_log,
5989         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5990     DEBUG_P(PerlIO_printf(Perl_debug_log,
5991         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5992                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5993                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5994     for (;;) {
5995       screamer:
5996         if (cnt > 0) {
5997             if (rslen) {
5998                 while (cnt > 0) {                    /* this     |  eat */
5999                     cnt--;
6000                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
6001                         goto thats_all_folks;        /* screams  |  sed :-) */
6002                 }
6003             }
6004             else {
6005                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
6006                 bp += cnt;                           /* screams  |  dust */
6007                 ptr += cnt;                          /* louder   |  sed :-) */
6008                 cnt = 0;
6009             }
6010         }
6011
6012         if (shortbuffered) {            /* oh well, must extend */
6013             cnt = shortbuffered;
6014             shortbuffered = 0;
6015             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6016             SvCUR_set(sv, bpx);
6017             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6018             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6019             continue;
6020         }
6021
6022         DEBUG_P(PerlIO_printf(Perl_debug_log,
6023                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6024                               PTR2UV(ptr),(long)cnt));
6025         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6026 #if 0
6027         DEBUG_P(PerlIO_printf(Perl_debug_log,
6028             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6029             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6030             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6031 #endif
6032         /* This used to call 'filbuf' in stdio form, but as that behaves like
6033            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6034            another abstraction.  */
6035         i   = PerlIO_getc(fp);          /* get more characters */
6036 #if 0
6037         DEBUG_P(PerlIO_printf(Perl_debug_log,
6038             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6039             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6040             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6041 #endif
6042         cnt = PerlIO_get_cnt(fp);
6043         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
6044         DEBUG_P(PerlIO_printf(Perl_debug_log,
6045             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6046
6047         if (i == EOF)                   /* all done for ever? */
6048             goto thats_really_all_folks;
6049
6050         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6051         SvCUR_set(sv, bpx);
6052         SvGROW(sv, bpx + cnt + 2);
6053         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6054
6055         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
6056
6057         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
6058             goto thats_all_folks;
6059     }
6060
6061 thats_all_folks:
6062     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
6063           memNE((char*)bp - rslen, rsptr, rslen))
6064         goto screamer;                          /* go back to the fray */
6065 thats_really_all_folks:
6066     if (shortbuffered)
6067         cnt += shortbuffered;
6068         DEBUG_P(PerlIO_printf(Perl_debug_log,
6069             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6070     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
6071     DEBUG_P(PerlIO_printf(Perl_debug_log,
6072         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6073         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6074         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6075     *bp = '\0';
6076     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
6077     DEBUG_P(PerlIO_printf(Perl_debug_log,
6078         "Screamer: done, len=%ld, string=|%.*s|\n",
6079         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
6080     }
6081    else
6082     {
6083 #ifndef EPOC
6084        /*The big, slow, and stupid way */
6085         STDCHAR buf[8192];
6086 #else
6087         /* Need to work around EPOC SDK features          */
6088         /* On WINS: MS VC5 generates calls to _chkstk,    */
6089         /* if a `large' stack frame is allocated          */
6090         /* gcc on MARM does not generate calls like these */
6091         STDCHAR buf[1024];
6092 #endif
6093
6094 screamer2:
6095         if (rslen) {
6096             register STDCHAR *bpe = buf + sizeof(buf);
6097             bp = buf;
6098             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6099                 ; /* keep reading */
6100             cnt = bp - buf;
6101         }
6102         else {
6103             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6104             /* Accomodate broken VAXC compiler, which applies U8 cast to
6105              * both args of ?: operator, causing EOF to change into 255
6106              */
6107             if (cnt > 0)
6108                  i = (U8)buf[cnt - 1];
6109             else
6110                  i = EOF;
6111         }
6112
6113         if (cnt < 0)
6114             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
6115         if (append)
6116              sv_catpvn(sv, (char *) buf, cnt);
6117         else
6118              sv_setpvn(sv, (char *) buf, cnt);
6119
6120         if (i != EOF &&                 /* joy */
6121             (!rslen ||
6122              SvCUR(sv) < rslen ||
6123              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6124         {
6125             append = -1;
6126             /*
6127              * If we're reading from a TTY and we get a short read,
6128              * indicating that the user hit his EOF character, we need
6129              * to notice it now, because if we try to read from the TTY
6130              * again, the EOF condition will disappear.
6131              *
6132              * The comparison of cnt to sizeof(buf) is an optimization
6133              * that prevents unnecessary calls to feof().
6134              *
6135              * - jik 9/25/96
6136              */
6137             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6138                 goto screamer2;
6139         }
6140     }
6141
6142     if (rspara) {               /* have to do this both before and after */
6143         while (i != EOF) {      /* to make sure file boundaries work right */
6144             i = PerlIO_getc(fp);
6145             if (i != '\n') {
6146                 PerlIO_ungetc(fp,i);
6147                 break;
6148             }
6149         }
6150     }
6151
6152     if (PerlIO_isutf8(fp))
6153         SvUTF8_on(sv);
6154     else
6155         SvUTF8_off(sv);
6156
6157     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6158 }
6159
6160 /*
6161 =for apidoc sv_inc
6162
6163 Auto-increment of the value in the SV, doing string to numeric conversion
6164 if necessary. Handles 'get' magic.
6165
6166 =cut
6167 */
6168
6169 void
6170 Perl_sv_inc(pTHX_ register SV *sv)
6171 {
6172     register char *d;
6173     int flags;
6174
6175     if (!sv)
6176         return;
6177     if (SvGMAGICAL(sv))
6178         mg_get(sv);
6179     if (SvTHINKFIRST(sv)) {
6180         if (SvIsCOW(sv))
6181             sv_force_normal_flags(sv, 0);
6182         if (SvREADONLY(sv)) {
6183             if (PL_curcop != &PL_compiling)
6184                 Perl_croak(aTHX_ PL_no_modify);
6185         }
6186         if (SvROK(sv)) {
6187             IV i;
6188             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6189                 return;
6190             i = PTR2IV(SvRV(sv));
6191             sv_unref(sv);
6192             sv_setiv(sv, i);
6193         }
6194     }
6195     flags = SvFLAGS(sv);
6196     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6197         /* It's (privately or publicly) a float, but not tested as an
6198            integer, so test it to see. */
6199         (void) SvIV(sv);
6200         flags = SvFLAGS(sv);
6201     }
6202     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6203         /* It's publicly an integer, or privately an integer-not-float */
6204 #ifdef PERL_PRESERVE_IVUV
6205       oops_its_int:
6206 #endif
6207         if (SvIsUV(sv)) {
6208             if (SvUVX(sv) == UV_MAX)
6209                 sv_setnv(sv, UV_MAX_P1);
6210             else
6211                 (void)SvIOK_only_UV(sv);
6212                 ++SvUVX(sv);
6213         } else {
6214             if (SvIVX(sv) == IV_MAX)
6215                 sv_setuv(sv, (UV)IV_MAX + 1);
6216             else {
6217                 (void)SvIOK_only(sv);
6218                 ++SvIVX(sv);
6219             }
6220         }
6221         return;
6222     }
6223     if (flags & SVp_NOK) {
6224         (void)SvNOK_only(sv);
6225         SvNVX(sv) += 1.0;
6226         return;
6227     }
6228
6229     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
6230         if ((flags & SVTYPEMASK) < SVt_PVIV)
6231             sv_upgrade(sv, SVt_IV);
6232         (void)SvIOK_only(sv);
6233         SvIVX(sv) = 1;
6234         return;
6235     }
6236     d = SvPVX(sv);
6237     while (isALPHA(*d)) d++;
6238     while (isDIGIT(*d)) d++;
6239     if (*d) {
6240 #ifdef PERL_PRESERVE_IVUV
6241         /* Got to punt this as an integer if needs be, but we don't issue
6242            warnings. Probably ought to make the sv_iv_please() that does
6243            the conversion if possible, and silently.  */
6244         int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6245         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6246             /* Need to try really hard to see if it's an integer.
6247                9.22337203685478e+18 is an integer.
6248                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6249                so $a="9.22337203685478e+18"; $a+0; $a++
6250                needs to be the same as $a="9.22337203685478e+18"; $a++
6251                or we go insane. */
6252
6253             (void) sv_2iv(sv);
6254             if (SvIOK(sv))
6255                 goto oops_its_int;
6256
6257             /* sv_2iv *should* have made this an NV */
6258             if (flags & SVp_NOK) {
6259                 (void)SvNOK_only(sv);
6260                 SvNVX(sv) += 1.0;
6261                 return;
6262             }
6263             /* I don't think we can get here. Maybe I should assert this
6264                And if we do get here I suspect that sv_setnv will croak. NWC
6265                Fall through. */
6266 #if defined(USE_LONG_DOUBLE)
6267             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",
6268                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6269 #else
6270             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6271                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6272 #endif
6273         }
6274 #endif /* PERL_PRESERVE_IVUV */
6275         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
6276         return;
6277     }
6278     d--;
6279     while (d >= SvPVX(sv)) {
6280         if (isDIGIT(*d)) {
6281             if (++*d <= '9')
6282                 return;
6283             *(d--) = '0';
6284         }
6285         else {
6286 #ifdef EBCDIC
6287             /* MKS: The original code here died if letters weren't consecutive.
6288              * at least it didn't have to worry about non-C locales.  The
6289              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6290              * arranged in order (although not consecutively) and that only
6291              * [A-Za-z] are accepted by isALPHA in the C locale.
6292              */
6293             if (*d != 'z' && *d != 'Z') {
6294                 do { ++*d; } while (!isALPHA(*d));
6295                 return;
6296             }
6297             *(d--) -= 'z' - 'a';
6298 #else
6299             ++*d;
6300             if (isALPHA(*d))
6301                 return;
6302             *(d--) -= 'z' - 'a' + 1;
6303 #endif
6304         }
6305     }
6306     /* oh,oh, the number grew */
6307     SvGROW(sv, SvCUR(sv) + 2);
6308     SvCUR(sv)++;
6309     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
6310         *d = d[-1];
6311     if (isDIGIT(d[1]))
6312         *d = '1';
6313     else
6314         *d = d[1];
6315 }
6316
6317 /*
6318 =for apidoc sv_dec
6319
6320 Auto-decrement of the value in the SV, doing string to numeric conversion
6321 if necessary. Handles 'get' magic.
6322
6323 =cut
6324 */
6325
6326 void
6327 Perl_sv_dec(pTHX_ register SV *sv)
6328 {
6329     int flags;
6330
6331     if (!sv)
6332         return;
6333     if (SvGMAGICAL(sv))
6334         mg_get(sv);
6335     if (SvTHINKFIRST(sv)) {
6336         if (SvIsCOW(sv))
6337             sv_force_normal_flags(sv, 0);
6338         if (SvREADONLY(sv)) {
6339             if (PL_curcop != &PL_compiling)
6340                 Perl_croak(aTHX_ PL_no_modify);
6341         }
6342         if (SvROK(sv)) {
6343             IV i;
6344             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6345                 return;
6346             i = PTR2IV(SvRV(sv));
6347             sv_unref(sv);
6348             sv_setiv(sv, i);
6349         }
6350     }
6351     /* Unlike sv_inc we don't have to worry about string-never-numbers
6352        and keeping them magic. But we mustn't warn on punting */
6353     flags = SvFLAGS(sv);
6354     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6355         /* It's publicly an integer, or privately an integer-not-float */
6356 #ifdef PERL_PRESERVE_IVUV
6357       oops_its_int:
6358 #endif
6359         if (SvIsUV(sv)) {
6360             if (SvUVX(sv) == 0) {
6361                 (void)SvIOK_only(sv);
6362                 SvIVX(sv) = -1;
6363             }
6364             else {
6365                 (void)SvIOK_only_UV(sv);
6366                 --SvUVX(sv);
6367             }
6368         } else {
6369             if (SvIVX(sv) == IV_MIN)
6370                 sv_setnv(sv, (NV)IV_MIN - 1.0);
6371             else {
6372                 (void)SvIOK_only(sv);
6373                 --SvIVX(sv);
6374             }
6375         }
6376         return;
6377     }
6378     if (flags & SVp_NOK) {
6379         SvNVX(sv) -= 1.0;
6380         (void)SvNOK_only(sv);
6381         return;
6382     }
6383     if (!(flags & SVp_POK)) {
6384         if ((flags & SVTYPEMASK) < SVt_PVNV)
6385             sv_upgrade(sv, SVt_NV);
6386         SvNVX(sv) = -1.0;
6387         (void)SvNOK_only(sv);
6388         return;
6389     }
6390 #ifdef PERL_PRESERVE_IVUV
6391     {
6392         int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6393         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6394             /* Need to try really hard to see if it's an integer.
6395                9.22337203685478e+18 is an integer.
6396                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6397                so $a="9.22337203685478e+18"; $a+0; $a--
6398                needs to be the same as $a="9.22337203685478e+18"; $a--
6399                or we go insane. */
6400
6401             (void) sv_2iv(sv);
6402             if (SvIOK(sv))
6403                 goto oops_its_int;
6404
6405             /* sv_2iv *should* have made this an NV */
6406             if (flags & SVp_NOK) {
6407                 (void)SvNOK_only(sv);
6408                 SvNVX(sv) -= 1.0;
6409                 return;
6410             }
6411             /* I don't think we can get here. Maybe I should assert this
6412                And if we do get here I suspect that sv_setnv will croak. NWC
6413                Fall through. */
6414 #if defined(USE_LONG_DOUBLE)
6415             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",
6416                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6417 #else
6418             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6419                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6420 #endif
6421         }
6422     }
6423 #endif /* PERL_PRESERVE_IVUV */
6424     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6425 }
6426
6427 /*
6428 =for apidoc sv_mortalcopy
6429
6430 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6431 The new SV is marked as mortal. It will be destroyed "soon", either by an
6432 explicit call to FREETMPS, or by an implicit call at places such as
6433 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
6434
6435 =cut
6436 */
6437
6438 /* Make a string that will exist for the duration of the expression
6439  * evaluation.  Actually, it may have to last longer than that, but
6440  * hopefully we won't free it until it has been assigned to a
6441  * permanent location. */
6442
6443 SV *
6444 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6445 {
6446     register SV *sv;
6447
6448     new_SV(sv);
6449     sv_setsv(sv,oldstr);
6450     EXTEND_MORTAL(1);
6451     PL_tmps_stack[++PL_tmps_ix] = sv;
6452     SvTEMP_on(sv);
6453     return sv;
6454 }
6455
6456 /*
6457 =for apidoc sv_newmortal
6458
6459 Creates a new null SV which is mortal.  The reference count of the SV is
6460 set to 1. It will be destroyed "soon", either by an explicit call to
6461 FREETMPS, or by an implicit call at places such as statement boundaries.
6462 See also C<sv_mortalcopy> and C<sv_2mortal>.
6463
6464 =cut
6465 */
6466
6467 SV *
6468 Perl_sv_newmortal(pTHX)
6469 {
6470     register SV *sv;
6471
6472     new_SV(sv);
6473     SvFLAGS(sv) = SVs_TEMP;
6474     EXTEND_MORTAL(1);
6475     PL_tmps_stack[++PL_tmps_ix] = sv;
6476     return sv;
6477 }
6478
6479 /*
6480 =for apidoc sv_2mortal
6481
6482 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
6483 by an explicit call to FREETMPS, or by an implicit call at places such as
6484 statement boundaries.  See also C<sv_newmortal> and C<sv_mortalcopy>.
6485
6486 =cut
6487 */
6488
6489 SV *
6490 Perl_sv_2mortal(pTHX_ register SV *sv)
6491 {
6492     if (!sv)
6493         return sv;
6494     if (SvREADONLY(sv) && SvIMMORTAL(sv))
6495         return sv;
6496     EXTEND_MORTAL(1);
6497     PL_tmps_stack[++PL_tmps_ix] = sv;
6498     SvTEMP_on(sv);
6499     return sv;
6500 }
6501
6502 /*
6503 =for apidoc newSVpv
6504
6505 Creates a new SV and copies a string into it.  The reference count for the
6506 SV is set to 1.  If C<len> is zero, Perl will compute the length using
6507 strlen().  For efficiency, consider using C<newSVpvn> instead.
6508
6509 =cut
6510 */
6511
6512 SV *
6513 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6514 {
6515     register SV *sv;
6516
6517     new_SV(sv);
6518     if (!len)
6519         len = strlen(s);
6520     sv_setpvn(sv,s,len);
6521     return sv;
6522 }
6523
6524 /*
6525 =for apidoc newSVpvn
6526
6527 Creates a new SV and copies a string into it.  The reference count for the
6528 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
6529 string.  You are responsible for ensuring that the source string is at least
6530 C<len> bytes long.
6531
6532 =cut
6533 */
6534
6535 SV *
6536 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6537 {
6538     register SV *sv;
6539
6540     new_SV(sv);
6541     sv_setpvn(sv,s,len);
6542     return sv;
6543 }
6544
6545 /*
6546 =for apidoc newSVpvn_share
6547
6548 Creates a new SV with its SvPVX pointing to a shared string in the string
6549 table. If the string does not already exist in the table, it is created
6550 first.  Turns on READONLY and FAKE.  The string's hash is stored in the UV
6551 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6552 otherwise the hash is computed.  The idea here is that as the string table
6553 is used for shared hash keys these strings will have SvPVX == HeKEY and
6554 hash lookup will avoid string compare.
6555
6556 =cut
6557 */
6558
6559 SV *
6560 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6561 {
6562     register SV *sv;
6563     bool is_utf8 = FALSE;
6564     if (len < 0) {
6565         STRLEN tmplen = -len;
6566         is_utf8 = TRUE;
6567         /* See the note in hv.c:hv_fetch() --jhi */
6568         src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6569         len = tmplen;
6570     }
6571     if (!hash)
6572         PERL_HASH(hash, src, len);
6573     new_SV(sv);
6574     sv_upgrade(sv, SVt_PVIV);
6575     SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6576     SvCUR(sv) = len;
6577     SvUVX(sv) = hash;
6578     SvLEN(sv) = 0;
6579     SvREADONLY_on(sv);
6580     SvFAKE_on(sv);
6581     SvPOK_on(sv);
6582     if (is_utf8)
6583         SvUTF8_on(sv);
6584     return sv;
6585 }
6586
6587
6588 #if defined(PERL_IMPLICIT_CONTEXT)
6589
6590 /* pTHX_ magic can't cope with varargs, so this is a no-context
6591  * version of the main function, (which may itself be aliased to us).
6592  * Don't access this version directly.
6593  */
6594
6595 SV *
6596 Perl_newSVpvf_nocontext(const char* pat, ...)
6597 {
6598     dTHX;
6599     register SV *sv;
6600     va_list args;
6601     va_start(args, pat);
6602     sv = vnewSVpvf(pat, &args);
6603     va_end(args);
6604     return sv;
6605 }
6606 #endif
6607
6608 /*
6609 =for apidoc newSVpvf
6610
6611 Creates a new SV and initializes it with the string formatted like
6612 C<sprintf>.
6613
6614 =cut
6615 */
6616
6617 SV *
6618 Perl_newSVpvf(pTHX_ const char* pat, ...)
6619 {
6620     register SV *sv;
6621     va_list args;
6622     va_start(args, pat);
6623     sv = vnewSVpvf(pat, &args);
6624     va_end(args);
6625     return sv;
6626 }
6627
6628 /* backend for newSVpvf() and newSVpvf_nocontext() */
6629
6630 SV *
6631 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6632 {
6633     register SV *sv;
6634     new_SV(sv);
6635     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6636     return sv;
6637 }
6638
6639 /*
6640 =for apidoc newSVnv
6641
6642 Creates a new SV and copies a floating point value into it.
6643 The reference count for the SV is set to 1.
6644
6645 =cut
6646 */
6647
6648 SV *
6649 Perl_newSVnv(pTHX_ NV n)
6650 {
6651     register SV *sv;
6652
6653     new_SV(sv);
6654     sv_setnv(sv,n);
6655     return sv;
6656 }
6657
6658 /*
6659 =for apidoc newSViv
6660
6661 Creates a new SV and copies an integer into it.  The reference count for the
6662 SV is set to 1.
6663
6664 =cut
6665 */
6666
6667 SV *
6668 Perl_newSViv(pTHX_ IV i)
6669 {
6670     register SV *sv;
6671
6672     new_SV(sv);
6673     sv_setiv(sv,i);
6674     return sv;
6675 }
6676
6677 /*
6678 =for apidoc newSVuv
6679
6680 Creates a new SV and copies an unsigned integer into it.
6681 The reference count for the SV is set to 1.
6682
6683 =cut
6684 */
6685
6686 SV *
6687 Perl_newSVuv(pTHX_ UV u)
6688 {
6689     register SV *sv;
6690
6691     new_SV(sv);
6692     sv_setuv(sv,u);
6693     return sv;
6694 }
6695
6696 /*
6697 =for apidoc newRV_noinc
6698
6699 Creates an RV wrapper for an SV.  The reference count for the original
6700 SV is B<not> incremented.
6701
6702 =cut
6703 */
6704
6705 SV *
6706 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6707 {
6708     register SV *sv;
6709
6710     new_SV(sv);
6711     sv_upgrade(sv, SVt_RV);
6712     SvTEMP_off(tmpRef);
6713     SvRV(sv) = tmpRef;
6714     SvROK_on(sv);
6715     return sv;
6716 }
6717
6718 /* newRV_inc is the official function name to use now.
6719  * newRV_inc is in fact #defined to newRV in sv.h
6720  */
6721
6722 SV *
6723 Perl_newRV(pTHX_ SV *tmpRef)
6724 {
6725     return newRV_noinc(SvREFCNT_inc(tmpRef));
6726 }
6727
6728 /*
6729 =for apidoc newSVsv
6730
6731 Creates a new SV which is an exact duplicate of the original SV.
6732 (Uses C<sv_setsv>).
6733
6734 =cut
6735 */
6736
6737 SV *
6738 Perl_newSVsv(pTHX_ register SV *old)
6739 {
6740     register SV *sv;
6741
6742     if (!old)
6743         return Nullsv;
6744     if (SvTYPE(old) == SVTYPEMASK) {
6745         if (ckWARN_d(WARN_INTERNAL))
6746             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
6747         return Nullsv;
6748     }
6749     new_SV(sv);
6750     if (SvTEMP(old)) {
6751         SvTEMP_off(old);
6752         sv_setsv(sv,old);
6753         SvTEMP_on(old);
6754     }
6755     else
6756         sv_setsv(sv,old);
6757     return sv;
6758 }
6759
6760 /*
6761 =for apidoc sv_reset
6762
6763 Underlying implementation for the C<reset> Perl function.
6764 Note that the perl-level function is vaguely deprecated.
6765
6766 =cut
6767 */
6768
6769 void
6770 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6771 {
6772     register HE *entry;
6773     register GV *gv;
6774     register SV *sv;
6775     register I32 i;
6776     register PMOP *pm;
6777     register I32 max;
6778     char todo[PERL_UCHAR_MAX+1];
6779
6780     if (!stash)
6781         return;
6782
6783     if (!*s) {          /* reset ?? searches */
6784         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6785             pm->op_pmdynflags &= ~PMdf_USED;
6786         }
6787         return;
6788     }
6789
6790     /* reset variables */
6791
6792     if (!HvARRAY(stash))
6793         return;
6794
6795     Zero(todo, 256, char);
6796     while (*s) {
6797         i = (unsigned char)*s;
6798         if (s[1] == '-') {
6799             s += 2;
6800         }
6801         max = (unsigned char)*s++;
6802         for ( ; i <= max; i++) {
6803             todo[i] = 1;
6804         }
6805         for (i = 0; i <= (I32) HvMAX(stash); i++) {
6806             for (entry = HvARRAY(stash)[i];
6807                  entry;
6808                  entry = HeNEXT(entry))
6809             {
6810                 if (!todo[(U8)*HeKEY(entry)])
6811                     continue;
6812                 gv = (GV*)HeVAL(entry);
6813                 sv = GvSV(gv);
6814                 if (SvTHINKFIRST(sv)) {
6815                     if (!SvREADONLY(sv) && SvROK(sv))
6816                         sv_unref(sv);
6817                     continue;
6818                 }
6819                 (void)SvOK_off(sv);
6820                 if (SvTYPE(sv) >= SVt_PV) {
6821                     SvCUR_set(sv, 0);
6822                     if (SvPVX(sv) != Nullch)
6823                         *SvPVX(sv) = '\0';
6824                     SvTAINT(sv);
6825                 }
6826                 if (GvAV(gv)) {
6827                     av_clear(GvAV(gv));
6828                 }
6829                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6830                     hv_clear(GvHV(gv));
6831 #ifdef USE_ENVIRON_ARRAY
6832                     if (gv == PL_envgv
6833 #  ifdef USE_ITHREADS
6834                         && PL_curinterp == aTHX
6835 #  endif
6836                     )
6837                     {
6838                         environ[0] = Nullch;
6839                     }
6840 #endif
6841                 }
6842             }
6843         }
6844     }
6845 }
6846
6847 /*
6848 =for apidoc sv_2io
6849
6850 Using various gambits, try to get an IO from an SV: the IO slot if its a
6851 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6852 named after the PV if we're a string.
6853
6854 =cut
6855 */
6856
6857 IO*
6858 Perl_sv_2io(pTHX_ SV *sv)
6859 {
6860     IO* io;
6861     GV* gv;
6862     STRLEN n_a;
6863
6864     switch (SvTYPE(sv)) {
6865     case SVt_PVIO:
6866         io = (IO*)sv;
6867         break;
6868     case SVt_PVGV:
6869         gv = (GV*)sv;
6870         io = GvIO(gv);
6871         if (!io)
6872             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6873         break;
6874     default:
6875         if (!SvOK(sv))
6876             Perl_croak(aTHX_ PL_no_usym, "filehandle");
6877         if (SvROK(sv))
6878             return sv_2io(SvRV(sv));
6879         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6880         if (gv)
6881             io = GvIO(gv);
6882         else
6883             io = 0;
6884         if (!io)
6885             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6886         break;
6887     }
6888     return io;
6889 }
6890
6891 /*
6892 =for apidoc sv_2cv
6893
6894 Using various gambits, try to get a CV from an SV; in addition, try if
6895 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6896
6897 =cut
6898 */
6899
6900 CV *
6901 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6902 {
6903     GV *gv = Nullgv;
6904     CV *cv = Nullcv;
6905     STRLEN n_a;
6906
6907     if (!sv)
6908         return *gvp = Nullgv, Nullcv;
6909     switch (SvTYPE(sv)) {
6910     case SVt_PVCV:
6911         *st = CvSTASH(sv);
6912         *gvp = Nullgv;
6913         return (CV*)sv;
6914     case SVt_PVHV:
6915     case SVt_PVAV:
6916         *gvp = Nullgv;
6917         return Nullcv;
6918     case SVt_PVGV:
6919         gv = (GV*)sv;
6920         *gvp = gv;
6921         *st = GvESTASH(gv);
6922         goto fix_gv;
6923
6924     default:
6925         if (SvGMAGICAL(sv))
6926             mg_get(sv);
6927         if (SvROK(sv)) {
6928             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
6929             tryAMAGICunDEREF(to_cv);
6930
6931             sv = SvRV(sv);
6932             if (SvTYPE(sv) == SVt_PVCV) {
6933                 cv = (CV*)sv;
6934                 *gvp = Nullgv;
6935                 *st = CvSTASH(cv);
6936                 return cv;
6937             }
6938             else if(isGV(sv))
6939                 gv = (GV*)sv;
6940             else
6941                 Perl_croak(aTHX_ "Not a subroutine reference");
6942         }
6943         else if (isGV(sv))
6944             gv = (GV*)sv;
6945         else
6946             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6947         *gvp = gv;
6948         if (!gv)
6949             return Nullcv;
6950         *st = GvESTASH(gv);
6951     fix_gv:
6952         if (lref && !GvCVu(gv)) {
6953             SV *tmpsv;
6954             ENTER;
6955             tmpsv = NEWSV(704,0);
6956             gv_efullname3(tmpsv, gv, Nullch);
6957             /* XXX this is probably not what they think they're getting.
6958              * It has the same effect as "sub name;", i.e. just a forward
6959              * declaration! */
6960             newSUB(start_subparse(FALSE, 0),
6961                    newSVOP(OP_CONST, 0, tmpsv),
6962                    Nullop,
6963                    Nullop);
6964             LEAVE;
6965             if (!GvCVu(gv))
6966                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6967         }
6968         return GvCVu(gv);
6969     }
6970 }
6971
6972 /*
6973 =for apidoc sv_true
6974
6975 Returns true if the SV has a true value by Perl's rules.
6976 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6977 instead use an in-line version.
6978
6979 =cut
6980 */
6981
6982 I32
6983 Perl_sv_true(pTHX_ register SV *sv)
6984 {
6985     if (!sv)
6986         return 0;
6987     if (SvPOK(sv)) {
6988         register XPV* tXpv;
6989         if ((tXpv = (XPV*)SvANY(sv)) &&
6990                 (tXpv->xpv_cur > 1 ||
6991                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6992             return 1;
6993         else
6994             return 0;
6995     }
6996     else {
6997         if (SvIOK(sv))
6998             return SvIVX(sv) != 0;
6999         else {
7000             if (SvNOK(sv))
7001                 return SvNVX(sv) != 0.0;
7002             else
7003                 return sv_2bool(sv);
7004         }
7005     }
7006 }
7007
7008 /*
7009 =for apidoc sv_iv
7010
7011 A private implementation of the C<SvIVx> macro for compilers which can't
7012 cope with complex macro expressions. Always use the macro instead.
7013
7014 =cut
7015 */
7016
7017 IV
7018 Perl_sv_iv(pTHX_ register SV *sv)
7019 {
7020     if (SvIOK(sv)) {
7021         if (SvIsUV(sv))
7022             return (IV)SvUVX(sv);
7023         return SvIVX(sv);
7024     }
7025     return sv_2iv(sv);
7026 }
7027
7028 /*
7029 =for apidoc sv_uv
7030
7031 A private implementation of the C<SvUVx> macro for compilers which can't
7032 cope with complex macro expressions. Always use the macro instead.
7033
7034 =cut
7035 */
7036
7037 UV
7038 Perl_sv_uv(pTHX_ register SV *sv)
7039 {
7040     if (SvIOK(sv)) {
7041         if (SvIsUV(sv))
7042             return SvUVX(sv);
7043         return (UV)SvIVX(sv);
7044     }
7045     return sv_2uv(sv);
7046 }
7047
7048 /*
7049 =for apidoc sv_nv
7050
7051 A private implementation of the C<SvNVx> macro for compilers which can't
7052 cope with complex macro expressions. Always use the macro instead.
7053
7054 =cut
7055 */
7056
7057 NV
7058 Perl_sv_nv(pTHX_ register SV *sv)
7059 {
7060     if (SvNOK(sv))
7061         return SvNVX(sv);
7062     return sv_2nv(sv);
7063 }
7064
7065 /*
7066 =for apidoc sv_pv
7067
7068 Use the C<SvPV_nolen> macro instead
7069
7070 =for apidoc sv_pvn
7071
7072 A private implementation of the C<SvPV> macro for compilers which can't
7073 cope with complex macro expressions. Always use the macro instead.
7074
7075 =cut
7076 */
7077
7078 char *
7079 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7080 {
7081     if (SvPOK(sv)) {
7082         *lp = SvCUR(sv);
7083         return SvPVX(sv);
7084     }
7085     return sv_2pv(sv, lp);
7086 }
7087
7088
7089 char *
7090 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7091 {
7092     if (SvPOK(sv)) {
7093         *lp = SvCUR(sv);
7094         return SvPVX(sv);
7095     }
7096     return sv_2pv_flags(sv, lp, 0);
7097 }
7098
7099 /*
7100 =for apidoc sv_pvn_force
7101
7102 Get a sensible string out of the SV somehow.
7103 A private implementation of the C<SvPV_force> macro for compilers which
7104 can't cope with complex macro expressions. Always use the macro instead.
7105
7106 =for apidoc sv_pvn_force_flags
7107
7108 Get a sensible string out of the SV somehow.
7109 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7110 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7111 implemented in terms of this function.
7112 You normally want to use the various wrapper macros instead: see
7113 C<SvPV_force> and C<SvPV_force_nomg>
7114
7115 =cut
7116 */
7117
7118 char *
7119 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7120 {
7121     char *s = NULL;
7122
7123     if (SvTHINKFIRST(sv) && !SvROK(sv))
7124         sv_force_normal_flags(sv, 0);
7125
7126     if (SvPOK(sv)) {
7127         *lp = SvCUR(sv);
7128     }
7129     else {
7130         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
7131             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7132                 OP_NAME(PL_op));
7133         }
7134         else
7135             s = sv_2pv_flags(sv, lp, flags);
7136         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
7137             STRLEN len = *lp;
7138
7139             if (SvROK(sv))
7140                 sv_unref(sv);
7141             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
7142             SvGROW(sv, len + 1);
7143             Move(s,SvPVX(sv),len,char);
7144             SvCUR_set(sv, len);
7145             *SvEND(sv) = '\0';
7146         }
7147         if (!SvPOK(sv)) {
7148             SvPOK_on(sv);               /* validate pointer */
7149             SvTAINT(sv);
7150             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7151                                   PTR2UV(sv),SvPVX(sv)));
7152         }
7153     }
7154     return SvPVX(sv);
7155 }
7156
7157 /*
7158 =for apidoc sv_pvbyte
7159
7160 Use C<SvPVbyte_nolen> instead.
7161
7162 =for apidoc sv_pvbyten
7163
7164 A private implementation of the C<SvPVbyte> macro for compilers
7165 which can't cope with complex macro expressions. Always use the macro
7166 instead.
7167
7168 =cut
7169 */
7170
7171 char *
7172 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7173 {
7174     sv_utf8_downgrade(sv,0);
7175     return sv_pvn(sv,lp);
7176 }
7177
7178 /*
7179 =for apidoc sv_pvbyten_force
7180
7181 A private implementation of the C<SvPVbytex_force> macro for compilers
7182 which can't cope with complex macro expressions. Always use the macro
7183 instead.
7184
7185 =cut
7186 */
7187
7188 char *
7189 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7190 {
7191     sv_utf8_downgrade(sv,0);
7192     return sv_pvn_force(sv,lp);
7193 }
7194
7195 /*
7196 =for apidoc sv_pvutf8
7197
7198 Use the C<SvPVutf8_nolen> macro instead
7199
7200 =for apidoc sv_pvutf8n
7201
7202 A private implementation of the C<SvPVutf8> macro for compilers
7203 which can't cope with complex macro expressions. Always use the macro
7204 instead.
7205
7206 =cut
7207 */
7208
7209 char *
7210 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
7211 {
7212     sv_utf8_upgrade(sv);
7213     return sv_pvn(sv,lp);
7214 }
7215
7216 /*
7217 =for apidoc sv_pvutf8n_force
7218
7219 A private implementation of the C<SvPVutf8_force> macro for compilers
7220 which can't cope with complex macro expressions. Always use the macro
7221 instead.
7222
7223 =cut
7224 */
7225
7226 char *
7227 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7228 {
7229     sv_utf8_upgrade(sv);
7230     return sv_pvn_force(sv,lp);
7231 }
7232
7233 /*
7234 =for apidoc sv_reftype
7235
7236 Returns a string describing what the SV is a reference to.
7237
7238 =cut
7239 */
7240
7241 char *
7242 Perl_sv_reftype(pTHX_ SV *sv, int ob)
7243 {
7244     if (ob && SvOBJECT(sv)) {
7245         return HvNAME(SvSTASH(sv));
7246     }
7247     else {
7248         switch (SvTYPE(sv)) {
7249         case SVt_NULL:
7250         case SVt_IV:
7251         case SVt_NV:
7252         case SVt_RV:
7253         case SVt_PV:
7254         case SVt_PVIV:
7255         case SVt_PVNV:
7256         case SVt_PVMG:
7257         case SVt_PVBM:
7258                                 if (SvVOK(sv))
7259                                     return "VSTRING";
7260                                 if (SvROK(sv))
7261                                     return "REF";
7262                                 else
7263                                     return "SCALAR";
7264         case SVt_PVLV:          return "LVALUE";
7265         case SVt_PVAV:          return "ARRAY";
7266         case SVt_PVHV:          return "HASH";
7267         case SVt_PVCV:          return "CODE";
7268         case SVt_PVGV:          return "GLOB";
7269         case SVt_PVFM:          return "FORMAT";
7270         case SVt_PVIO:          return "IO";
7271         default:                return "UNKNOWN";
7272         }
7273     }
7274 }
7275
7276 /*
7277 =for apidoc sv_isobject
7278
7279 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7280 object.  If the SV is not an RV, or if the object is not blessed, then this
7281 will return false.
7282
7283 =cut
7284 */
7285
7286 int
7287 Perl_sv_isobject(pTHX_ SV *sv)
7288 {
7289     if (!sv)
7290         return 0;
7291     if (SvGMAGICAL(sv))
7292         mg_get(sv);
7293     if (!SvROK(sv))
7294         return 0;
7295     sv = (SV*)SvRV(sv);
7296     if (!SvOBJECT(sv))
7297         return 0;
7298     return 1;
7299 }
7300
7301 /*
7302 =for apidoc sv_isa
7303
7304 Returns a boolean indicating whether the SV is blessed into the specified
7305 class.  This does not check for subtypes; use C<sv_derived_from> to verify
7306 an inheritance relationship.
7307
7308 =cut
7309 */
7310
7311 int
7312 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7313 {
7314     if (!sv)
7315         return 0;
7316     if (SvGMAGICAL(sv))
7317         mg_get(sv);
7318     if (!SvROK(sv))
7319         return 0;
7320     sv = (SV*)SvRV(sv);
7321     if (!SvOBJECT(sv))
7322         return 0;
7323
7324     return strEQ(HvNAME(SvSTASH(sv)), name);
7325 }
7326
7327 /*
7328 =for apidoc newSVrv
7329
7330 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
7331 it will be upgraded to one.  If C<classname> is non-null then the new SV will
7332 be blessed in the specified package.  The new SV is returned and its
7333 reference count is 1.
7334
7335 =cut
7336 */
7337
7338 SV*
7339 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7340 {
7341     SV *sv;
7342
7343     new_SV(sv);
7344
7345     SV_CHECK_THINKFIRST_COW_DROP(rv);
7346     SvAMAGIC_off(rv);
7347
7348     if (SvTYPE(rv) >= SVt_PVMG) {
7349         U32 refcnt = SvREFCNT(rv);
7350         SvREFCNT(rv) = 0;
7351         sv_clear(rv);
7352         SvFLAGS(rv) = 0;
7353         SvREFCNT(rv) = refcnt;
7354     }
7355
7356     if (SvTYPE(rv) < SVt_RV)
7357         sv_upgrade(rv, SVt_RV);
7358     else if (SvTYPE(rv) > SVt_RV) {
7359         (void)SvOOK_off(rv);
7360         if (SvPVX(rv) && SvLEN(rv))
7361             Safefree(SvPVX(rv));
7362         SvCUR_set(rv, 0);
7363         SvLEN_set(rv, 0);
7364     }
7365
7366     (void)SvOK_off(rv);
7367     SvRV(rv) = sv;
7368     SvROK_on(rv);
7369
7370     if (classname) {
7371         HV* stash = gv_stashpv(classname, TRUE);
7372         (void)sv_bless(rv, stash);
7373     }
7374     return sv;
7375 }
7376
7377 /*
7378 =for apidoc sv_setref_pv
7379
7380 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
7381 argument will be upgraded to an RV.  That RV will be modified to point to
7382 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7383 into the SV.  The C<classname> argument indicates the package for the
7384 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7385 will be returned and will have a reference count of 1.
7386
7387 Do not use with other Perl types such as HV, AV, SV, CV, because those
7388 objects will become corrupted by the pointer copy process.
7389
7390 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7391
7392 =cut
7393 */
7394
7395 SV*
7396 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7397 {
7398     if (!pv) {
7399         sv_setsv(rv, &PL_sv_undef);
7400         SvSETMAGIC(rv);
7401     }
7402     else
7403         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7404     return rv;
7405 }
7406
7407 /*
7408 =for apidoc sv_setref_iv
7409
7410 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
7411 argument will be upgraded to an RV.  That RV will be modified to point to
7412 the new SV.  The C<classname> argument indicates the package for the
7413 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7414 will be returned and will have a reference count of 1.
7415
7416 =cut
7417 */
7418
7419 SV*
7420 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7421 {
7422     sv_setiv(newSVrv(rv,classname), iv);
7423     return rv;
7424 }
7425
7426 /*
7427 =for apidoc sv_setref_uv
7428
7429 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
7430 argument will be upgraded to an RV.  That RV will be modified to point to
7431 the new SV.  The C<classname> argument indicates the package for the
7432 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7433 will be returned and will have a reference count of 1.
7434
7435 =cut
7436 */
7437
7438 SV*
7439 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7440 {
7441     sv_setuv(newSVrv(rv,classname), uv);
7442     return rv;
7443 }
7444
7445 /*
7446 =for apidoc sv_setref_nv
7447
7448 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
7449 argument will be upgraded to an RV.  That RV will be modified to point to
7450 the new SV.  The C<classname> argument indicates the package for the
7451 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7452 will be returned and will have a reference count of 1.
7453
7454 =cut
7455 */
7456
7457 SV*
7458 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7459 {
7460     sv_setnv(newSVrv(rv,classname), nv);
7461     return rv;
7462 }
7463
7464 /*
7465 =for apidoc sv_setref_pvn
7466
7467 Copies a string into a new SV, optionally blessing the SV.  The length of the
7468 string must be specified with C<n>.  The C<rv> argument will be upgraded to
7469 an RV.  That RV will be modified to point to the new SV.  The C<classname>
7470 argument indicates the package for the blessing.  Set C<classname> to
7471 C<Nullch> to avoid the blessing.  The new SV will be returned and will have
7472 a reference count of 1.
7473
7474 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7475
7476 =cut
7477 */
7478
7479 SV*
7480 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7481 {
7482     sv_setpvn(newSVrv(rv,classname), pv, n);
7483     return rv;
7484 }
7485
7486 /*
7487 =for apidoc sv_bless
7488
7489 Blesses an SV into a specified package.  The SV must be an RV.  The package
7490 must be designated by its stash (see C<gv_stashpv()>).  The reference count
7491 of the SV is unaffected.
7492
7493 =cut
7494 */
7495
7496 SV*
7497 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7498 {
7499     SV *tmpRef;
7500     if (!SvROK(sv))
7501         Perl_croak(aTHX_ "Can't bless non-reference value");
7502     tmpRef = SvRV(sv);
7503     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7504         if (SvREADONLY(tmpRef))
7505             Perl_croak(aTHX_ PL_no_modify);
7506         if (SvOBJECT(tmpRef)) {
7507             if (SvTYPE(tmpRef) != SVt_PVIO)
7508                 --PL_sv_objcount;
7509             SvREFCNT_dec(SvSTASH(tmpRef));
7510         }
7511     }
7512     SvOBJECT_on(tmpRef);
7513     if (SvTYPE(tmpRef) != SVt_PVIO)
7514         ++PL_sv_objcount;
7515     (void)SvUPGRADE(tmpRef, SVt_PVMG);
7516     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7517
7518     if (Gv_AMG(stash))
7519         SvAMAGIC_on(sv);
7520     else
7521         SvAMAGIC_off(sv);
7522
7523     if(SvSMAGICAL(tmpRef))
7524         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7525             mg_set(tmpRef);
7526
7527
7528
7529     return sv;
7530 }
7531
7532 /* Downgrades a PVGV to a PVMG.
7533  */
7534
7535 STATIC void
7536 S_sv_unglob(pTHX_ SV *sv)
7537 {
7538     void *xpvmg;
7539
7540     assert(SvTYPE(sv) == SVt_PVGV);
7541     SvFAKE_off(sv);
7542     if (GvGP(sv))
7543         gp_free((GV*)sv);
7544     if (GvSTASH(sv)) {
7545         SvREFCNT_dec(GvSTASH(sv));
7546         GvSTASH(sv) = Nullhv;
7547     }
7548     sv_unmagic(sv, PERL_MAGIC_glob);
7549     Safefree(GvNAME(sv));
7550     GvMULTI_off(sv);
7551
7552     /* need to keep SvANY(sv) in the right arena */
7553     xpvmg = new_XPVMG();
7554     StructCopy(SvANY(sv), xpvmg, XPVMG);
7555     del_XPVGV(SvANY(sv));
7556     SvANY(sv) = xpvmg;
7557
7558     SvFLAGS(sv) &= ~SVTYPEMASK;
7559     SvFLAGS(sv) |= SVt_PVMG;
7560 }
7561
7562 /*
7563 =for apidoc sv_unref_flags
7564
7565 Unsets the RV status of the SV, and decrements the reference count of
7566 whatever was being referenced by the RV.  This can almost be thought of
7567 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
7568 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7569 (otherwise the decrementing is conditional on the reference count being
7570 different from one or the reference being a readonly SV).
7571 See C<SvROK_off>.
7572
7573 =cut
7574 */
7575
7576 void
7577 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7578 {
7579     SV* rv = SvRV(sv);
7580
7581     if (SvWEAKREF(sv)) {
7582         sv_del_backref(sv);
7583         SvWEAKREF_off(sv);
7584         SvRV(sv) = 0;
7585         return;
7586     }
7587     SvRV(sv) = 0;
7588     SvROK_off(sv);
7589     if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || (flags & SV_IMMEDIATE_UNREF))
7590         SvREFCNT_dec(rv);
7591     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7592         sv_2mortal(rv);         /* Schedule for freeing later */
7593 }
7594
7595 /*
7596 =for apidoc sv_unref
7597
7598 Unsets the RV status of the SV, and decrements the reference count of
7599 whatever was being referenced by the RV.  This can almost be thought of
7600 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
7601 being zero.  See C<SvROK_off>.
7602
7603 =cut
7604 */
7605
7606 void
7607 Perl_sv_unref(pTHX_ SV *sv)
7608 {
7609     sv_unref_flags(sv, 0);
7610 }
7611
7612 /*
7613 =for apidoc sv_taint
7614
7615 Taint an SV. Use C<SvTAINTED_on> instead.
7616 =cut
7617 */
7618
7619 void
7620 Perl_sv_taint(pTHX_ SV *sv)
7621 {
7622     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7623 }
7624
7625 /*
7626 =for apidoc sv_untaint
7627
7628 Untaint an SV. Use C<SvTAINTED_off> instead.
7629 =cut
7630 */
7631
7632 void
7633 Perl_sv_untaint(pTHX_ SV *sv)
7634 {
7635     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7636         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7637         if (mg)
7638             mg->mg_len &= ~1;
7639     }
7640 }
7641
7642 /*
7643 =for apidoc sv_tainted
7644
7645 Test an SV for taintedness. Use C<SvTAINTED> instead.
7646 =cut
7647 */
7648
7649 bool
7650 Perl_sv_tainted(pTHX_ SV *sv)
7651 {
7652     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7653         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7654         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7655             return TRUE;
7656     }
7657     return FALSE;
7658 }
7659
7660 #if defined(PERL_IMPLICIT_CONTEXT)
7661
7662 /* pTHX_ magic can't cope with varargs, so this is a no-context
7663  * version of the main function, (which may itself be aliased to us).
7664  * Don't access this version directly.
7665  */
7666
7667 void
7668 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7669 {
7670     dTHX;
7671     va_list args;
7672     va_start(args, pat);
7673     sv_vsetpvf(sv, pat, &args);
7674     va_end(args);
7675 }
7676
7677 /* pTHX_ magic can't cope with varargs, so this is a no-context
7678  * version of the main function, (which may itself be aliased to us).
7679  * Don't access this version directly.
7680  */
7681
7682 void
7683 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7684 {
7685     dTHX;
7686     va_list args;
7687     va_start(args, pat);
7688     sv_vsetpvf_mg(sv, pat, &args);
7689     va_end(args);
7690 }
7691 #endif
7692
7693 /*
7694 =for apidoc sv_setpvf
7695
7696 Processes its arguments like C<sprintf> and sets an SV to the formatted
7697 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
7698
7699 =cut
7700 */
7701
7702 void
7703 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7704 {
7705     va_list args;
7706     va_start(args, pat);
7707     sv_vsetpvf(sv, pat, &args);
7708     va_end(args);
7709 }
7710
7711 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7712
7713 void
7714 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7715 {
7716     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7717 }
7718
7719 /*
7720 =for apidoc sv_setpvf_mg
7721
7722 Like C<sv_setpvf>, but also handles 'set' magic.
7723
7724 =cut
7725 */
7726
7727 void
7728 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7729 {
7730     va_list args;
7731     va_start(args, pat);
7732     sv_vsetpvf_mg(sv, pat, &args);
7733     va_end(args);
7734 }
7735
7736 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7737
7738 void
7739 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7740 {
7741     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7742     SvSETMAGIC(sv);
7743 }
7744
7745 #if defined(PERL_IMPLICIT_CONTEXT)
7746
7747 /* pTHX_ magic can't cope with varargs, so this is a no-context
7748  * version of the main function, (which may itself be aliased to us).
7749  * Don't access this version directly.
7750  */
7751
7752 void
7753 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7754 {
7755     dTHX;
7756     va_list args;
7757     va_start(args, pat);
7758     sv_vcatpvf(sv, pat, &args);
7759     va_end(args);
7760 }
7761
7762 /* pTHX_ magic can't cope with varargs, so this is a no-context
7763  * version of the main function, (which may itself be aliased to us).
7764  * Don't access this version directly.
7765  */
7766
7767 void
7768 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7769 {
7770     dTHX;
7771     va_list args;
7772     va_start(args, pat);
7773     sv_vcatpvf_mg(sv, pat, &args);
7774     va_end(args);
7775 }
7776 #endif
7777
7778 /*
7779 =for apidoc sv_catpvf
7780
7781 Processes its arguments like C<sprintf> and appends the formatted
7782 output to an SV.  If the appended data contains "wide" characters
7783 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7784 and characters >255 formatted with %c), the original SV might get
7785 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.
7786 C<SvSETMAGIC()> must typically be called after calling this function
7787 to handle 'set' magic.
7788
7789 =cut */
7790
7791 void
7792 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7793 {
7794     va_list args;
7795     va_start(args, pat);
7796     sv_vcatpvf(sv, pat, &args);
7797     va_end(args);
7798 }
7799
7800 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7801
7802 void
7803 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7804 {
7805     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7806 }
7807
7808 /*
7809 =for apidoc sv_catpvf_mg
7810
7811 Like C<sv_catpvf>, but also handles 'set' magic.
7812
7813 =cut
7814 */
7815
7816 void
7817 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7818 {
7819     va_list args;
7820     va_start(args, pat);
7821     sv_vcatpvf_mg(sv, pat, &args);
7822     va_end(args);
7823 }
7824
7825 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7826
7827 void
7828 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7829 {
7830     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7831     SvSETMAGIC(sv);
7832 }
7833
7834 /*
7835 =for apidoc sv_vsetpvfn
7836
7837 Works like C<vcatpvfn> but copies the text into the SV instead of
7838 appending it.
7839
7840 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7841
7842 =cut
7843 */
7844
7845 void
7846 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7847 {
7848     sv_setpvn(sv, "", 0);
7849     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7850 }
7851
7852 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7853
7854 STATIC I32
7855 S_expect_number(pTHX_ char** pattern)
7856 {
7857     I32 var = 0;
7858     switch (**pattern) {
7859     case '1': case '2': case '3':
7860     case '4': case '5': case '6':
7861     case '7': case '8': case '9':
7862         while (isDIGIT(**pattern))
7863             var = var * 10 + (*(*pattern)++ - '0');
7864     }
7865     return var;
7866 }
7867 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7868
7869 /*
7870 =for apidoc sv_vcatpvfn
7871
7872 Processes its arguments like C<vsprintf> and appends the formatted output
7873 to an SV.  Uses an array of SVs if the C style variable argument list is
7874 missing (NULL).  When running with taint checks enabled, indicates via
7875 C<maybe_tainted> if results are untrustworthy (often due to the use of
7876 locales).
7877
7878 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7879
7880 =cut
7881 */
7882
7883 void
7884 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7885 {
7886     char *p;
7887     char *q;
7888     char *patend;
7889     STRLEN origlen;
7890     I32 svix = 0;
7891     static char nullstr[] = "(null)";
7892     SV *argsv = Nullsv;
7893     bool has_utf8 = FALSE; /* has the result utf8? */
7894
7895     /* no matter what, this is a string now */
7896     (void)SvPV_force(sv, origlen);
7897
7898     /* special-case "", "%s", and "%_" */
7899     if (patlen == 0)
7900         return;
7901     if (patlen == 2 && pat[0] == '%') {
7902         switch (pat[1]) {
7903         case 's':
7904             if (args) {
7905                 char *s = va_arg(*args, char*);
7906                 sv_catpv(sv, s ? s : nullstr);
7907             }
7908             else if (svix < svmax) {
7909                 sv_catsv(sv, *svargs);
7910                 if (DO_UTF8(*svargs))
7911                     SvUTF8_on(sv);
7912             }
7913             return;
7914         case '_':
7915             if (args) {
7916                 argsv = va_arg(*args, SV*);
7917                 sv_catsv(sv, argsv);
7918                 if (DO_UTF8(argsv))
7919                     SvUTF8_on(sv);
7920                 return;
7921             }
7922             /* See comment on '_' below */
7923             break;
7924         }
7925     }
7926
7927     if (!args && svix < svmax && DO_UTF8(*svargs))
7928         has_utf8 = TRUE;
7929
7930     patend = (char*)pat + patlen;
7931     for (p = (char*)pat; p < patend; p = q) {
7932         bool alt = FALSE;
7933         bool left = FALSE;
7934         bool vectorize = FALSE;
7935         bool vectorarg = FALSE;
7936         bool vec_utf8 = FALSE;
7937         char fill = ' ';
7938         char plus = 0;
7939         char intsize = 0;
7940         STRLEN width = 0;
7941         STRLEN zeros = 0;
7942         bool has_precis = FALSE;
7943         STRLEN precis = 0;
7944         bool is_utf8 = FALSE;  /* is this item utf8?   */
7945 #ifdef HAS_LDBL_SPRINTF_BUG
7946         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
7947            with sfio - Allen <allens@cpan.org> */
7948         bool fix_ldbl_sprintf_bug = FALSE;
7949 #endif
7950
7951         char esignbuf[4];
7952         U8 utf8buf[UTF8_MAXLEN+1];
7953         STRLEN esignlen = 0;
7954
7955         char *eptr = Nullch;
7956         STRLEN elen = 0;
7957         /* Times 4: a decimal digit takes more than 3 binary digits.
7958          * NV_DIG: mantissa takes than many decimal digits.
7959          * Plus 32: Playing safe. */
7960         char ebuf[IV_DIG * 4 + NV_DIG + 32];
7961         /* large enough for "%#.#f" --chip */
7962         /* what about long double NVs? --jhi */
7963
7964         SV *vecsv = Nullsv;
7965         U8 *vecstr = Null(U8*);
7966         STRLEN veclen = 0;
7967         char c = 0;
7968         int i;
7969         unsigned base = 0;
7970         IV iv = 0;
7971         UV uv = 0;
7972         /* we need a long double target in case HAS_LONG_DOUBLE but
7973            not USE_LONG_DOUBLE
7974         */
7975 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
7976         long double nv;
7977 #else
7978         NV nv;
7979 #endif
7980         STRLEN have;
7981         STRLEN need;
7982         STRLEN gap;
7983         char *dotstr = ".";
7984         STRLEN dotstrlen = 1;
7985         I32 efix = 0; /* explicit format parameter index */
7986         I32 ewix = 0; /* explicit width index */
7987         I32 epix = 0; /* explicit precision index */
7988         I32 evix = 0; /* explicit vector index */
7989         bool asterisk = FALSE;
7990
7991         /* echo everything up to the next format specification */
7992         for (q = p; q < patend && *q != '%'; ++q) ;
7993         if (q > p) {
7994             sv_catpvn(sv, p, q - p);
7995             p = q;
7996         }
7997         if (q++ >= patend)
7998             break;
7999
8000 /*
8001     We allow format specification elements in this order:
8002         \d+\$              explicit format parameter index
8003         [-+ 0#]+           flags
8004         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
8005         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
8006         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8007         [hlqLV]            size
8008     [%bcdefginopsux_DFOUX] format (mandatory)
8009 */
8010         if (EXPECT_NUMBER(q, width)) {
8011             if (*q == '$') {
8012                 ++q;
8013                 efix = width;
8014             } else {
8015                 goto gotwidth;
8016             }
8017         }
8018
8019         /* FLAGS */
8020
8021         while (*q) {
8022             switch (*q) {
8023             case ' ':
8024             case '+':
8025                 plus = *q++;
8026                 continue;
8027
8028             case '-':
8029                 left = TRUE;
8030                 q++;
8031                 continue;
8032
8033             case '0':
8034                 fill = *q++;
8035                 continue;
8036
8037             case '#':
8038                 alt = TRUE;
8039                 q++;
8040                 continue;
8041
8042             default:
8043                 break;
8044             }
8045             break;
8046         }
8047
8048       tryasterisk:
8049         if (*q == '*') {
8050             q++;
8051             if (EXPECT_NUMBER(q, ewix))
8052                 if (*q++ != '$')
8053                     goto unknown;
8054             asterisk = TRUE;
8055         }
8056         if (*q == 'v') {
8057             q++;
8058             if (vectorize)
8059                 goto unknown;
8060             if ((vectorarg = asterisk)) {
8061                 evix = ewix;
8062                 ewix = 0;
8063                 asterisk = FALSE;
8064             }
8065             vectorize = TRUE;
8066             goto tryasterisk;
8067         }
8068
8069         if (!asterisk)
8070             EXPECT_NUMBER(q, width);
8071
8072         if (vectorize) {
8073             if (vectorarg) {
8074                 if (args)
8075                     vecsv = va_arg(*args, SV*);
8076                 else
8077                     vecsv = (evix ? evix <= svmax : svix < svmax) ?
8078                         svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
8079                 dotstr = SvPVx(vecsv, dotstrlen);
8080                 if (DO_UTF8(vecsv))
8081                     is_utf8 = TRUE;
8082             }
8083             if (args) {
8084                 vecsv = va_arg(*args, SV*);
8085                 vecstr = (U8*)SvPVx(vecsv,veclen);
8086                 vec_utf8 = DO_UTF8(vecsv);
8087             }
8088             else if (efix ? efix <= svmax : svix < svmax) {
8089                 vecsv = svargs[efix ? efix-1 : svix++];
8090                 vecstr = (U8*)SvPVx(vecsv,veclen);
8091                 vec_utf8 = DO_UTF8(vecsv);
8092             }
8093             else {
8094                 vecstr = (U8*)"";
8095                 veclen = 0;
8096             }
8097         }
8098
8099         if (asterisk) {
8100             if (args)
8101                 i = va_arg(*args, int);
8102             else
8103                 i = (ewix ? ewix <= svmax : svix < svmax) ?
8104                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8105             left |= (i < 0);
8106             width = (i < 0) ? -i : i;
8107         }
8108       gotwidth:
8109
8110         /* PRECISION */
8111
8112         if (*q == '.') {
8113             q++;
8114             if (*q == '*') {
8115                 q++;
8116                 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8117                     goto unknown;
8118                 /* XXX: todo, support specified precision parameter */
8119                 if (epix)
8120                     goto unknown;
8121                 if (args)
8122                     i = va_arg(*args, int);
8123                 else
8124                     i = (ewix ? ewix <= svmax : svix < svmax)
8125                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8126                 precis = (i < 0) ? 0 : i;
8127             }
8128             else {
8129                 precis = 0;
8130                 while (isDIGIT(*q))
8131                     precis = precis * 10 + (*q++ - '0');
8132             }
8133             has_precis = TRUE;
8134         }
8135
8136         /* SIZE */
8137
8138         switch (*q) {
8139 #ifdef WIN32
8140         case 'I':                       /* Ix, I32x, and I64x */
8141 #  ifdef WIN64
8142             if (q[1] == '6' && q[2] == '4') {
8143                 q += 3;
8144                 intsize = 'q';
8145                 break;
8146             }
8147 #  endif
8148             if (q[1] == '3' && q[2] == '2') {
8149                 q += 3;
8150                 break;
8151             }
8152 #  ifdef WIN64
8153             intsize = 'q';
8154 #  endif
8155             q++;
8156             break;
8157 #endif
8158 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8159         case 'L':                       /* Ld */
8160             /* FALL THROUGH */
8161 #ifdef HAS_QUAD
8162         case 'q':                       /* qd */
8163 #endif
8164             intsize = 'q';
8165             q++;
8166             break;
8167 #endif
8168         case 'l':
8169 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8170             if (*(q + 1) == 'l') {      /* lld, llf */
8171                 intsize = 'q';
8172                 q += 2;
8173                 break;
8174              }
8175 #endif
8176             /* FALL THROUGH */
8177         case 'h':
8178             /* FALL THROUGH */
8179         case 'V':
8180             intsize = *q++;
8181             break;
8182         }
8183
8184         /* CONVERSION */
8185
8186         if (*q == '%') {
8187             eptr = q++;
8188             elen = 1;
8189             goto string;
8190         }
8191
8192         if (vectorize)
8193             argsv = vecsv;
8194         else if (!args)
8195             argsv = (efix ? efix <= svmax : svix < svmax) ?
8196                     svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8197
8198         switch (c = *q++) {
8199
8200             /* STRINGS */
8201
8202         case 'c':
8203             uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8204             if ((uv > 255 ||
8205                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8206                 && !IN_BYTES) {
8207                 eptr = (char*)utf8buf;
8208                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8209                 is_utf8 = TRUE;
8210             }
8211             else {
8212                 c = (char)uv;
8213                 eptr = &c;
8214                 elen = 1;
8215             }
8216             goto string;
8217
8218         case 's':
8219             if (args && !vectorize) {
8220                 eptr = va_arg(*args, char*);
8221                 if (eptr)
8222 #ifdef MACOS_TRADITIONAL
8223                   /* On MacOS, %#s format is used for Pascal strings */
8224                   if (alt)
8225                     elen = *eptr++;
8226                   else
8227 #endif
8228                     elen = strlen(eptr);
8229                 else {
8230                     eptr = nullstr;
8231                     elen = sizeof nullstr - 1;
8232                 }
8233             }
8234             else {
8235                 eptr = SvPVx(argsv, elen);
8236                 if (DO_UTF8(argsv)) {
8237                     if (has_precis && precis < elen) {
8238                         I32 p = precis;
8239                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8240                         precis = p;
8241                     }
8242                     if (width) { /* fudge width (can't fudge elen) */
8243                         width += elen - sv_len_utf8(argsv);
8244                     }
8245                     is_utf8 = TRUE;
8246                 }
8247             }
8248             goto string;
8249
8250         case '_':
8251             /*
8252              * The "%_" hack might have to be changed someday,
8253              * if ISO or ANSI decide to use '_' for something.
8254              * So we keep it hidden from users' code.
8255              */
8256             if (!args || vectorize)
8257                 goto unknown;
8258             argsv = va_arg(*args, SV*);
8259             eptr = SvPVx(argsv, elen);
8260             if (DO_UTF8(argsv))
8261                 is_utf8 = TRUE;
8262
8263         string:
8264             vectorize = FALSE;
8265             if (has_precis && elen > precis)
8266                 elen = precis;
8267             break;
8268
8269             /* INTEGERS */
8270
8271         case 'p':
8272             if (alt || vectorize)
8273                 goto unknown;
8274             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8275             base = 16;
8276             goto integer;
8277
8278         case 'D':
8279 #ifdef IV_IS_QUAD
8280             intsize = 'q';
8281 #else
8282             intsize = 'l';
8283 #endif
8284             /* FALL THROUGH */
8285         case 'd':
8286         case 'i':
8287             if (vectorize) {
8288                 STRLEN ulen;
8289                 if (!veclen)
8290                     continue;
8291                 if (vec_utf8)
8292                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8293                                         UTF8_ALLOW_ANYUV);
8294                 else {
8295                     uv = *vecstr;
8296                     ulen = 1;
8297                 }
8298                 vecstr += ulen;
8299                 veclen -= ulen;
8300                 if (plus)
8301                      esignbuf[esignlen++] = plus;
8302             }
8303             else if (args) {
8304                 switch (intsize) {
8305                 case 'h':       iv = (short)va_arg(*args, int); break;
8306                 default:        iv = va_arg(*args, int); break;
8307                 case 'l':       iv = va_arg(*args, long); break;
8308                 case 'V':       iv = va_arg(*args, IV); break;
8309 #ifdef HAS_QUAD
8310                 case 'q':       iv = va_arg(*args, Quad_t); break;
8311 #endif
8312                 }
8313             }
8314             else {
8315                 iv = SvIVx(argsv);
8316                 switch (intsize) {
8317                 case 'h':       iv = (short)iv; break;
8318                 default:        break;
8319                 case 'l':       iv = (long)iv; break;
8320                 case 'V':       break;
8321 #ifdef HAS_QUAD
8322                 case 'q':       iv = (Quad_t)iv; break;
8323 #endif
8324                 }
8325             }
8326             if ( !vectorize )   /* we already set uv above */
8327             {
8328                 if (iv >= 0) {
8329                     uv = iv;
8330                     if (plus)
8331                         esignbuf[esignlen++] = plus;
8332                 }
8333                 else {
8334                     uv = -iv;
8335                     esignbuf[esignlen++] = '-';
8336                 }
8337             }
8338             base = 10;
8339             goto integer;
8340
8341         case 'U':
8342 #ifdef IV_IS_QUAD
8343             intsize = 'q';
8344 #else
8345             intsize = 'l';
8346 #endif
8347             /* FALL THROUGH */
8348         case 'u':
8349             base = 10;
8350             goto uns_integer;
8351
8352         case 'b':
8353             base = 2;
8354             goto uns_integer;
8355
8356         case 'O':
8357 #ifdef IV_IS_QUAD
8358             intsize = 'q';
8359 #else
8360             intsize = 'l';
8361 #endif
8362             /* FALL THROUGH */
8363         case 'o':
8364             base = 8;
8365             goto uns_integer;
8366
8367         case 'X':
8368         case 'x':
8369             base = 16;
8370
8371         uns_integer:
8372             if (vectorize) {
8373                 STRLEN ulen;
8374         vector:
8375                 if (!veclen)
8376                     continue;
8377                 if (vec_utf8)
8378                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8379                                         UTF8_ALLOW_ANYUV);
8380                 else {
8381                     uv = *vecstr;
8382                     ulen = 1;
8383                 }
8384                 vecstr += ulen;
8385                 veclen -= ulen;
8386             }
8387             else if (args) {
8388                 switch (intsize) {
8389                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
8390                 default:   uv = va_arg(*args, unsigned); break;
8391                 case 'l':  uv = va_arg(*args, unsigned long); break;
8392                 case 'V':  uv = va_arg(*args, UV); break;
8393 #ifdef HAS_QUAD
8394                 case 'q':  uv = va_arg(*args, Quad_t); break;
8395 #endif
8396                 }
8397             }
8398             else {
8399                 uv = SvUVx(argsv);
8400                 switch (intsize) {
8401                 case 'h':       uv = (unsigned short)uv; break;
8402                 default:        break;
8403                 case 'l':       uv = (unsigned long)uv; break;
8404                 case 'V':       break;
8405 #ifdef HAS_QUAD
8406                 case 'q':       uv = (Quad_t)uv; break;
8407 #endif
8408                 }
8409             }
8410
8411         integer:
8412             eptr = ebuf + sizeof ebuf;
8413             switch (base) {
8414                 unsigned dig;
8415             case 16:
8416                 if (!uv)
8417                     alt = FALSE;
8418                 p = (char*)((c == 'X')
8419                             ? "0123456789ABCDEF" : "0123456789abcdef");
8420                 do {
8421                     dig = uv & 15;
8422                     *--eptr = p[dig];
8423                 } while (uv >>= 4);
8424                 if (alt) {
8425                     esignbuf[esignlen++] = '0';
8426                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
8427                 }
8428                 break;
8429             case 8:
8430                 do {
8431                     dig = uv & 7;
8432                     *--eptr = '0' + dig;
8433                 } while (uv >>= 3);
8434                 if (alt && *eptr != '0')
8435                     *--eptr = '0';
8436                 break;
8437             case 2:
8438                 do {
8439                     dig = uv & 1;
8440                     *--eptr = '0' + dig;
8441                 } while (uv >>= 1);
8442                 if (alt) {
8443                     esignbuf[esignlen++] = '0';
8444                     esignbuf[esignlen++] = 'b';
8445                 }
8446                 break;
8447             default:            /* it had better be ten or less */
8448 #if defined(PERL_Y2KWARN)
8449                 if (ckWARN(WARN_Y2K)) {
8450                     STRLEN n;
8451                     char *s = SvPV(sv,n);
8452                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8453                         && (n == 2 || !isDIGIT(s[n-3])))
8454                     {
8455                         Perl_warner(aTHX_ packWARN(WARN_Y2K),
8456                                     "Possible Y2K bug: %%%c %s",
8457                                     c, "format string following '19'");
8458                     }
8459                 }
8460 #endif
8461                 do {
8462                     dig = uv % base;
8463                     *--eptr = '0' + dig;
8464                 } while (uv /= base);
8465                 break;
8466             }
8467             elen = (ebuf + sizeof ebuf) - eptr;
8468             if (has_precis) {
8469                 if (precis > elen)
8470                     zeros = precis - elen;
8471                 else if (precis == 0 && elen == 1 && *eptr == '0')
8472                     elen = 0;
8473             }
8474             break;
8475
8476             /* FLOATING POINT */
8477
8478         case 'F':
8479             c = 'f';            /* maybe %F isn't supported here */
8480             /* FALL THROUGH */
8481         case 'e': case 'E':
8482         case 'f':
8483         case 'g': case 'G':
8484
8485             /* This is evil, but floating point is even more evil */
8486
8487             /* for SV-style calling, we can only get NV
8488                for C-style calling, we assume %f is double;
8489                for simplicity we allow any of %Lf, %llf, %qf for long double
8490             */
8491             switch (intsize) {
8492             case 'V':
8493 #if defined(USE_LONG_DOUBLE)
8494                 intsize = 'q';
8495 #endif
8496                 break;
8497             default:
8498 #if defined(USE_LONG_DOUBLE)
8499                 intsize = args ? 0 : 'q';
8500 #endif
8501                 break;
8502             case 'q':
8503 #if defined(HAS_LONG_DOUBLE)
8504                 break;
8505 #else
8506                 /* FALL THROUGH */
8507 #endif
8508             case 'h':
8509                 /* FALL THROUGH */
8510             case 'l':
8511                 goto unknown;
8512             }
8513
8514             /* now we need (long double) if intsize == 'q', else (double) */
8515             nv = (args && !vectorize) ?
8516 #if LONG_DOUBLESIZE > DOUBLESIZE
8517                 intsize == 'q' ?
8518                     va_arg(*args, long double) :
8519                     va_arg(*args, double)
8520 #else
8521                     va_arg(*args, double)
8522 #endif
8523                 : SvNVx(argsv);
8524
8525             need = 0;
8526             vectorize = FALSE;
8527             if (c != 'e' && c != 'E') {
8528                 i = PERL_INT_MIN;
8529                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
8530                    will cast our (long double) to (double) */
8531                 (void)Perl_frexp(nv, &i);
8532                 if (i == PERL_INT_MIN)
8533                     Perl_die(aTHX_ "panic: frexp");
8534                 if (i > 0)
8535                     need = BIT_DIGITS(i);
8536             }
8537             need += has_precis ? precis : 6; /* known default */
8538
8539             if (need < width)
8540                 need = width;
8541
8542 #ifdef HAS_LDBL_SPRINTF_BUG
8543             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8544                with sfio - Allen <allens@cpan.org> */
8545
8546 #  ifdef DBL_MAX
8547 #    define MY_DBL_MAX DBL_MAX
8548 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
8549 #    if DOUBLESIZE >= 8
8550 #      define MY_DBL_MAX 1.7976931348623157E+308L
8551 #    else
8552 #      define MY_DBL_MAX 3.40282347E+38L
8553 #    endif
8554 #  endif
8555
8556 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
8557 #    define MY_DBL_MAX_BUG 1L
8558 #  else
8559 #    define MY_DBL_MAX_BUG MY_DBL_MAX
8560 #  endif
8561
8562 #  ifdef DBL_MIN
8563 #    define MY_DBL_MIN DBL_MIN
8564 #  else  /* XXX guessing! -Allen */
8565 #    if DOUBLESIZE >= 8
8566 #      define MY_DBL_MIN 2.2250738585072014E-308L
8567 #    else
8568 #      define MY_DBL_MIN 1.17549435E-38L
8569 #    endif
8570 #  endif
8571
8572             if ((intsize == 'q') && (c == 'f') &&
8573                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
8574                 (need < DBL_DIG)) {
8575                 /* it's going to be short enough that
8576                  * long double precision is not needed */
8577
8578                 if ((nv <= 0L) && (nv >= -0L))
8579                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
8580                 else {
8581                     /* would use Perl_fp_class as a double-check but not
8582                      * functional on IRIX - see perl.h comments */
8583
8584                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
8585                         /* It's within the range that a double can represent */
8586 #if defined(DBL_MAX) && !defined(DBL_MIN)
8587                         if ((nv >= ((long double)1/DBL_MAX)) ||
8588                             (nv <= (-(long double)1/DBL_MAX)))
8589 #endif
8590                         fix_ldbl_sprintf_bug = TRUE;
8591                     }
8592                 }
8593                 if (fix_ldbl_sprintf_bug == TRUE) {
8594                     double temp;
8595
8596                     intsize = 0;
8597                     temp = (double)nv;
8598                     nv = (NV)temp;
8599                 }
8600             }
8601
8602 #  undef MY_DBL_MAX
8603 #  undef MY_DBL_MAX_BUG
8604 #  undef MY_DBL_MIN
8605
8606 #endif /* HAS_LDBL_SPRINTF_BUG */
8607
8608             need += 20; /* fudge factor */
8609             if (PL_efloatsize < need) {
8610                 Safefree(PL_efloatbuf);
8611                 PL_efloatsize = need + 20; /* more fudge */
8612                 New(906, PL_efloatbuf, PL_efloatsize, char);
8613                 PL_efloatbuf[0] = '\0';
8614             }
8615
8616             eptr = ebuf + sizeof ebuf;
8617             *--eptr = '\0';
8618             *--eptr = c;
8619             /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
8620 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8621             if (intsize == 'q') {
8622                 /* Copy the one or more characters in a long double
8623                  * format before the 'base' ([efgEFG]) character to
8624                  * the format string. */
8625                 static char const prifldbl[] = PERL_PRIfldbl;
8626                 char const *p = prifldbl + sizeof(prifldbl) - 3;
8627                 while (p >= prifldbl) { *--eptr = *p--; }
8628             }
8629 #endif
8630             if (has_precis) {
8631                 base = precis;
8632                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8633                 *--eptr = '.';
8634             }
8635             if (width) {
8636                 base = width;
8637                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8638             }
8639             if (fill == '0')
8640                 *--eptr = fill;
8641             if (left)
8642                 *--eptr = '-';
8643             if (plus)
8644                 *--eptr = plus;
8645             if (alt)
8646                 *--eptr = '#';
8647             *--eptr = '%';
8648
8649             /* No taint.  Otherwise we are in the strange situation
8650              * where printf() taints but print($float) doesn't.
8651              * --jhi */
8652 #if defined(HAS_LONG_DOUBLE)
8653             if (intsize == 'q')
8654                 (void)sprintf(PL_efloatbuf, eptr, nv);
8655             else
8656                 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
8657 #else
8658             (void)sprintf(PL_efloatbuf, eptr, nv);
8659 #endif
8660             eptr = PL_efloatbuf;
8661             elen = strlen(PL_efloatbuf);
8662             break;
8663
8664             /* SPECIAL */
8665
8666         case 'n':
8667             i = SvCUR(sv) - origlen;
8668             if (args && !vectorize) {
8669                 switch (intsize) {
8670                 case 'h':       *(va_arg(*args, short*)) = i; break;
8671                 default:        *(va_arg(*args, int*)) = i; break;
8672                 case 'l':       *(va_arg(*args, long*)) = i; break;
8673                 case 'V':       *(va_arg(*args, IV*)) = i; break;
8674 #ifdef HAS_QUAD
8675                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
8676 #endif
8677                 }
8678             }
8679             else
8680                 sv_setuv_mg(argsv, (UV)i);
8681             vectorize = FALSE;
8682             continue;   /* not "break" */
8683
8684             /* UNKNOWN */
8685
8686         default:
8687       unknown:
8688             vectorize = FALSE;
8689             if (!args && ckWARN(WARN_PRINTF) &&
8690                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8691                 SV *msg = sv_newmortal();
8692                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8693                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8694                 if (c) {
8695                     if (isPRINT(c))
8696                         Perl_sv_catpvf(aTHX_ msg,
8697                                        "\"%%%c\"", c & 0xFF);
8698                     else
8699                         Perl_sv_catpvf(aTHX_ msg,
8700                                        "\"%%\\%03"UVof"\"",
8701                                        (UV)c & 0xFF);
8702                 } else
8703                     sv_catpv(msg, "end of string");
8704                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
8705             }
8706
8707             /* output mangled stuff ... */
8708             if (c == '\0')
8709                 --q;
8710             eptr = p;
8711             elen = q - p;
8712
8713             /* ... right here, because formatting flags should not apply */
8714             SvGROW(sv, SvCUR(sv) + elen + 1);
8715             p = SvEND(sv);
8716             Copy(eptr, p, elen, char);
8717             p += elen;
8718             *p = '\0';
8719             SvCUR(sv) = p - SvPVX(sv);
8720             continue;   /* not "break" */
8721         }
8722
8723         if (is_utf8 != has_utf8) {
8724              if (is_utf8) {
8725                   if (SvCUR(sv))
8726                        sv_utf8_upgrade(sv);
8727              }
8728              else {
8729                   SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
8730                   sv_utf8_upgrade(nsv);
8731                   eptr = SvPVX(nsv);
8732                   elen = SvCUR(nsv);
8733              }
8734              SvGROW(sv, SvCUR(sv) + elen + 1);
8735              p = SvEND(sv);
8736              *p = '\0';
8737         }
8738
8739         have = esignlen + zeros + elen;
8740         need = (have > width ? have : width);
8741         gap = need - have;
8742
8743         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8744         p = SvEND(sv);
8745         if (esignlen && fill == '0') {
8746             for (i = 0; i < (int)esignlen; i++)
8747                 *p++ = esignbuf[i];
8748         }
8749         if (gap && !left) {
8750             memset(p, fill, gap);
8751             p += gap;
8752         }
8753         if (esignlen && fill != '0') {
8754             for (i = 0; i < (int)esignlen; i++)
8755                 *p++ = esignbuf[i];
8756         }
8757         if (zeros) {
8758             for (i = zeros; i; i--)
8759                 *p++ = '0';
8760         }
8761         if (elen) {
8762             Copy(eptr, p, elen, char);
8763             p += elen;
8764         }
8765         if (gap && left) {
8766             memset(p, ' ', gap);
8767             p += gap;
8768         }
8769         if (vectorize) {
8770             if (veclen) {
8771                 Copy(dotstr, p, dotstrlen, char);
8772                 p += dotstrlen;
8773             }
8774             else
8775                 vectorize = FALSE;              /* done iterating over vecstr */
8776         }
8777         if (is_utf8)
8778             has_utf8 = TRUE;
8779         if (has_utf8)
8780             SvUTF8_on(sv);
8781         *p = '\0';
8782         SvCUR(sv) = p - SvPVX(sv);
8783         if (vectorize) {
8784             esignlen = 0;
8785             goto vector;
8786         }
8787     }
8788 }
8789
8790 /* =========================================================================
8791
8792 =head1 Cloning an interpreter
8793
8794 All the macros and functions in this section are for the private use of
8795 the main function, perl_clone().
8796
8797 The foo_dup() functions make an exact copy of an existing foo thinngy.
8798 During the course of a cloning, a hash table is used to map old addresses
8799 to new addresses. The table is created and manipulated with the
8800 ptr_table_* functions.
8801
8802 =cut
8803
8804 ============================================================================*/
8805
8806
8807 #if defined(USE_ITHREADS)
8808
8809 #if defined(USE_5005THREADS)
8810 #  include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
8811 #endif
8812
8813 #ifndef GpREFCNT_inc
8814 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8815 #endif
8816
8817
8818 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8819 #define av_dup(s,t)     (AV*)sv_dup((SV*)s,t)
8820 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8821 #define hv_dup(s,t)     (HV*)sv_dup((SV*)s,t)
8822 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8823 #define cv_dup(s,t)     (CV*)sv_dup((SV*)s,t)
8824 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8825 #define io_dup(s,t)     (IO*)sv_dup((SV*)s,t)
8826 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8827 #define gv_dup(s,t)     (GV*)sv_dup((SV*)s,t)
8828 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8829 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
8830 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
8831
8832
8833 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8834    regcomp.c. AMS 20010712 */
8835
8836 REGEXP *
8837 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
8838 {
8839     REGEXP *ret;
8840     int i, len, npar;
8841     struct reg_substr_datum *s;
8842
8843     if (!r)
8844         return (REGEXP *)NULL;
8845
8846     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8847         return ret;
8848
8849     len = r->offsets[0];
8850     npar = r->nparens+1;
8851
8852     Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8853     Copy(r->program, ret->program, len+1, regnode);
8854
8855     New(0, ret->startp, npar, I32);
8856     Copy(r->startp, ret->startp, npar, I32);
8857     New(0, ret->endp, npar, I32);
8858     Copy(r->startp, ret->startp, npar, I32);
8859
8860     New(0, ret->substrs, 1, struct reg_substr_data);
8861     for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8862         s->min_offset = r->substrs->data[i].min_offset;
8863         s->max_offset = r->substrs->data[i].max_offset;
8864         s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
8865         s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8866     }
8867
8868     ret->regstclass = NULL;
8869     if (r->data) {
8870         struct reg_data *d;
8871         int count = r->data->count;
8872
8873         Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8874                 char, struct reg_data);
8875         New(0, d->what, count, U8);
8876
8877         d->count = count;
8878         for (i = 0; i < count; i++) {
8879             d->what[i] = r->data->what[i];
8880             switch (d->what[i]) {
8881             case 's':
8882                 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8883                 break;
8884             case 'p':
8885                 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8886                 break;
8887             case 'f':
8888                 /* This is cheating. */
8889                 New(0, d->data[i], 1, struct regnode_charclass_class);
8890                 StructCopy(r->data->data[i], d->data[i],
8891                             struct regnode_charclass_class);
8892                 ret->regstclass = (regnode*)d->data[i];
8893                 break;
8894             case 'o':
8895                 /* Compiled op trees are readonly, and can thus be
8896                    shared without duplication. */
8897                 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8898                 break;
8899             case 'n':
8900                 d->data[i] = r->data->data[i];
8901                 break;
8902             }
8903         }
8904
8905         ret->data = d;
8906     }
8907     else
8908         ret->data = NULL;
8909
8910     New(0, ret->offsets, 2*len+1, U32);
8911     Copy(r->offsets, ret->offsets, 2*len+1, U32);
8912
8913     ret->precomp        = SAVEPV(r->precomp);
8914     ret->refcnt         = r->refcnt;
8915     ret->minlen         = r->minlen;
8916     ret->prelen         = r->prelen;
8917     ret->nparens        = r->nparens;
8918     ret->lastparen      = r->lastparen;
8919     ret->lastcloseparen = r->lastcloseparen;
8920     ret->reganch        = r->reganch;
8921
8922     ret->sublen         = r->sublen;
8923
8924     if (RX_MATCH_COPIED(ret))
8925         ret->subbeg  = SAVEPV(r->subbeg);
8926     else
8927         ret->subbeg = Nullch;
8928
8929     ptr_table_store(PL_ptr_table, r, ret);
8930     return ret;
8931 }
8932
8933 /* duplicate a file handle */
8934
8935 PerlIO *
8936 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8937 {
8938     PerlIO *ret;
8939     if (!fp)
8940         return (PerlIO*)NULL;
8941
8942     /* look for it in the table first */
8943     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8944     if (ret)
8945         return ret;
8946
8947     /* create anew and remember what it is */
8948     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
8949     ptr_table_store(PL_ptr_table, fp, ret);
8950     return ret;
8951 }
8952
8953 /* duplicate a directory handle */
8954
8955 DIR *
8956 Perl_dirp_dup(pTHX_ DIR *dp)
8957 {
8958     if (!dp)
8959         return (DIR*)NULL;
8960     /* XXX TODO */
8961     return dp;
8962 }
8963
8964 /* duplicate a typeglob */
8965
8966 GP *
8967 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8968 {
8969     GP *ret;
8970     if (!gp)
8971         return (GP*)NULL;
8972     /* look for it in the table first */
8973     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8974     if (ret)
8975         return ret;
8976
8977     /* create anew and remember what it is */
8978     Newz(0, ret, 1, GP);
8979     ptr_table_store(PL_ptr_table, gp, ret);
8980
8981     /* clone */
8982     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
8983     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
8984     ret->gp_io          = io_dup_inc(gp->gp_io, param);
8985     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
8986     ret->gp_av          = av_dup_inc(gp->gp_av, param);
8987     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
8988     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8989     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
8990     ret->gp_cvgen       = gp->gp_cvgen;
8991     ret->gp_flags       = gp->gp_flags;
8992     ret->gp_line        = gp->gp_line;
8993     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
8994     return ret;
8995 }
8996
8997 /* duplicate a chain of magic */
8998
8999 MAGIC *
9000 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9001 {
9002     MAGIC *mgprev = (MAGIC*)NULL;
9003     MAGIC *mgret;
9004     if (!mg)
9005         return (MAGIC*)NULL;
9006     /* look for it in the table first */
9007     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9008     if (mgret)
9009         return mgret;
9010
9011     for (; mg; mg = mg->mg_moremagic) {
9012         MAGIC *nmg;
9013         Newz(0, nmg, 1, MAGIC);
9014         if (mgprev)
9015             mgprev->mg_moremagic = nmg;
9016         else
9017             mgret = nmg;
9018         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
9019         nmg->mg_private = mg->mg_private;
9020         nmg->mg_type    = mg->mg_type;
9021         nmg->mg_flags   = mg->mg_flags;
9022         if (mg->mg_type == PERL_MAGIC_qr) {
9023             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9024         }
9025         else if(mg->mg_type == PERL_MAGIC_backref) {
9026              AV *av = (AV*) mg->mg_obj;
9027              SV **svp;
9028              I32 i;
9029              nmg->mg_obj = (SV*)newAV();
9030              svp = AvARRAY(av);
9031              i = AvFILLp(av);
9032              while (i >= 0) {
9033                   av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9034                   i--;
9035              }
9036         }
9037         else {
9038             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9039                               ? sv_dup_inc(mg->mg_obj, param)
9040                               : sv_dup(mg->mg_obj, param);
9041         }
9042         nmg->mg_len     = mg->mg_len;
9043         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
9044         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9045             if (mg->mg_len > 0) {
9046                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
9047                 if (mg->mg_type == PERL_MAGIC_overload_table &&
9048                         AMT_AMAGIC((AMT*)mg->mg_ptr))
9049                 {
9050                     AMT *amtp = (AMT*)mg->mg_ptr;
9051                     AMT *namtp = (AMT*)nmg->mg_ptr;
9052                     I32 i;
9053                     for (i = 1; i < NofAMmeth; i++) {
9054                         namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9055                     }
9056                 }
9057             }
9058             else if (mg->mg_len == HEf_SVKEY)
9059                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9060         }
9061         if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9062             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9063         }
9064         mgprev = nmg;
9065     }
9066     return mgret;
9067 }
9068
9069 /* create a new pointer-mapping table */
9070
9071 PTR_TBL_t *
9072 Perl_ptr_table_new(pTHX)
9073 {
9074     PTR_TBL_t *tbl;
9075     Newz(0, tbl, 1, PTR_TBL_t);
9076     tbl->tbl_max        = 511;
9077     tbl->tbl_items      = 0;
9078     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9079     return tbl;
9080 }
9081
9082 /* map an existing pointer using a table */
9083
9084 void *
9085 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
9086 {
9087     PTR_TBL_ENT_t *tblent;
9088     UV hash = PTR2UV(sv);
9089     assert(tbl);
9090     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9091     for (; tblent; tblent = tblent->next) {
9092         if (tblent->oldval == sv)
9093             return tblent->newval;
9094     }
9095     return (void*)NULL;
9096 }
9097
9098 /* add a new entry to a pointer-mapping table */
9099
9100 void
9101 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
9102 {
9103     PTR_TBL_ENT_t *tblent, **otblent;
9104     /* XXX this may be pessimal on platforms where pointers aren't good
9105      * hash values e.g. if they grow faster in the most significant
9106      * bits */
9107     UV hash = PTR2UV(oldv);
9108     bool i = 1;
9109
9110     assert(tbl);
9111     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9112     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
9113         if (tblent->oldval == oldv) {
9114             tblent->newval = newv;
9115             return;
9116         }
9117     }
9118     Newz(0, tblent, 1, PTR_TBL_ENT_t);
9119     tblent->oldval = oldv;
9120     tblent->newval = newv;
9121     tblent->next = *otblent;
9122     *otblent = tblent;
9123     tbl->tbl_items++;
9124     if (i && tbl->tbl_items > tbl->tbl_max)
9125         ptr_table_split(tbl);
9126 }
9127
9128 /* double the hash bucket size of an existing ptr table */
9129
9130 void
9131 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9132 {
9133     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9134     UV oldsize = tbl->tbl_max + 1;
9135     UV newsize = oldsize * 2;
9136     UV i;
9137
9138     Renew(ary, newsize, PTR_TBL_ENT_t*);
9139     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9140     tbl->tbl_max = --newsize;
9141     tbl->tbl_ary = ary;
9142     for (i=0; i < oldsize; i++, ary++) {
9143         PTR_TBL_ENT_t **curentp, **entp, *ent;
9144         if (!*ary)
9145             continue;
9146         curentp = ary + oldsize;
9147         for (entp = ary, ent = *ary; ent; ent = *entp) {
9148             if ((newsize & PTR2UV(ent->oldval)) != i) {
9149                 *entp = ent->next;
9150                 ent->next = *curentp;
9151                 *curentp = ent;
9152                 continue;
9153             }
9154             else
9155                 entp = &ent->next;
9156         }
9157     }
9158 }
9159
9160 /* remove all the entries from a ptr table */
9161
9162 void
9163 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9164 {
9165     register PTR_TBL_ENT_t **array;
9166     register PTR_TBL_ENT_t *entry;
9167     register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
9168     UV riter = 0;
9169     UV max;
9170
9171     if (!tbl || !tbl->tbl_items) {
9172         return;
9173     }
9174
9175     array = tbl->tbl_ary;
9176     entry = array[0];
9177     max = tbl->tbl_max;
9178
9179     for (;;) {
9180         if (entry) {
9181             oentry = entry;
9182             entry = entry->next;
9183             Safefree(oentry);
9184         }
9185         if (!entry) {
9186             if (++riter > max) {
9187                 break;
9188             }
9189             entry = array[riter];
9190         }
9191     }
9192
9193     tbl->tbl_items = 0;
9194 }
9195
9196 /* clear and free a ptr table */
9197
9198 void
9199 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9200 {
9201     if (!tbl) {
9202         return;
9203     }
9204     ptr_table_clear(tbl);
9205     Safefree(tbl->tbl_ary);
9206     Safefree(tbl);
9207 }
9208
9209 #ifdef DEBUGGING
9210 char *PL_watch_pvx;
9211 #endif
9212
9213 /* attempt to make everything in the typeglob readonly */
9214
9215 STATIC SV *
9216 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
9217 {
9218     GV *gv = (GV*)sstr;
9219     SV *sv = &param->proto_perl->Isv_no; /* just need SvREADONLY-ness */
9220
9221     if (GvIO(gv) || GvFORM(gv)) {
9222         GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
9223     }
9224     else if (!GvCV(gv)) {
9225         GvCV(gv) = (CV*)sv;
9226     }
9227     else {
9228         /* CvPADLISTs cannot be shared */
9229         if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
9230             GvUNIQUE_off(gv);
9231         }
9232     }
9233
9234     if (!GvUNIQUE(gv)) {
9235 #if 0
9236         PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
9237                       HvNAME(GvSTASH(gv)), GvNAME(gv));
9238 #endif
9239         return Nullsv;
9240     }
9241
9242     /*
9243      * write attempts will die with
9244      * "Modification of a read-only value attempted"
9245      */
9246     if (!GvSV(gv)) {
9247         GvSV(gv) = sv;
9248     }
9249     else {
9250         SvREADONLY_on(GvSV(gv));
9251     }
9252
9253     if (!GvAV(gv)) {
9254         GvAV(gv) = (AV*)sv;
9255     }
9256     else {
9257         SvREADONLY_on(GvAV(gv));
9258     }
9259
9260     if (!GvHV(gv)) {
9261         GvHV(gv) = (HV*)sv;
9262     }
9263     else {
9264         SvREADONLY_on(GvAV(gv));
9265     }
9266
9267     return sstr; /* he_dup() will SvREFCNT_inc() */
9268 }
9269
9270 /* duplicate an SV of any type (including AV, HV etc) */
9271
9272 void
9273 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9274 {
9275     if (SvROK(sstr)) {
9276         SvRV(dstr) = SvWEAKREF(sstr)
9277                      ? sv_dup(SvRV(sstr), param)
9278                      : sv_dup_inc(SvRV(sstr), param);
9279     }
9280     else if (SvPVX(sstr)) {
9281         /* Has something there */
9282         if (SvLEN(sstr)) {
9283             /* Normal PV - clone whole allocated space */
9284             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9285             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9286                 /* Not that normal - actually sstr is copy on write.
9287                    But we are a true, independant SV, so:  */
9288                 SvREADONLY_off(dstr);
9289                 SvFAKE_off(dstr);
9290             }
9291         }
9292         else {
9293             /* Special case - not normally malloced for some reason */
9294             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9295                 /* A "shared" PV - clone it as unshared string */
9296                 SvFAKE_off(dstr);
9297                 SvREADONLY_off(dstr);
9298                 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
9299             }
9300             else {
9301                 /* Some other special case - random pointer */
9302                 SvPVX(dstr) = SvPVX(sstr);
9303             }
9304         }
9305     }
9306     else {
9307         /* Copy the Null */
9308         SvPVX(dstr) = SvPVX(sstr);
9309     }
9310 }
9311
9312 SV *
9313 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9314 {
9315     SV *dstr;
9316
9317     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9318         return Nullsv;
9319     /* look for it in the table first */
9320     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9321     if (dstr)
9322         return dstr;
9323
9324     /* create anew and remember what it is */
9325     new_SV(dstr);
9326     ptr_table_store(PL_ptr_table, sstr, dstr);
9327
9328     /* clone */
9329     SvFLAGS(dstr)       = SvFLAGS(sstr);
9330     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
9331     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
9332
9333 #ifdef DEBUGGING
9334     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
9335         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9336                       PL_watch_pvx, SvPVX(sstr));
9337 #endif
9338
9339     switch (SvTYPE(sstr)) {
9340     case SVt_NULL:
9341         SvANY(dstr)     = NULL;
9342         break;
9343     case SVt_IV:
9344         SvANY(dstr)     = new_XIV();
9345         SvIVX(dstr)     = SvIVX(sstr);
9346         break;
9347     case SVt_NV:
9348         SvANY(dstr)     = new_XNV();
9349         SvNVX(dstr)     = SvNVX(sstr);
9350         break;
9351     case SVt_RV:
9352         SvANY(dstr)     = new_XRV();
9353         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9354         break;
9355     case SVt_PV:
9356         SvANY(dstr)     = new_XPV();
9357         SvCUR(dstr)     = SvCUR(sstr);
9358         SvLEN(dstr)     = SvLEN(sstr);
9359         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9360         break;
9361     case SVt_PVIV:
9362         SvANY(dstr)     = new_XPVIV();
9363         SvCUR(dstr)     = SvCUR(sstr);
9364         SvLEN(dstr)     = SvLEN(sstr);
9365         SvIVX(dstr)     = SvIVX(sstr);
9366         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9367         break;
9368     case SVt_PVNV:
9369         SvANY(dstr)     = new_XPVNV();
9370         SvCUR(dstr)     = SvCUR(sstr);
9371         SvLEN(dstr)     = SvLEN(sstr);
9372         SvIVX(dstr)     = SvIVX(sstr);
9373         SvNVX(dstr)     = SvNVX(sstr);
9374         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9375         break;
9376     case SVt_PVMG:
9377         SvANY(dstr)     = new_XPVMG();
9378         SvCUR(dstr)     = SvCUR(sstr);
9379         SvLEN(dstr)     = SvLEN(sstr);
9380         SvIVX(dstr)     = SvIVX(sstr);
9381         SvNVX(dstr)     = SvNVX(sstr);
9382         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9383         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9384         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9385         break;
9386     case SVt_PVBM:
9387         SvANY(dstr)     = new_XPVBM();
9388         SvCUR(dstr)     = SvCUR(sstr);
9389         SvLEN(dstr)     = SvLEN(sstr);
9390         SvIVX(dstr)     = SvIVX(sstr);
9391         SvNVX(dstr)     = SvNVX(sstr);
9392         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9393         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9394         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9395         BmRARE(dstr)    = BmRARE(sstr);
9396         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
9397         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
9398         break;
9399     case SVt_PVLV:
9400         SvANY(dstr)     = new_XPVLV();
9401         SvCUR(dstr)     = SvCUR(sstr);
9402         SvLEN(dstr)     = SvLEN(sstr);
9403         SvIVX(dstr)     = SvIVX(sstr);
9404         SvNVX(dstr)     = SvNVX(sstr);
9405         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9406         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9407         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9408         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
9409         LvTARGLEN(dstr) = LvTARGLEN(sstr);
9410         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr), param);
9411         LvTYPE(dstr)    = LvTYPE(sstr);
9412         break;
9413     case SVt_PVGV:
9414         if (GvUNIQUE((GV*)sstr)) {
9415             SV *share;
9416             if ((share = gv_share(sstr, param))) {
9417                 del_SV(dstr);
9418                 dstr = share;
9419                 ptr_table_store(PL_ptr_table, sstr, dstr);
9420 #if 0
9421                 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
9422                               HvNAME(GvSTASH(share)), GvNAME(share));
9423 #endif
9424                 break;
9425             }
9426         }
9427         SvANY(dstr)     = new_XPVGV();
9428         SvCUR(dstr)     = SvCUR(sstr);
9429         SvLEN(dstr)     = SvLEN(sstr);
9430         SvIVX(dstr)     = SvIVX(sstr);
9431         SvNVX(dstr)     = SvNVX(sstr);
9432         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9433         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9434         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9435         GvNAMELEN(dstr) = GvNAMELEN(sstr);
9436         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
9437         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr), param);
9438         GvFLAGS(dstr)   = GvFLAGS(sstr);
9439         GvGP(dstr)      = gp_dup(GvGP(sstr), param);
9440         (void)GpREFCNT_inc(GvGP(dstr));
9441         break;
9442     case SVt_PVIO:
9443         SvANY(dstr)     = new_XPVIO();
9444         SvCUR(dstr)     = SvCUR(sstr);
9445         SvLEN(dstr)     = SvLEN(sstr);
9446         SvIVX(dstr)     = SvIVX(sstr);
9447         SvNVX(dstr)     = SvNVX(sstr);
9448         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9449         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9450         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9451         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
9452         if (IoOFP(sstr) == IoIFP(sstr))
9453             IoOFP(dstr) = IoIFP(dstr);
9454         else
9455             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
9456         /* PL_rsfp_filters entries have fake IoDIRP() */
9457         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
9458             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
9459         else
9460             IoDIRP(dstr)        = IoDIRP(sstr);
9461         IoLINES(dstr)           = IoLINES(sstr);
9462         IoPAGE(dstr)            = IoPAGE(sstr);
9463         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
9464         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
9465         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
9466         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr), param);
9467         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
9468         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr), param);
9469         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
9470         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr), param);
9471         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
9472         IoTYPE(dstr)            = IoTYPE(sstr);
9473         IoFLAGS(dstr)           = IoFLAGS(sstr);
9474         break;
9475     case SVt_PVAV:
9476         SvANY(dstr)     = new_XPVAV();
9477         SvCUR(dstr)     = SvCUR(sstr);
9478         SvLEN(dstr)     = SvLEN(sstr);
9479         SvIVX(dstr)     = SvIVX(sstr);
9480         SvNVX(dstr)     = SvNVX(sstr);
9481         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9482         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9483         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9484         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9485         if (AvARRAY((AV*)sstr)) {
9486             SV **dst_ary, **src_ary;
9487             SSize_t items = AvFILLp((AV*)sstr) + 1;
9488
9489             src_ary = AvARRAY((AV*)sstr);
9490             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9491             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9492             SvPVX(dstr) = (char*)dst_ary;
9493             AvALLOC((AV*)dstr) = dst_ary;
9494             if (AvREAL((AV*)sstr)) {
9495                 while (items-- > 0)
9496                     *dst_ary++ = sv_dup_inc(*src_ary++, param);
9497             }
9498             else {
9499                 while (items-- > 0)
9500                     *dst_ary++ = sv_dup(*src_ary++, param);
9501             }
9502             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9503             while (items-- > 0) {
9504                 *dst_ary++ = &PL_sv_undef;
9505             }
9506         }
9507         else {
9508             SvPVX(dstr)         = Nullch;
9509             AvALLOC((AV*)dstr)  = (SV**)NULL;
9510         }
9511         break;
9512     case SVt_PVHV:
9513         SvANY(dstr)     = new_XPVHV();
9514         SvCUR(dstr)     = SvCUR(sstr);
9515         SvLEN(dstr)     = SvLEN(sstr);
9516         SvIVX(dstr)     = SvIVX(sstr);
9517         SvNVX(dstr)     = SvNVX(sstr);
9518         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9519         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9520         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
9521         if (HvARRAY((HV*)sstr)) {
9522             STRLEN i = 0;
9523             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9524             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9525             Newz(0, dxhv->xhv_array,
9526                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9527             while (i <= sxhv->xhv_max) {
9528                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9529                                                     (bool)!!HvSHAREKEYS(sstr),
9530                                                     param);
9531                 ++i;
9532             }
9533             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
9534                                      (bool)!!HvSHAREKEYS(sstr), param);
9535         }
9536         else {
9537             SvPVX(dstr)         = Nullch;
9538             HvEITER((HV*)dstr)  = (HE*)NULL;
9539         }
9540         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
9541         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
9542     /* Record stashes for possible cloning in Perl_clone(). */
9543         if(HvNAME((HV*)dstr))
9544             av_push(param->stashes, dstr);
9545         break;
9546     case SVt_PVFM:
9547         SvANY(dstr)     = new_XPVFM();
9548         FmLINES(dstr)   = FmLINES(sstr);
9549         goto dup_pvcv;
9550         /* NOTREACHED */
9551     case SVt_PVCV:
9552         SvANY(dstr)     = new_XPVCV();
9553         dup_pvcv:
9554         SvCUR(dstr)     = SvCUR(sstr);
9555         SvLEN(dstr)     = SvLEN(sstr);
9556         SvIVX(dstr)     = SvIVX(sstr);
9557         SvNVX(dstr)     = SvNVX(sstr);
9558         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr), param);
9559         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr), param);
9560         Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9561         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9562         CvSTART(dstr)   = CvSTART(sstr);
9563         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
9564         CvXSUB(dstr)    = CvXSUB(sstr);
9565         CvXSUBANY(dstr) = CvXSUBANY(sstr);
9566         if (CvCONST(sstr)) {
9567             CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9568                 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9569                 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9570         }
9571         CvGV(dstr)      = gv_dup(CvGV(sstr), param);
9572         if (param->flags & CLONEf_COPY_STACKS) {
9573           CvDEPTH(dstr) = CvDEPTH(sstr);
9574         } else {
9575           CvDEPTH(dstr) = 0;
9576         }
9577         PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
9578         if (!CvANON(sstr) || CvCLONED(sstr))
9579             CvOUTSIDE(dstr)     = cv_dup_inc(CvOUTSIDE(sstr), param);
9580         else
9581             CvOUTSIDE(dstr)     = cv_dup(CvOUTSIDE(sstr), param);
9582         CvFLAGS(dstr)   = CvFLAGS(sstr);
9583         CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9584         break;
9585     default:
9586         Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
9587         break;
9588     }
9589
9590     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9591         ++PL_sv_objcount;
9592
9593     return dstr;
9594  }
9595
9596 /* duplicate a context */
9597
9598 PERL_CONTEXT *
9599 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9600 {
9601     PERL_CONTEXT *ncxs;
9602
9603     if (!cxs)
9604         return (PERL_CONTEXT*)NULL;
9605
9606     /* look for it in the table first */
9607     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9608     if (ncxs)
9609         return ncxs;
9610
9611     /* create anew and remember what it is */
9612     Newz(56, ncxs, max + 1, PERL_CONTEXT);
9613     ptr_table_store(PL_ptr_table, cxs, ncxs);
9614
9615     while (ix >= 0) {
9616         PERL_CONTEXT *cx = &cxs[ix];
9617         PERL_CONTEXT *ncx = &ncxs[ix];
9618         ncx->cx_type    = cx->cx_type;
9619         if (CxTYPE(cx) == CXt_SUBST) {
9620             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9621         }
9622         else {
9623             ncx->blk_oldsp      = cx->blk_oldsp;
9624             ncx->blk_oldcop     = cx->blk_oldcop;
9625             ncx->blk_oldretsp   = cx->blk_oldretsp;
9626             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
9627             ncx->blk_oldscopesp = cx->blk_oldscopesp;
9628             ncx->blk_oldpm      = cx->blk_oldpm;
9629             ncx->blk_gimme      = cx->blk_gimme;
9630             switch (CxTYPE(cx)) {
9631             case CXt_SUB:
9632                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
9633                                            ? cv_dup_inc(cx->blk_sub.cv, param)
9634                                            : cv_dup(cx->blk_sub.cv,param));
9635                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
9636                                            ? av_dup_inc(cx->blk_sub.argarray, param)
9637                                            : Nullav);
9638                 ncx->blk_sub.savearray  = av_dup_inc(cx->blk_sub.savearray, param);
9639                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
9640                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
9641                 ncx->blk_sub.lval       = cx->blk_sub.lval;
9642                 break;
9643             case CXt_EVAL:
9644                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9645                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9646                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
9647                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9648                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text, param);
9649                 break;
9650             case CXt_LOOP:
9651                 ncx->blk_loop.label     = cx->blk_loop.label;
9652                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
9653                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
9654                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
9655                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
9656                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
9657                                            ? cx->blk_loop.iterdata
9658                                            : gv_dup((GV*)cx->blk_loop.iterdata, param));
9659                 ncx->blk_loop.oldcurpad
9660                     = (SV**)ptr_table_fetch(PL_ptr_table,
9661                                             cx->blk_loop.oldcurpad);
9662                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave, param);
9663                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval, param);
9664                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary, param);
9665                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
9666                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
9667                 break;
9668             case CXt_FORMAT:
9669                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv, param);
9670                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv, param);
9671                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9672                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
9673                 break;
9674             case CXt_BLOCK:
9675             case CXt_NULL:
9676                 break;
9677             }
9678         }
9679         --ix;
9680     }
9681     return ncxs;
9682 }
9683
9684 /* duplicate a stack info structure */
9685
9686 PERL_SI *
9687 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9688 {
9689     PERL_SI *nsi;
9690
9691     if (!si)
9692         return (PERL_SI*)NULL;
9693
9694     /* look for it in the table first */
9695     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9696     if (nsi)
9697         return nsi;
9698
9699     /* create anew and remember what it is */
9700     Newz(56, nsi, 1, PERL_SI);
9701     ptr_table_store(PL_ptr_table, si, nsi);
9702
9703     nsi->si_stack       = av_dup_inc(si->si_stack, param);
9704     nsi->si_cxix        = si->si_cxix;
9705     nsi->si_cxmax       = si->si_cxmax;
9706     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9707     nsi->si_type        = si->si_type;
9708     nsi->si_prev        = si_dup(si->si_prev, param);
9709     nsi->si_next        = si_dup(si->si_next, param);
9710     nsi->si_markoff     = si->si_markoff;
9711
9712     return nsi;
9713 }
9714
9715 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
9716 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
9717 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
9718 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
9719 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
9720 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
9721 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
9722 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
9723 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
9724 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
9725 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9726 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9727
9728 /* XXXXX todo */
9729 #define pv_dup_inc(p)   SAVEPV(p)
9730 #define pv_dup(p)       SAVEPV(p)
9731 #define svp_dup_inc(p,pp)       any_dup(p,pp)
9732
9733 /* map any object to the new equivent - either something in the
9734  * ptr table, or something in the interpreter structure
9735  */
9736
9737 void *
9738 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9739 {
9740     void *ret;
9741
9742     if (!v)
9743         return (void*)NULL;
9744
9745     /* look for it in the table first */
9746     ret = ptr_table_fetch(PL_ptr_table, v);
9747     if (ret)
9748         return ret;
9749
9750     /* see if it is part of the interpreter structure */
9751     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9752         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9753     else {
9754         ret = v;
9755     }
9756
9757     return ret;
9758 }
9759
9760 /* duplicate the save stack */
9761
9762 ANY *
9763 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9764 {
9765     ANY *ss     = proto_perl->Tsavestack;
9766     I32 ix      = proto_perl->Tsavestack_ix;
9767     I32 max     = proto_perl->Tsavestack_max;
9768     ANY *nss;
9769     SV *sv;
9770     GV *gv;
9771     AV *av;
9772     HV *hv;
9773     void* ptr;
9774     int intval;
9775     long longval;
9776     GP *gp;
9777     IV iv;
9778     I32 i;
9779     char *c = NULL;
9780     void (*dptr) (void*);
9781     void (*dxptr) (pTHX_ void*);
9782     OP *o;
9783
9784     Newz(54, nss, max, ANY);
9785
9786     while (ix > 0) {
9787         i = POPINT(ss,ix);
9788         TOPINT(nss,ix) = i;
9789         switch (i) {
9790         case SAVEt_ITEM:                        /* normal string */
9791             sv = (SV*)POPPTR(ss,ix);
9792             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9793             sv = (SV*)POPPTR(ss,ix);
9794             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9795             break;
9796         case SAVEt_SV:                          /* scalar reference */
9797             sv = (SV*)POPPTR(ss,ix);
9798             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9799             gv = (GV*)POPPTR(ss,ix);
9800             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9801             break;
9802         case SAVEt_GENERIC_PVREF:               /* generic char* */
9803             c = (char*)POPPTR(ss,ix);
9804             TOPPTR(nss,ix) = pv_dup(c);
9805             ptr = POPPTR(ss,ix);
9806             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9807             break;
9808         case SAVEt_SHARED_PVREF:                /* char* in shared space */
9809             c = (char*)POPPTR(ss,ix);
9810             TOPPTR(nss,ix) = savesharedpv(c);
9811             ptr = POPPTR(ss,ix);
9812             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9813             break;
9814         case SAVEt_GENERIC_SVREF:               /* generic sv */
9815         case SAVEt_SVREF:                       /* scalar reference */
9816             sv = (SV*)POPPTR(ss,ix);
9817             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9818             ptr = POPPTR(ss,ix);
9819             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9820             break;
9821         case SAVEt_AV:                          /* array reference */
9822             av = (AV*)POPPTR(ss,ix);
9823             TOPPTR(nss,ix) = av_dup_inc(av, param);
9824             gv = (GV*)POPPTR(ss,ix);
9825             TOPPTR(nss,ix) = gv_dup(gv, param);
9826             break;
9827         case SAVEt_HV:                          /* hash reference */
9828             hv = (HV*)POPPTR(ss,ix);
9829             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9830             gv = (GV*)POPPTR(ss,ix);
9831             TOPPTR(nss,ix) = gv_dup(gv, param);
9832             break;
9833         case SAVEt_INT:                         /* int reference */
9834             ptr = POPPTR(ss,ix);
9835             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9836             intval = (int)POPINT(ss,ix);
9837             TOPINT(nss,ix) = intval;
9838             break;
9839         case SAVEt_LONG:                        /* long reference */
9840             ptr = POPPTR(ss,ix);
9841             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9842             longval = (long)POPLONG(ss,ix);
9843             TOPLONG(nss,ix) = longval;
9844             break;
9845         case SAVEt_I32:                         /* I32 reference */
9846         case SAVEt_I16:                         /* I16 reference */
9847         case SAVEt_I8:                          /* I8 reference */
9848             ptr = POPPTR(ss,ix);
9849             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9850             i = POPINT(ss,ix);
9851             TOPINT(nss,ix) = i;
9852             break;
9853         case SAVEt_IV:                          /* IV reference */
9854             ptr = POPPTR(ss,ix);
9855             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9856             iv = POPIV(ss,ix);
9857             TOPIV(nss,ix) = iv;
9858             break;
9859         case SAVEt_SPTR:                        /* SV* reference */
9860             ptr = POPPTR(ss,ix);
9861             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9862             sv = (SV*)POPPTR(ss,ix);
9863             TOPPTR(nss,ix) = sv_dup(sv, param);
9864             break;
9865         case SAVEt_VPTR:                        /* random* reference */
9866             ptr = POPPTR(ss,ix);
9867             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9868             ptr = POPPTR(ss,ix);
9869             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9870             break;
9871         case SAVEt_PPTR:                        /* char* reference */
9872             ptr = POPPTR(ss,ix);
9873             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9874             c = (char*)POPPTR(ss,ix);
9875             TOPPTR(nss,ix) = pv_dup(c);
9876             break;
9877         case SAVEt_HPTR:                        /* HV* reference */
9878             ptr = POPPTR(ss,ix);
9879             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9880             hv = (HV*)POPPTR(ss,ix);
9881             TOPPTR(nss,ix) = hv_dup(hv, param);
9882             break;
9883         case SAVEt_APTR:                        /* AV* reference */
9884             ptr = POPPTR(ss,ix);
9885             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9886             av = (AV*)POPPTR(ss,ix);
9887             TOPPTR(nss,ix) = av_dup(av, param);
9888             break;
9889         case SAVEt_NSTAB:
9890             gv = (GV*)POPPTR(ss,ix);
9891             TOPPTR(nss,ix) = gv_dup(gv, param);
9892             break;
9893         case SAVEt_GP:                          /* scalar reference */
9894             gp = (GP*)POPPTR(ss,ix);
9895             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9896             (void)GpREFCNT_inc(gp);
9897             gv = (GV*)POPPTR(ss,ix);
9898             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9899             c = (char*)POPPTR(ss,ix);
9900             TOPPTR(nss,ix) = pv_dup(c);
9901             iv = POPIV(ss,ix);
9902             TOPIV(nss,ix) = iv;
9903             iv = POPIV(ss,ix);
9904             TOPIV(nss,ix) = iv;
9905             break;
9906         case SAVEt_FREESV:
9907         case SAVEt_MORTALIZESV:
9908             sv = (SV*)POPPTR(ss,ix);
9909             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9910             break;
9911         case SAVEt_FREEOP:
9912             ptr = POPPTR(ss,ix);
9913             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9914                 /* these are assumed to be refcounted properly */
9915                 switch (((OP*)ptr)->op_type) {
9916                 case OP_LEAVESUB:
9917                 case OP_LEAVESUBLV:
9918                 case OP_LEAVEEVAL:
9919                 case OP_LEAVE:
9920                 case OP_SCOPE:
9921                 case OP_LEAVEWRITE:
9922                     TOPPTR(nss,ix) = ptr;
9923                     o = (OP*)ptr;
9924                     OpREFCNT_inc(o);
9925                     break;
9926                 default:
9927                     TOPPTR(nss,ix) = Nullop;
9928                     break;
9929                 }
9930             }
9931             else
9932                 TOPPTR(nss,ix) = Nullop;
9933             break;
9934         case SAVEt_FREEPV:
9935             c = (char*)POPPTR(ss,ix);
9936             TOPPTR(nss,ix) = pv_dup_inc(c);
9937             break;
9938         case SAVEt_CLEARSV:
9939             longval = POPLONG(ss,ix);
9940             TOPLONG(nss,ix) = longval;
9941             break;
9942         case SAVEt_DELETE:
9943             hv = (HV*)POPPTR(ss,ix);
9944             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9945             c = (char*)POPPTR(ss,ix);
9946             TOPPTR(nss,ix) = pv_dup_inc(c);
9947             i = POPINT(ss,ix);
9948             TOPINT(nss,ix) = i;
9949             break;
9950         case SAVEt_DESTRUCTOR:
9951             ptr = POPPTR(ss,ix);
9952             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
9953             dptr = POPDPTR(ss,ix);
9954             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9955             break;
9956         case SAVEt_DESTRUCTOR_X:
9957             ptr = POPPTR(ss,ix);
9958             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
9959             dxptr = POPDXPTR(ss,ix);
9960             TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
9961             break;
9962         case SAVEt_REGCONTEXT:
9963         case SAVEt_ALLOC:
9964             i = POPINT(ss,ix);
9965             TOPINT(nss,ix) = i;
9966             ix -= i;
9967             break;
9968         case SAVEt_STACK_POS:           /* Position on Perl stack */
9969             i = POPINT(ss,ix);
9970             TOPINT(nss,ix) = i;
9971             break;
9972         case SAVEt_AELEM:               /* array element */
9973             sv = (SV*)POPPTR(ss,ix);
9974             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9975             i = POPINT(ss,ix);
9976             TOPINT(nss,ix) = i;
9977             av = (AV*)POPPTR(ss,ix);
9978             TOPPTR(nss,ix) = av_dup_inc(av, param);
9979             break;
9980         case SAVEt_HELEM:               /* hash element */
9981             sv = (SV*)POPPTR(ss,ix);
9982             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9983             sv = (SV*)POPPTR(ss,ix);
9984             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9985             hv = (HV*)POPPTR(ss,ix);
9986             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9987             break;
9988         case SAVEt_OP:
9989             ptr = POPPTR(ss,ix);
9990             TOPPTR(nss,ix) = ptr;
9991             break;
9992         case SAVEt_HINTS:
9993             i = POPINT(ss,ix);
9994             TOPINT(nss,ix) = i;
9995             break;
9996         case SAVEt_COMPPAD:
9997             av = (AV*)POPPTR(ss,ix);
9998             TOPPTR(nss,ix) = av_dup(av, param);
9999             break;
10000         case SAVEt_PADSV:
10001             longval = (long)POPLONG(ss,ix);
10002             TOPLONG(nss,ix) = longval;
10003             ptr = POPPTR(ss,ix);
10004             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10005             sv = (SV*)POPPTR(ss,ix);
10006             TOPPTR(nss,ix) = sv_dup(sv, param);
10007             break;
10008         default:
10009             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10010         }
10011     }
10012
10013     return nss;
10014 }
10015
10016 /*
10017 =for apidoc perl_clone
10018
10019 Create and return a new interpreter by cloning the current one.
10020
10021 =cut
10022 */
10023
10024 /* XXX the above needs expanding by someone who actually understands it ! */
10025 EXTERN_C PerlInterpreter *
10026 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10027
10028 PerlInterpreter *
10029 perl_clone(PerlInterpreter *proto_perl, UV flags)
10030 {
10031 #ifdef PERL_IMPLICIT_SYS
10032
10033    /* perlhost.h so we need to call into it
10034    to clone the host, CPerlHost should have a c interface, sky */
10035
10036    if (flags & CLONEf_CLONE_HOST) {
10037        return perl_clone_host(proto_perl,flags);
10038    }
10039    return perl_clone_using(proto_perl, flags,
10040                             proto_perl->IMem,
10041                             proto_perl->IMemShared,
10042                             proto_perl->IMemParse,
10043                             proto_perl->IEnv,
10044                             proto_perl->IStdIO,
10045                             proto_perl->ILIO,
10046                             proto_perl->IDir,
10047                             proto_perl->ISock,
10048                             proto_perl->IProc);
10049 }
10050
10051 PerlInterpreter *
10052 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10053                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
10054                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10055                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10056                  struct IPerlDir* ipD, struct IPerlSock* ipS,
10057                  struct IPerlProc* ipP)
10058 {
10059     /* XXX many of the string copies here can be optimized if they're
10060      * constants; they need to be allocated as common memory and just
10061      * their pointers copied. */
10062
10063     IV i;
10064     CLONE_PARAMS clone_params;
10065     CLONE_PARAMS* param = &clone_params;
10066
10067     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10068     PERL_SET_THX(my_perl);
10069
10070 #  ifdef DEBUGGING
10071     Poison(my_perl, 1, PerlInterpreter);
10072     PL_markstack = 0;
10073     PL_scopestack = 0;
10074     PL_savestack = 0;
10075     PL_retstack = 0;
10076     PL_sig_pending = 0;
10077     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10078 #  else /* !DEBUGGING */
10079     Zero(my_perl, 1, PerlInterpreter);
10080 #  endif        /* DEBUGGING */
10081
10082     /* host pointers */
10083     PL_Mem              = ipM;
10084     PL_MemShared        = ipMS;
10085     PL_MemParse         = ipMP;
10086     PL_Env              = ipE;
10087     PL_StdIO            = ipStd;
10088     PL_LIO              = ipLIO;
10089     PL_Dir              = ipD;
10090     PL_Sock             = ipS;
10091     PL_Proc             = ipP;
10092 #else           /* !PERL_IMPLICIT_SYS */
10093     IV i;
10094     CLONE_PARAMS clone_params;
10095     CLONE_PARAMS* param = &clone_params;
10096     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10097     PERL_SET_THX(my_perl);
10098
10099
10100
10101 #    ifdef DEBUGGING
10102     Poison(my_perl, 1, PerlInterpreter);
10103     PL_markstack = 0;
10104     PL_scopestack = 0;
10105     PL_savestack = 0;
10106     PL_retstack = 0;
10107     PL_sig_pending = 0;
10108     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10109 #    else       /* !DEBUGGING */
10110     Zero(my_perl, 1, PerlInterpreter);
10111 #    endif      /* DEBUGGING */
10112 #endif          /* PERL_IMPLICIT_SYS */
10113     param->flags = flags;
10114     param->proto_perl = proto_perl;
10115
10116     /* arena roots */
10117     PL_xiv_arenaroot    = NULL;
10118     PL_xiv_root         = NULL;
10119     PL_xnv_arenaroot    = NULL;
10120     PL_xnv_root         = NULL;
10121     PL_xrv_arenaroot    = NULL;
10122     PL_xrv_root         = NULL;
10123     PL_xpv_arenaroot    = NULL;
10124     PL_xpv_root         = NULL;
10125     PL_xpviv_arenaroot  = NULL;
10126     PL_xpviv_root       = NULL;
10127     PL_xpvnv_arenaroot  = NULL;
10128     PL_xpvnv_root       = NULL;
10129     PL_xpvcv_arenaroot  = NULL;
10130     PL_xpvcv_root       = NULL;
10131     PL_xpvav_arenaroot  = NULL;
10132     PL_xpvav_root       = NULL;
10133     PL_xpvhv_arenaroot  = NULL;
10134     PL_xpvhv_root       = NULL;
10135     PL_xpvmg_arenaroot  = NULL;
10136     PL_xpvmg_root       = NULL;
10137     PL_xpvlv_arenaroot  = NULL;
10138     PL_xpvlv_root       = NULL;
10139     PL_xpvbm_arenaroot  = NULL;
10140     PL_xpvbm_root       = NULL;
10141     PL_he_arenaroot     = NULL;
10142     PL_he_root          = NULL;
10143     PL_nice_chunk       = NULL;
10144     PL_nice_chunk_size  = 0;
10145     PL_sv_count         = 0;
10146     PL_sv_objcount      = 0;
10147     PL_sv_root          = Nullsv;
10148     PL_sv_arenaroot     = Nullsv;
10149
10150     PL_debug            = proto_perl->Idebug;
10151
10152 #ifdef USE_REENTRANT_API
10153     Perl_reentrant_init(aTHX);
10154 #endif
10155
10156     /* create SV map for pointer relocation */
10157     PL_ptr_table = ptr_table_new();
10158
10159     /* initialize these special pointers as early as possible */
10160     SvANY(&PL_sv_undef)         = NULL;
10161     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
10162     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
10163     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10164
10165     SvANY(&PL_sv_no)            = new_XPVNV();
10166     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
10167     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10168     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
10169     SvCUR(&PL_sv_no)            = 0;
10170     SvLEN(&PL_sv_no)            = 1;
10171     SvNVX(&PL_sv_no)            = 0;
10172     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10173
10174     SvANY(&PL_sv_yes)           = new_XPVNV();
10175     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
10176     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10177     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
10178     SvCUR(&PL_sv_yes)           = 1;
10179     SvLEN(&PL_sv_yes)           = 2;
10180     SvNVX(&PL_sv_yes)           = 1;
10181     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10182
10183     /* create (a non-shared!) shared string table */
10184     PL_strtab           = newHV();
10185     HvSHAREKEYS_off(PL_strtab);
10186     hv_ksplit(PL_strtab, 512);
10187     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10188
10189     PL_compiling = proto_perl->Icompiling;
10190
10191     /* These two PVs will be free'd special way so must set them same way op.c does */
10192     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10193     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10194
10195     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
10196     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10197
10198     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10199     if (!specialWARN(PL_compiling.cop_warnings))
10200         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10201     if (!specialCopIO(PL_compiling.cop_io))
10202         PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10203     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10204
10205     /* pseudo environmental stuff */
10206     PL_origargc         = proto_perl->Iorigargc;
10207     i = PL_origargc;
10208     New(0, PL_origargv, i+1, char*);
10209     PL_origargv[i] = '\0';
10210     while (i-- > 0) {
10211         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
10212     }
10213
10214     param->stashes      = newAV();  /* Setup array of objects to call clone on */
10215
10216 #ifdef PERLIO_LAYERS
10217     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10218     PerlIO_clone(aTHX_ proto_perl, param);
10219 #endif
10220
10221     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
10222     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
10223     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
10224     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
10225     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
10226     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
10227
10228     /* switches */
10229     PL_minus_c          = proto_perl->Iminus_c;
10230     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
10231     PL_localpatches     = proto_perl->Ilocalpatches;
10232     PL_splitstr         = proto_perl->Isplitstr;
10233     PL_preprocess       = proto_perl->Ipreprocess;
10234     PL_minus_n          = proto_perl->Iminus_n;
10235     PL_minus_p          = proto_perl->Iminus_p;
10236     PL_minus_l          = proto_perl->Iminus_l;
10237     PL_minus_a          = proto_perl->Iminus_a;
10238     PL_minus_F          = proto_perl->Iminus_F;
10239     PL_doswitches       = proto_perl->Idoswitches;
10240     PL_dowarn           = proto_perl->Idowarn;
10241     PL_doextract        = proto_perl->Idoextract;
10242     PL_sawampersand     = proto_perl->Isawampersand;
10243     PL_unsafe           = proto_perl->Iunsafe;
10244     PL_inplace          = SAVEPV(proto_perl->Iinplace);
10245     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
10246     PL_perldb           = proto_perl->Iperldb;
10247     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10248     PL_exit_flags       = proto_perl->Iexit_flags;
10249
10250     /* magical thingies */
10251     /* XXX time(&PL_basetime) when asked for? */
10252     PL_basetime         = proto_perl->Ibasetime;
10253     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
10254
10255     PL_maxsysfd         = proto_perl->Imaxsysfd;
10256     PL_multiline        = proto_perl->Imultiline;
10257     PL_statusvalue      = proto_perl->Istatusvalue;
10258 #ifdef VMS
10259     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
10260 #endif
10261     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
10262
10263     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
10264     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
10265     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
10266
10267     /* Clone the regex array */
10268     PL_regex_padav = newAV();
10269     {
10270         I32 len = av_len((AV*)proto_perl->Iregex_padav);
10271         SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10272         av_push(PL_regex_padav,
10273                 sv_dup_inc(regexen[0],param));
10274         for(i = 1; i <= len; i++) {
10275             if(SvREPADTMP(regexen[i])) {
10276               av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
10277             } else {
10278                 av_push(PL_regex_padav,
10279                     SvREFCNT_inc(
10280                         newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
10281                              SvIVX(regexen[i])), param)))
10282                        ));
10283             }
10284         }
10285     }
10286     PL_regex_pad = AvARRAY(PL_regex_padav);
10287
10288     /* shortcuts to various I/O objects */
10289     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
10290     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
10291     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
10292     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
10293     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
10294     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
10295
10296     /* shortcuts to regexp stuff */
10297     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
10298
10299     /* shortcuts to misc objects */
10300     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
10301
10302     /* shortcuts to debugging objects */
10303     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
10304     PL_DBline           = gv_dup(proto_perl->IDBline, param);
10305     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
10306     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
10307     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
10308     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
10309     PL_lineary          = av_dup(proto_perl->Ilineary, param);
10310     PL_dbargs           = av_dup(proto_perl->Idbargs, param);
10311
10312     /* symbol tables */
10313     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash, param);
10314     PL_curstash         = hv_dup(proto_perl->Tcurstash, param);
10315     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
10316     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
10317     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
10318
10319     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
10320     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
10321     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
10322     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
10323     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
10324     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
10325
10326     PL_sub_generation   = proto_perl->Isub_generation;
10327
10328     /* funky return mechanisms */
10329     PL_forkprocess      = proto_perl->Iforkprocess;
10330
10331     /* subprocess state */
10332     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
10333
10334     /* internal state */
10335     PL_tainting         = proto_perl->Itainting;
10336     PL_maxo             = proto_perl->Imaxo;
10337     if (proto_perl->Iop_mask)
10338         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10339     else
10340         PL_op_mask      = Nullch;
10341
10342     /* current interpreter roots */
10343     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
10344     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
10345     PL_main_start       = proto_perl->Imain_start;
10346     PL_eval_root        = proto_perl->Ieval_root;
10347     PL_eval_start       = proto_perl->Ieval_start;
10348
10349     /* runtime control stuff */
10350     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10351     PL_copline          = proto_perl->Icopline;
10352
10353     PL_filemode         = proto_perl->Ifilemode;
10354     PL_lastfd           = proto_perl->Ilastfd;
10355     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
10356     PL_Argv             = NULL;
10357     PL_Cmd              = Nullch;
10358     PL_gensym           = proto_perl->Igensym;
10359     PL_preambled        = proto_perl->Ipreambled;
10360     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
10361     PL_laststatval      = proto_perl->Ilaststatval;
10362     PL_laststype        = proto_perl->Ilaststype;
10363     PL_mess_sv          = Nullsv;
10364
10365     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
10366     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
10367
10368     /* interpreter atexit processing */
10369     PL_exitlistlen      = proto_perl->Iexitlistlen;
10370     if (PL_exitlistlen) {
10371         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10372         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10373     }
10374     else
10375         PL_exitlist     = (PerlExitListEntry*)NULL;
10376     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
10377     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
10378     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10379
10380     PL_profiledata      = NULL;
10381     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<', param);
10382     /* PL_rsfp_filters entries have fake IoDIRP() */
10383     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters, param);
10384
10385     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
10386
10387     PAD_CLONE_VARS(proto_perl, param);
10388
10389 #ifdef HAVE_INTERP_INTERN
10390     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10391 #endif
10392
10393     /* more statics moved here */
10394     PL_generation       = proto_perl->Igeneration;
10395     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
10396
10397     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
10398     PL_in_clean_all     = proto_perl->Iin_clean_all;
10399
10400     PL_uid              = proto_perl->Iuid;
10401     PL_euid             = proto_perl->Ieuid;
10402     PL_gid              = proto_perl->Igid;
10403     PL_egid             = proto_perl->Iegid;
10404     PL_nomemok          = proto_perl->Inomemok;
10405     PL_an               = proto_perl->Ian;
10406     PL_op_seqmax        = proto_perl->Iop_seqmax;
10407     PL_evalseq          = proto_perl->Ievalseq;
10408     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
10409     PL_origalen         = proto_perl->Iorigalen;
10410     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
10411     PL_osname           = SAVEPV(proto_perl->Iosname);
10412     PL_sh_path          = proto_perl->Ish_path; /* XXX never deallocated */
10413     PL_sighandlerp      = proto_perl->Isighandlerp;
10414
10415
10416     PL_runops           = proto_perl->Irunops;
10417
10418     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10419
10420 #ifdef CSH
10421     PL_cshlen           = proto_perl->Icshlen;
10422     PL_cshname          = proto_perl->Icshname; /* XXX never deallocated */
10423 #endif
10424
10425     PL_lex_state        = proto_perl->Ilex_state;
10426     PL_lex_defer        = proto_perl->Ilex_defer;
10427     PL_lex_expect       = proto_perl->Ilex_expect;
10428     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
10429     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
10430     PL_lex_starts       = proto_perl->Ilex_starts;
10431     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff, param);
10432     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl, param);
10433     PL_lex_op           = proto_perl->Ilex_op;
10434     PL_lex_inpat        = proto_perl->Ilex_inpat;
10435     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
10436     PL_lex_brackets     = proto_perl->Ilex_brackets;
10437     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10438     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
10439     PL_lex_casemods     = proto_perl->Ilex_casemods;
10440     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10441     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
10442
10443     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10444     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10445     PL_nexttoke         = proto_perl->Inexttoke;
10446
10447     /* XXX This is probably masking the deeper issue of why
10448      * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
10449      * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
10450      * (A little debugging with a watchpoint on it may help.)
10451      */
10452     if (SvANY(proto_perl->Ilinestr)) {
10453         PL_linestr              = sv_dup_inc(proto_perl->Ilinestr, param);
10454         i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
10455         PL_bufptr               = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10456         i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
10457         PL_oldbufptr    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10458         i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
10459         PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10460         i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
10461         PL_linestart    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10462     }
10463     else {
10464         PL_linestr = NEWSV(65,79);
10465         sv_upgrade(PL_linestr,SVt_PVIV);
10466         sv_setpvn(PL_linestr,"",0);
10467         PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
10468     }
10469     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10470     PL_pending_ident    = proto_perl->Ipending_ident;
10471     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
10472
10473     PL_expect           = proto_perl->Iexpect;
10474
10475     PL_multi_start      = proto_perl->Imulti_start;
10476     PL_multi_end        = proto_perl->Imulti_end;
10477     PL_multi_open       = proto_perl->Imulti_open;
10478     PL_multi_close      = proto_perl->Imulti_close;
10479
10480     PL_error_count      = proto_perl->Ierror_count;
10481     PL_subline          = proto_perl->Isubline;
10482     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
10483
10484     /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
10485     if (SvANY(proto_perl->Ilinestr)) {
10486         i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10487         PL_last_uni             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10488         i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10489         PL_last_lop             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10490         PL_last_lop_op  = proto_perl->Ilast_lop_op;
10491     }
10492     else {
10493         PL_last_uni     = SvPVX(PL_linestr);
10494         PL_last_lop     = SvPVX(PL_linestr);
10495         PL_last_lop_op  = 0;
10496     }
10497     PL_in_my            = proto_perl->Iin_my;
10498     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash, param);
10499 #ifdef FCRYPT
10500     PL_cryptseen        = proto_perl->Icryptseen;
10501 #endif
10502
10503     PL_hints            = proto_perl->Ihints;
10504
10505     PL_amagic_generation        = proto_perl->Iamagic_generation;
10506
10507 #ifdef USE_LOCALE_COLLATE
10508     PL_collation_ix     = proto_perl->Icollation_ix;
10509     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
10510     PL_collation_standard       = proto_perl->Icollation_standard;
10511     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
10512     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
10513 #endif /* USE_LOCALE_COLLATE */
10514
10515 #ifdef USE_LOCALE_NUMERIC
10516     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
10517     PL_numeric_standard = proto_perl->Inumeric_standard;
10518     PL_numeric_local    = proto_perl->Inumeric_local;
10519     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10520 #endif /* !USE_LOCALE_NUMERIC */
10521
10522     /* utf8 character classes */
10523     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10524     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10525     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10526     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10527     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
10528     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10529     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
10530     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
10531     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
10532     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
10533     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
10534     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
10535     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10536     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
10537     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10538     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10539     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10540     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
10541     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
10542     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
10543
10544     /* swatch cache */
10545     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
10546     PL_last_swash_klen  = 0;
10547     PL_last_swash_key[0]= '\0';
10548     PL_last_swash_tmps  = (U8*)NULL;
10549     PL_last_swash_slen  = 0;
10550
10551     /* perly.c globals */
10552     PL_yydebug          = proto_perl->Iyydebug;
10553     PL_yynerrs          = proto_perl->Iyynerrs;
10554     PL_yyerrflag        = proto_perl->Iyyerrflag;
10555     PL_yychar           = proto_perl->Iyychar;
10556     PL_yyval            = proto_perl->Iyyval;
10557     PL_yylval           = proto_perl->Iyylval;
10558
10559     PL_glob_index       = proto_perl->Iglob_index;
10560     PL_srand_called     = proto_perl->Isrand_called;
10561     PL_uudmap['M']      = 0;            /* reinits on demand */
10562     PL_bitcount         = Nullch;       /* reinits on demand */
10563
10564     if (proto_perl->Ipsig_pend) {
10565         Newz(0, PL_psig_pend, SIG_SIZE, int);
10566     }
10567     else {
10568         PL_psig_pend    = (int*)NULL;
10569     }
10570
10571     if (proto_perl->Ipsig_ptr) {
10572         Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
10573         Newz(0, PL_psig_name, SIG_SIZE, SV*);
10574         for (i = 1; i < SIG_SIZE; i++) {
10575             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10576             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10577         }
10578     }
10579     else {
10580         PL_psig_ptr     = (SV**)NULL;
10581         PL_psig_name    = (SV**)NULL;
10582     }
10583
10584     /* thrdvar.h stuff */
10585
10586     if (flags & CLONEf_COPY_STACKS) {
10587         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10588         PL_tmps_ix              = proto_perl->Ttmps_ix;
10589         PL_tmps_max             = proto_perl->Ttmps_max;
10590         PL_tmps_floor           = proto_perl->Ttmps_floor;
10591         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10592         i = 0;
10593         while (i <= PL_tmps_ix) {
10594             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10595             ++i;
10596         }
10597
10598         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10599         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10600         Newz(54, PL_markstack, i, I32);
10601         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
10602                                                   - proto_perl->Tmarkstack);
10603         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
10604                                                   - proto_perl->Tmarkstack);
10605         Copy(proto_perl->Tmarkstack, PL_markstack,
10606              PL_markstack_ptr - PL_markstack + 1, I32);
10607
10608         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10609          * NOTE: unlike the others! */
10610         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
10611         PL_scopestack_max       = proto_perl->Tscopestack_max;
10612         Newz(54, PL_scopestack, PL_scopestack_max, I32);
10613         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10614
10615         /* next push_return() sets PL_retstack[PL_retstack_ix]
10616          * NOTE: unlike the others! */
10617         PL_retstack_ix          = proto_perl->Tretstack_ix;
10618         PL_retstack_max         = proto_perl->Tretstack_max;
10619         Newz(54, PL_retstack, PL_retstack_max, OP*);
10620         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
10621
10622         /* NOTE: si_dup() looks at PL_markstack */
10623         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo, param);
10624
10625         /* PL_curstack          = PL_curstackinfo->si_stack; */
10626         PL_curstack             = av_dup(proto_perl->Tcurstack, param);
10627         PL_mainstack            = av_dup(proto_perl->Tmainstack, param);
10628
10629         /* next PUSHs() etc. set *(PL_stack_sp+1) */
10630         PL_stack_base           = AvARRAY(PL_curstack);
10631         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
10632                                                    - proto_perl->Tstack_base);
10633         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
10634
10635         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10636          * NOTE: unlike the others! */
10637         PL_savestack_ix         = proto_perl->Tsavestack_ix;
10638         PL_savestack_max        = proto_perl->Tsavestack_max;
10639         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10640         PL_savestack            = ss_dup(proto_perl, param);
10641     }
10642     else {
10643         init_stacks();
10644         ENTER;                  /* perl_destruct() wants to LEAVE; */
10645     }
10646
10647     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
10648     PL_top_env          = &PL_start_env;
10649
10650     PL_op               = proto_perl->Top;
10651
10652     PL_Sv               = Nullsv;
10653     PL_Xpv              = (XPV*)NULL;
10654     PL_na               = proto_perl->Tna;
10655
10656     PL_statbuf          = proto_perl->Tstatbuf;
10657     PL_statcache        = proto_perl->Tstatcache;
10658     PL_statgv           = gv_dup(proto_perl->Tstatgv, param);
10659     PL_statname         = sv_dup_inc(proto_perl->Tstatname, param);
10660 #ifdef HAS_TIMES
10661     PL_timesbuf         = proto_perl->Ttimesbuf;
10662 #endif
10663
10664     PL_tainted          = proto_perl->Ttainted;
10665     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
10666     PL_rs               = sv_dup_inc(proto_perl->Trs, param);
10667     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv, param);
10668     PL_ofs_sv           = sv_dup_inc(proto_perl->Tofs_sv, param);
10669     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv, param);
10670     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
10671     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget, param);
10672     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget, param);
10673     PL_formtarget       = sv_dup(proto_perl->Tformtarget, param);
10674
10675     PL_restartop        = proto_perl->Trestartop;
10676     PL_in_eval          = proto_perl->Tin_eval;
10677     PL_delaymagic       = proto_perl->Tdelaymagic;
10678     PL_dirty            = proto_perl->Tdirty;
10679     PL_localizing       = proto_perl->Tlocalizing;
10680
10681 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10682     PL_protect          = proto_perl->Tprotect;
10683 #endif
10684     PL_errors           = sv_dup_inc(proto_perl->Terrors, param);
10685     PL_av_fetch_sv      = Nullsv;
10686     PL_hv_fetch_sv      = Nullsv;
10687     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
10688     PL_modcount         = proto_perl->Tmodcount;
10689     PL_lastgotoprobe    = Nullop;
10690     PL_dumpindent       = proto_perl->Tdumpindent;
10691
10692     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10693     PL_sortstash        = hv_dup(proto_perl->Tsortstash, param);
10694     PL_firstgv          = gv_dup(proto_perl->Tfirstgv, param);
10695     PL_secondgv         = gv_dup(proto_perl->Tsecondgv, param);
10696     PL_sortcxix         = proto_perl->Tsortcxix;
10697     PL_efloatbuf        = Nullch;               /* reinits on demand */
10698     PL_efloatsize       = 0;                    /* reinits on demand */
10699
10700     /* regex stuff */
10701
10702     PL_screamfirst      = NULL;
10703     PL_screamnext       = NULL;
10704     PL_maxscream        = -1;                   /* reinits on demand */
10705     PL_lastscream       = Nullsv;
10706
10707     PL_watchaddr        = NULL;
10708     PL_watchok          = Nullch;
10709
10710     PL_regdummy         = proto_perl->Tregdummy;
10711     PL_regcomp_parse    = Nullch;
10712     PL_regxend          = Nullch;
10713     PL_regcode          = (regnode*)NULL;
10714     PL_regnaughty       = 0;
10715     PL_regsawback       = 0;
10716     PL_regprecomp       = Nullch;
10717     PL_regnpar          = 0;
10718     PL_regsize          = 0;
10719     PL_regflags         = 0;
10720     PL_regseen          = 0;
10721     PL_seen_zerolen     = 0;
10722     PL_seen_evals       = 0;
10723     PL_regcomp_rx       = (regexp*)NULL;
10724     PL_extralen         = 0;
10725     PL_colorset         = 0;            /* reinits PL_colors[] */
10726     /*PL_colors[6]      = {0,0,0,0,0,0};*/
10727     PL_reg_whilem_seen  = 0;
10728     PL_reginput         = Nullch;
10729     PL_regbol           = Nullch;
10730     PL_regeol           = Nullch;
10731     PL_regstartp        = (I32*)NULL;
10732     PL_regendp          = (I32*)NULL;
10733     PL_reglastparen     = (U32*)NULL;
10734     PL_regtill          = Nullch;
10735     PL_reg_start_tmp    = (char**)NULL;
10736     PL_reg_start_tmpl   = 0;
10737     PL_regdata          = (struct reg_data*)NULL;
10738     PL_bostr            = Nullch;
10739     PL_reg_flags        = 0;
10740     PL_reg_eval_set     = 0;
10741     PL_regnarrate       = 0;
10742     PL_regprogram       = (regnode*)NULL;
10743     PL_regindent        = 0;
10744     PL_regcc            = (CURCUR*)NULL;
10745     PL_reg_call_cc      = (struct re_cc_state*)NULL;
10746     PL_reg_re           = (regexp*)NULL;
10747     PL_reg_ganch        = Nullch;
10748     PL_reg_sv           = Nullsv;
10749     PL_reg_match_utf8   = FALSE;
10750     PL_reg_magic        = (MAGIC*)NULL;
10751     PL_reg_oldpos       = 0;
10752     PL_reg_oldcurpm     = (PMOP*)NULL;
10753     PL_reg_curpm        = (PMOP*)NULL;
10754     PL_reg_oldsaved     = Nullch;
10755     PL_reg_oldsavedlen  = 0;
10756     PL_reg_maxiter      = 0;
10757     PL_reg_leftiter     = 0;
10758     PL_reg_poscache     = Nullch;
10759     PL_reg_poscache_size= 0;
10760
10761     /* RE engine - function pointers */
10762     PL_regcompp         = proto_perl->Tregcompp;
10763     PL_regexecp         = proto_perl->Tregexecp;
10764     PL_regint_start     = proto_perl->Tregint_start;
10765     PL_regint_string    = proto_perl->Tregint_string;
10766     PL_regfree          = proto_perl->Tregfree;
10767
10768     PL_reginterp_cnt    = 0;
10769     PL_reg_starttry     = 0;
10770
10771     /* Pluggable optimizer */
10772     PL_peepp            = proto_perl->Tpeepp;
10773
10774     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10775         ptr_table_free(PL_ptr_table);
10776         PL_ptr_table = NULL;
10777     }
10778
10779     /* Call the ->CLONE method, if it exists, for each of the stashes
10780        identified by sv_dup() above.
10781     */
10782     while(av_len(param->stashes) != -1) {
10783         HV* stash = (HV*) av_shift(param->stashes);
10784         GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10785         if (cloner && GvCV(cloner)) {
10786             dSP;
10787             ENTER;
10788             SAVETMPS;
10789             PUSHMARK(SP);
10790            XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10791             PUTBACK;
10792             call_sv((SV*)GvCV(cloner), G_DISCARD);
10793             FREETMPS;
10794             LEAVE;
10795         }
10796     }
10797
10798     SvREFCNT_dec(param->stashes);
10799
10800     return my_perl;
10801 }
10802
10803 #endif /* USE_ITHREADS */
10804
10805 /*
10806 =head1 Unicode Support
10807
10808 =for apidoc sv_recode_to_utf8
10809
10810 The encoding is assumed to be an Encode object, on entry the PV
10811 of the sv is assumed to be octets in that encoding, and the sv
10812 will be converted into Unicode (and UTF-8).
10813
10814 If the sv already is UTF-8 (or if it is not POK), or if the encoding
10815 is not a reference, nothing is done to the sv.  If the encoding is not
10816 an C<Encode::XS> Encoding object, bad things will happen.
10817 (See F<lib/encoding.pm> and L<Encode>).
10818
10819 The PV of the sv is returned.
10820
10821 =cut */
10822
10823 char *
10824 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
10825 {
10826     if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
10827           SV *uni;
10828           STRLEN len;
10829           char *s;
10830           dSP;
10831           ENTER;
10832           SAVETMPS;
10833           PUSHMARK(sp);
10834           EXTEND(SP, 3);
10835           XPUSHs(encoding);
10836           XPUSHs(sv);
10837 /*
10838   NI-S 2002/07/09
10839   Passing sv_yes is wrong - it needs to be or'ed set of constants
10840   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
10841   remove converted chars from source.
10842
10843   Both will default the value - let them.
10844
10845           XPUSHs(&PL_sv_yes);
10846 */
10847           PUTBACK;
10848           call_method("decode", G_SCALAR);
10849           SPAGAIN;
10850           uni = POPs;
10851           PUTBACK;
10852           s = SvPV(uni, len);
10853           if (s != SvPVX(sv)) {
10854                SvGROW(sv, len + 1);
10855                Move(s, SvPVX(sv), len, char);
10856                SvCUR_set(sv, len);
10857                SvPVX(sv)[len] = 0;
10858           }
10859           FREETMPS;
10860           LEAVE;
10861           SvUTF8_on(sv);
10862     }
10863     return SvPVX(sv);
10864 }
10865
10866
10867