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