sv.c

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