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