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