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