sv.c

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