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