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