sv.c

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