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) {
4563         if (SvMAGIC(sv))
4564             mg_free(sv);
4565         if (SvFLAGS(sv) & SVpad_TYPED)
4566             SvREFCNT_dec(SvSTASH(sv));
4567     }
4568     stash = NULL;
4569     switch (SvTYPE(sv)) {
4570     case SVt_PVIO:
4571         if (IoIFP(sv) &&
4572             IoIFP(sv) != PerlIO_stdin() &&
4573             IoIFP(sv) != PerlIO_stdout() &&
4574             IoIFP(sv) != PerlIO_stderr())
4575         {
4576             io_close((IO*)sv, FALSE);
4577         }
4578         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4579             PerlDir_close(IoDIRP(sv));
4580         IoDIRP(sv) = (DIR*)NULL;
4581         Safefree(IoTOP_NAME(sv));
4582         Safefree(IoFMT_NAME(sv));
4583         Safefree(IoBOTTOM_NAME(sv));
4584         /* FALL THROUGH */
4585     case SVt_PVBM:
4586         goto freescalar;
4587     case SVt_PVCV:
4588     case SVt_PVFM:
4589         cv_undef((CV*)sv);
4590         goto freescalar;
4591     case SVt_PVHV:
4592         hv_undef((HV*)sv);
4593         break;
4594     case SVt_PVAV:
4595         av_undef((AV*)sv);
4596         break;
4597     case SVt_PVLV:
4598         SvREFCNT_dec(LvTARG(sv));
4599         goto freescalar;
4600     case SVt_PVGV:
4601         gp_free((GV*)sv);
4602         Safefree(GvNAME(sv));
4603         /* cannot decrease stash refcount yet, as we might recursively delete
4604            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4605            of stash until current sv is completely gone.
4606            -- JohnPC, 27 Mar 1998 */
4607         stash = GvSTASH(sv);
4608         /* FALL THROUGH */
4609     case SVt_PVMG:
4610     case SVt_PVNV:
4611     case SVt_PVIV:
4612       freescalar:
4613         (void)SvOOK_off(sv);
4614         /* FALL THROUGH */
4615     case SVt_PV:
4616     case SVt_RV:
4617         if (SvROK(sv)) {
4618             if (SvWEAKREF(sv))
4619                 sv_del_backref(sv);
4620             else
4621                 SvREFCNT_dec(SvRV(sv));
4622         }
4623         else if (SvPVX(sv) && SvLEN(sv))
4624             Safefree(SvPVX(sv));
4625         else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4626             unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4627             SvFAKE_off(sv);
4628         }
4629         break;
4630 /*
4631     case SVt_NV:
4632     case SVt_IV:
4633     case SVt_NULL:
4634         break;
4635 */
4636     }
4637
4638     switch (SvTYPE(sv)) {
4639     case SVt_NULL:
4640         break;
4641     case SVt_IV:
4642         del_XIV(SvANY(sv));
4643         break;
4644     case SVt_NV:
4645         del_XNV(SvANY(sv));
4646         break;
4647     case SVt_RV:
4648         del_XRV(SvANY(sv));
4649         break;
4650     case SVt_PV:
4651         del_XPV(SvANY(sv));
4652         break;
4653     case SVt_PVIV:
4654         del_XPVIV(SvANY(sv));
4655         break;
4656     case SVt_PVNV:
4657         del_XPVNV(SvANY(sv));
4658         break;
4659     case SVt_PVMG:
4660         del_XPVMG(SvANY(sv));
4661         break;
4662     case SVt_PVLV:
4663         del_XPVLV(SvANY(sv));
4664         break;
4665     case SVt_PVAV:
4666         del_XPVAV(SvANY(sv));
4667         break;
4668     case SVt_PVHV:
4669         del_XPVHV(SvANY(sv));
4670         break;
4671     case SVt_PVCV:
4672         del_XPVCV(SvANY(sv));
4673         break;
4674     case SVt_PVGV:
4675         del_XPVGV(SvANY(sv));
4676         /* code duplication for increased performance. */
4677         SvFLAGS(sv) &= SVf_BREAK;
4678         SvFLAGS(sv) |= SVTYPEMASK;
4679         /* decrease refcount of the stash that owns this GV, if any */
4680         if (stash)
4681             SvREFCNT_dec(stash);
4682         return; /* not break, SvFLAGS reset already happened */
4683     case SVt_PVBM:
4684         del_XPVBM(SvANY(sv));
4685         break;
4686     case SVt_PVFM:
4687         del_XPVFM(SvANY(sv));
4688         break;
4689     case SVt_PVIO:
4690         del_XPVIO(SvANY(sv));
4691         break;
4692     }
4693     SvFLAGS(sv) &= SVf_BREAK;
4694     SvFLAGS(sv) |= SVTYPEMASK;
4695 }
4696
4697 SV *
4698 Perl_sv_newref(pTHX_ SV *sv)
4699 {
4700     if (sv)
4701         ATOMIC_INC(SvREFCNT(sv));
4702     return sv;
4703 }
4704
4705 /*
4706 =for apidoc sv_free
4707
4708 Free the memory used by an SV.
4709
4710 =cut
4711 */
4712
4713 void
4714 Perl_sv_free(pTHX_ SV *sv)
4715 {
4716     int refcount_is_zero;
4717
4718     if (!sv)
4719         return;
4720     if (SvREFCNT(sv) == 0) {
4721         if (SvFLAGS(sv) & SVf_BREAK)
4722             return;
4723         if (PL_in_clean_all) /* All is fair */
4724             return;
4725         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4726             /* make sure SvREFCNT(sv)==0 happens very seldom */
4727             SvREFCNT(sv) = (~(U32)0)/2;
4728             return;
4729         }
4730         if (ckWARN_d(WARN_INTERNAL))
4731             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4732         return;
4733     }
4734     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4735     if (!refcount_is_zero)
4736         return;
4737 #ifdef DEBUGGING
4738     if (SvTEMP(sv)) {
4739         if (ckWARN_d(WARN_DEBUGGING))
4740             Perl_warner(aTHX_ WARN_DEBUGGING,
4741                         "Attempt to free temp prematurely: SV 0x%"UVxf,
4742                         PTR2UV(sv));
4743         return;
4744     }
4745 #endif
4746     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4747         /* make sure SvREFCNT(sv)==0 happens very seldom */
4748         SvREFCNT(sv) = (~(U32)0)/2;
4749         return;
4750     }
4751     sv_clear(sv);
4752     if (! SvREFCNT(sv))
4753         del_SV(sv);
4754 }
4755
4756 /*
4757 =for apidoc sv_len
4758
4759 Returns the length of the string in the SV.  See also C<SvCUR>.
4760
4761 =cut
4762 */
4763
4764 STRLEN
4765 Perl_sv_len(pTHX_ register SV *sv)
4766 {
4767     char *junk;
4768     STRLEN len;
4769
4770     if (!sv)
4771         return 0;
4772
4773     if (SvGMAGICAL(sv))
4774         len = mg_length(sv);
4775     else
4776         junk = SvPV(sv, len);
4777     return len;
4778 }
4779
4780 /*
4781 =for apidoc sv_len_utf8
4782
4783 Returns the number of characters in the string in an SV, counting wide
4784 UTF8 bytes as a single character.
4785
4786 =cut
4787 */
4788
4789 STRLEN
4790 Perl_sv_len_utf8(pTHX_ register SV *sv)
4791 {
4792     if (!sv)
4793         return 0;
4794
4795     if (SvGMAGICAL(sv))
4796         return mg_length(sv);
4797     else
4798     {
4799         STRLEN len;
4800         U8 *s = (U8*)SvPV(sv, len);
4801
4802         return Perl_utf8_length(aTHX_ s, s + len);
4803     }
4804 }
4805
4806 void
4807 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4808 {
4809     U8 *start;
4810     U8 *s;
4811     U8 *send;
4812     I32 uoffset = *offsetp;
4813     STRLEN len;
4814
4815     if (!sv)
4816         return;
4817
4818     start = s = (U8*)SvPV(sv, len);
4819     send = s + len;
4820     while (s < send && uoffset--)
4821         s += UTF8SKIP(s);
4822     if (s >= send)
4823         s = send;
4824     *offsetp = s - start;
4825     if (lenp) {
4826         I32 ulen = *lenp;
4827         start = s;
4828         while (s < send && ulen--)
4829             s += UTF8SKIP(s);
4830         if (s >= send)
4831             s = send;
4832         *lenp = s - start;
4833     }
4834     return;
4835 }
4836
4837 void
4838 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4839 {
4840     U8 *s;
4841     U8 *send;
4842     STRLEN len;
4843
4844     if (!sv)
4845         return;
4846
4847     s = (U8*)SvPV(sv, len);
4848     if (len < *offsetp)
4849         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4850     send = s + *offsetp;
4851     len = 0;
4852     while (s < send) {
4853         STRLEN n;
4854         /* Call utf8n_to_uvchr() to validate the sequence */
4855         utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4856         if (n > 0) {
4857             s += n;
4858             len++;
4859         }
4860         else
4861             break;
4862     }
4863     *offsetp = len;
4864     return;
4865 }
4866
4867 /*
4868 =for apidoc sv_eq
4869
4870 Returns a boolean indicating whether the strings in the two SVs are
4871 identical.
4872
4873 =cut
4874 */
4875
4876 I32
4877 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4878 {
4879     char *pv1;
4880     STRLEN cur1;
4881     char *pv2;
4882     STRLEN cur2;
4883     I32  eq     = 0;
4884     char *tpv   = Nullch;
4885
4886     if (!sv1) {
4887         pv1 = "";
4888         cur1 = 0;
4889     }
4890     else
4891         pv1 = SvPV(sv1, cur1);
4892
4893     if (!sv2){
4894         pv2 = "";
4895         cur2 = 0;
4896     }
4897     else
4898         pv2 = SvPV(sv2, cur2);
4899
4900     /* do not utf8ize the comparands as a side-effect */
4901     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4902         bool is_utf8 = TRUE;
4903         /* UTF-8ness differs */
4904         if (PL_hints & HINT_UTF8_DISTINCT)
4905             return FALSE;
4906
4907         if (SvUTF8(sv1)) {
4908             /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4909             char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4910             if (pv != pv1)
4911                 pv1 = tpv = pv;
4912         }
4913         else {
4914             /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4915             char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4916             if (pv != pv2)
4917                 pv2 = tpv = pv;
4918         }
4919         if (is_utf8) {
4920             /* Downgrade not possible - cannot be eq */
4921             return FALSE;
4922         }
4923     }
4924
4925     if (cur1 == cur2)
4926         eq = memEQ(pv1, pv2, cur1);
4927
4928     if (tpv != Nullch)
4929         Safefree(tpv);
4930
4931     return eq;
4932 }
4933
4934 /*
4935 =for apidoc sv_cmp
4936
4937 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
4938 string in C<sv1> is less than, equal to, or greater than the string in
4939 C<sv2>.
4940
4941 =cut
4942 */
4943
4944 I32
4945 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4946 {
4947     STRLEN cur1, cur2;
4948     char *pv1, *pv2;
4949     I32  cmp;
4950     bool pv1tmp = FALSE;
4951     bool pv2tmp = FALSE;
4952
4953     if (!sv1) {
4954         pv1 = "";
4955         cur1 = 0;
4956     }
4957     else
4958         pv1 = SvPV(sv1, cur1);
4959
4960     if (!sv2){
4961         pv2 = "";
4962         cur2 = 0;
4963     }
4964     else
4965         pv2 = SvPV(sv2, cur2);
4966
4967     /* do not utf8ize the comparands as a side-effect */
4968     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4969         if (PL_hints & HINT_UTF8_DISTINCT)
4970             return SvUTF8(sv1) ? 1 : -1;
4971
4972         if (SvUTF8(sv1)) {
4973             pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4974             pv2tmp = TRUE;
4975         }
4976         else {
4977             pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4978             pv1tmp = TRUE;
4979         }
4980     }
4981
4982     if (!cur1) {
4983         cmp = cur2 ? -1 : 0;
4984     } else if (!cur2) {
4985         cmp = 1;
4986     } else {
4987         I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4988
4989         if (retval) {
4990             cmp = retval < 0 ? -1 : 1;
4991         } else if (cur1 == cur2) {
4992             cmp = 0;
4993         } else {
4994             cmp = cur1 < cur2 ? -1 : 1;
4995         }
4996     }
4997
4998     if (pv1tmp)
4999         Safefree(pv1);
5000     if (pv2tmp)
5001         Safefree(pv2);
5002
5003     return cmp;
5004 }
5005
5006 /*
5007 =for apidoc sv_cmp_locale
5008
5009 Compares the strings in two SVs in a locale-aware manner. See
5010 L</sv_cmp_locale>
5011
5012 =cut
5013 */
5014
5015 I32
5016 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5017 {
5018 #ifdef USE_LOCALE_COLLATE
5019
5020     char *pv1, *pv2;
5021     STRLEN len1, len2;
5022     I32 retval;
5023
5024     if (PL_collation_standard)
5025         goto raw_compare;
5026
5027     len1 = 0;
5028     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5029     len2 = 0;
5030     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5031
5032     if (!pv1 || !len1) {
5033         if (pv2 && len2)
5034             return -1;
5035         else
5036             goto raw_compare;
5037     }
5038     else {
5039         if (!pv2 || !len2)
5040             return 1;
5041     }
5042
5043     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5044
5045     if (retval)
5046         return retval < 0 ? -1 : 1;
5047
5048     /*
5049      * When the result of collation is equality, that doesn't mean
5050      * that there are no differences -- some locales exclude some
5051      * characters from consideration.  So to avoid false equalities,
5052      * we use the raw string as a tiebreaker.
5053      */
5054
5055   raw_compare:
5056     /* FALL THROUGH */
5057
5058 #endif /* USE_LOCALE_COLLATE */
5059
5060     return sv_cmp(sv1, sv2);
5061 }
5062
5063 #ifdef USE_LOCALE_COLLATE
5064 /*
5065  * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5066  * scalar data of the variable transformed to such a format that
5067  * a normal memory comparison can be used to compare the data
5068  * according to the locale settings.
5069  */
5070 char *
5071 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5072 {
5073     MAGIC *mg;
5074
5075     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5076     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5077         char *s, *xf;
5078         STRLEN len, xlen;
5079
5080         if (mg)
5081             Safefree(mg->mg_ptr);
5082         s = SvPV(sv, len);
5083         if ((xf = mem_collxfrm(s, len, &xlen))) {
5084             if (SvREADONLY(sv)) {
5085                 SAVEFREEPV(xf);
5086                 *nxp = xlen;
5087                 return xf + sizeof(PL_collation_ix);
5088             }
5089             if (! mg) {
5090                 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5091                 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5092                 assert(mg);
5093             }
5094             mg->mg_ptr = xf;
5095             mg->mg_len = xlen;
5096         }
5097         else {
5098             if (mg) {
5099                 mg->mg_ptr = NULL;
5100                 mg->mg_len = -1;
5101             }
5102         }
5103     }
5104     if (mg && mg->mg_ptr) {
5105         *nxp = mg->mg_len;
5106         return mg->mg_ptr + sizeof(PL_collation_ix);
5107     }
5108     else {
5109         *nxp = 0;
5110         return NULL;
5111     }
5112 }
5113
5114 #endif /* USE_LOCALE_COLLATE */
5115
5116 /*
5117 =for apidoc sv_gets
5118
5119 Get a line from the filehandle and store it into the SV, optionally
5120 appending to the currently-stored string.
5121
5122 =cut
5123 */
5124
5125 char *
5126 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5127 {
5128     char *rsptr;
5129     STRLEN rslen;
5130     register STDCHAR rslast;
5131     register STDCHAR *bp;
5132     register I32 cnt;
5133     I32 i = 0;
5134
5135     SV_CHECK_THINKFIRST(sv);
5136     (void)SvUPGRADE(sv, SVt_PV);
5137
5138     SvSCREAM_off(sv);
5139
5140     if (RsSNARF(PL_rs)) {
5141         rsptr = NULL;
5142         rslen = 0;
5143     }
5144     else if (RsRECORD(PL_rs)) {
5145       I32 recsize, bytesread;
5146       char *buffer;
5147
5148       /* Grab the size of the record we're getting */
5149       recsize = SvIV(SvRV(PL_rs));
5150       (void)SvPOK_only(sv);    /* Validate pointer */
5151       buffer = SvGROW(sv, recsize + 1);
5152       /* Go yank in */
5153 #ifdef VMS
5154       /* VMS wants read instead of fread, because fread doesn't respect */
5155       /* RMS record boundaries. This is not necessarily a good thing to be */
5156       /* doing, but we've got no other real choice */
5157       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5158 #else
5159       bytesread = PerlIO_read(fp, buffer, recsize);
5160 #endif
5161       SvCUR_set(sv, bytesread);
5162       buffer[bytesread] = '\0';
5163       if (PerlIO_isutf8(fp))
5164         SvUTF8_on(sv);
5165       else
5166         SvUTF8_off(sv);
5167       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5168     }
5169     else if (RsPARA(PL_rs)) {
5170         rsptr = "\n\n";
5171         rslen = 2;
5172     }
5173     else {
5174         /* Get $/ i.e. PL_rs into same encoding as stream wants */
5175         if (PerlIO_isutf8(fp)) {
5176             rsptr = SvPVutf8(PL_rs, rslen);
5177         }
5178         else {
5179             if (SvUTF8(PL_rs)) {
5180                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5181                     Perl_croak(aTHX_ "Wide character in $/");
5182                 }
5183             }
5184             rsptr = SvPV(PL_rs, rslen);
5185         }
5186     }
5187
5188     rslast = rslen ? rsptr[rslen - 1] : '\0';
5189
5190     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
5191         do {                    /* to make sure file boundaries work right */
5192             if (PerlIO_eof(fp))
5193                 return 0;
5194             i = PerlIO_getc(fp);
5195             if (i != '\n') {
5196                 if (i == -1)
5197                     return 0;
5198                 PerlIO_ungetc(fp,i);
5199                 break;
5200             }
5201         } while (i != EOF);
5202     }
5203
5204     /* See if we know enough about I/O mechanism to cheat it ! */
5205
5206     /* This used to be #ifdef test - it is made run-time test for ease
5207        of abstracting out stdio interface. One call should be cheap
5208        enough here - and may even be a macro allowing compile
5209        time optimization.
5210      */
5211
5212     if (PerlIO_fast_gets(fp)) {
5213
5214     /*
5215      * We're going to steal some values from the stdio struct
5216      * and put EVERYTHING in the innermost loop into registers.
5217      */
5218     register STDCHAR *ptr;
5219     STRLEN bpx;
5220     I32 shortbuffered;
5221
5222 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5223     /* An ungetc()d char is handled separately from the regular
5224      * buffer, so we getc() it back out and stuff it in the buffer.
5225      */
5226     i = PerlIO_getc(fp);
5227     if (i == EOF) return 0;
5228     *(--((*fp)->_ptr)) = (unsigned char) i;
5229     (*fp)->_cnt++;
5230 #endif
5231
5232     /* Here is some breathtakingly efficient cheating */
5233
5234     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
5235     (void)SvPOK_only(sv);               /* validate pointer */
5236     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5237         if (cnt > 80 && SvLEN(sv) > append) {
5238             shortbuffered = cnt - SvLEN(sv) + append + 1;
5239             cnt -= shortbuffered;
5240         }
5241         else {
5242             shortbuffered = 0;
5243             /* remember that cnt can be negative */
5244             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5245         }
5246     }
5247     else
5248         shortbuffered = 0;
5249     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
5250     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5251     DEBUG_P(PerlIO_printf(Perl_debug_log,
5252         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5253     DEBUG_P(PerlIO_printf(Perl_debug_log,
5254         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5255                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5256                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5257     for (;;) {
5258       screamer:
5259         if (cnt > 0) {
5260             if (rslen) {
5261                 while (cnt > 0) {                    /* this     |  eat */
5262                     cnt--;
5263                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
5264                         goto thats_all_folks;        /* screams  |  sed :-) */
5265                 }
5266             }
5267             else {
5268                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
5269                 bp += cnt;                           /* screams  |  dust */
5270                 ptr += cnt;                          /* louder   |  sed :-) */
5271                 cnt = 0;
5272             }
5273         }
5274
5275         if (shortbuffered) {            /* oh well, must extend */
5276             cnt = shortbuffered;
5277             shortbuffered = 0;
5278             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5279             SvCUR_set(sv, bpx);
5280             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5281             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5282             continue;
5283         }
5284
5285         DEBUG_P(PerlIO_printf(Perl_debug_log,
5286                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5287                               PTR2UV(ptr),(long)cnt));
5288         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5289         DEBUG_P(PerlIO_printf(Perl_debug_log,
5290             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5291             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5292             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5293         /* This used to call 'filbuf' in stdio form, but as that behaves like
5294            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5295            another abstraction.  */
5296         i   = PerlIO_getc(fp);          /* get more characters */
5297         DEBUG_P(PerlIO_printf(Perl_debug_log,
5298             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5299             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5300             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5301         cnt = PerlIO_get_cnt(fp);
5302         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
5303         DEBUG_P(PerlIO_printf(Perl_debug_log,
5304             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5305
5306         if (i == EOF)                   /* all done for ever? */
5307             goto thats_really_all_folks;
5308
5309         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5310         SvCUR_set(sv, bpx);
5311         SvGROW(sv, bpx + cnt + 2);
5312         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5313
5314         *bp++ = i;                      /* store character from PerlIO_getc */
5315
5316         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
5317             goto thats_all_folks;
5318     }
5319
5320 thats_all_folks:
5321     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5322           memNE((char*)bp - rslen, rsptr, rslen))
5323         goto screamer;                          /* go back to the fray */
5324 thats_really_all_folks:
5325     if (shortbuffered)
5326         cnt += shortbuffered;
5327         DEBUG_P(PerlIO_printf(Perl_debug_log,
5328             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5329     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
5330     DEBUG_P(PerlIO_printf(Perl_debug_log,
5331         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5332         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5333         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5334     *bp = '\0';
5335     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
5336     DEBUG_P(PerlIO_printf(Perl_debug_log,
5337         "Screamer: done, len=%ld, string=|%.*s|\n",
5338         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5339     }
5340    else
5341     {
5342 #ifndef EPOC
5343        /*The big, slow, and stupid way */
5344         STDCHAR buf[8192];
5345 #else
5346         /* Need to work around EPOC SDK features          */
5347         /* On WINS: MS VC5 generates calls to _chkstk,    */
5348         /* if a `large' stack frame is allocated          */
5349         /* gcc on MARM does not generate calls like these */
5350         STDCHAR buf[1024];
5351 #endif
5352
5353 screamer2:
5354         if (rslen) {
5355             register STDCHAR *bpe = buf + sizeof(buf);
5356             bp = buf;
5357             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5358                 ; /* keep reading */
5359             cnt = bp - buf;
5360         }
5361         else {
5362             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5363             /* Accomodate broken VAXC compiler, which applies U8 cast to
5364              * both args of ?: operator, causing EOF to change into 255
5365              */
5366             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5367         }
5368
5369         if (append)
5370             sv_catpvn(sv, (char *) buf, cnt);
5371         else
5372             sv_setpvn(sv, (char *) buf, cnt);
5373
5374         if (i != EOF &&                 /* joy */
5375             (!rslen ||
5376              SvCUR(sv) < rslen ||
5377              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5378         {
5379             append = -1;
5380             /*
5381              * If we're reading from a TTY and we get a short read,
5382              * indicating that the user hit his EOF character, we need
5383              * to notice it now, because if we try to read from the TTY
5384              * again, the EOF condition will disappear.
5385              *
5386              * The comparison of cnt to sizeof(buf) is an optimization
5387              * that prevents unnecessary calls to feof().
5388              *
5389              * - jik 9/25/96
5390              */
5391             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5392                 goto screamer2;
5393         }
5394     }
5395
5396     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
5397         while (i != EOF) {      /* to make sure file boundaries work right */
5398             i = PerlIO_getc(fp);
5399             if (i != '\n') {
5400                 PerlIO_ungetc(fp,i);
5401                 break;
5402             }
5403         }
5404     }
5405
5406     if (PerlIO_isutf8(fp))
5407         SvUTF8_on(sv);
5408     else
5409         SvUTF8_off(sv);
5410
5411     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5412 }
5413
5414
5415 /*
5416 =for apidoc sv_inc
5417
5418 Auto-increment of the value in the SV.
5419
5420 =cut
5421 */
5422
5423 void
5424 Perl_sv_inc(pTHX_ register SV *sv)
5425 {
5426     register char *d;
5427     int flags;
5428
5429     if (!sv)
5430         return;
5431     if (SvGMAGICAL(sv))
5432         mg_get(sv);
5433     if (SvTHINKFIRST(sv)) {
5434         if (SvREADONLY(sv)) {
5435             if (PL_curcop != &PL_compiling)
5436                 Perl_croak(aTHX_ PL_no_modify);
5437         }
5438         if (SvROK(sv)) {
5439             IV i;
5440             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5441                 return;
5442             i = PTR2IV(SvRV(sv));
5443             sv_unref(sv);
5444             sv_setiv(sv, i);
5445         }
5446     }
5447     flags = SvFLAGS(sv);
5448     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5449         /* It's (privately or publicly) a float, but not tested as an
5450            integer, so test it to see. */
5451         (void) SvIV(sv);
5452         flags = SvFLAGS(sv);
5453     }
5454     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5455         /* It's publicly an integer, or privately an integer-not-float */
5456       oops_its_int:
5457         if (SvIsUV(sv)) {
5458             if (SvUVX(sv) == UV_MAX)
5459                 sv_setnv(sv, (NV)UV_MAX + 1.0);
5460             else
5461                 (void)SvIOK_only_UV(sv);
5462                 ++SvUVX(sv);
5463         } else {
5464             if (SvIVX(sv) == IV_MAX)
5465                 sv_setuv(sv, (UV)IV_MAX + 1);
5466             else {
5467                 (void)SvIOK_only(sv);
5468                 ++SvIVX(sv);
5469             }
5470         }
5471         return;
5472     }
5473     if (flags & SVp_NOK) {
5474         (void)SvNOK_only(sv);
5475         SvNVX(sv) += 1.0;
5476         return;
5477     }
5478
5479     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5480         if ((flags & SVTYPEMASK) < SVt_PVIV)
5481             sv_upgrade(sv, SVt_IV);
5482         (void)SvIOK_only(sv);
5483         SvIVX(sv) = 1;
5484         return;
5485     }
5486     d = SvPVX(sv);
5487     while (isALPHA(*d)) d++;
5488     while (isDIGIT(*d)) d++;
5489     if (*d) {
5490 #ifdef PERL_PRESERVE_IVUV
5491         /* Got to punt this an an integer if needs be, but we don't issue
5492            warnings. Probably ought to make the sv_iv_please() that does
5493            the conversion if possible, and silently.  */
5494         I32 numtype = looks_like_number(sv);
5495         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5496             /* Need to try really hard to see if it's an integer.
5497                9.22337203685478e+18 is an integer.
5498                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5499                so $a="9.22337203685478e+18"; $a+0; $a++
5500                needs to be the same as $a="9.22337203685478e+18"; $a++
5501                or we go insane. */
5502
5503             (void) sv_2iv(sv);
5504             if (SvIOK(sv))
5505                 goto oops_its_int;
5506
5507             /* sv_2iv *should* have made this an NV */
5508             if (flags & SVp_NOK) {
5509                 (void)SvNOK_only(sv);
5510                 SvNVX(sv) += 1.0;
5511                 return;
5512             }
5513             /* I don't think we can get here. Maybe I should assert this
5514                And if we do get here I suspect that sv_setnv will croak. NWC
5515                Fall through. */
5516 #if defined(USE_LONG_DOUBLE)
5517             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",
5518                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5519 #else
5520             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5521                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5522 #endif
5523         }
5524 #endif /* PERL_PRESERVE_IVUV */
5525         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5526         return;
5527     }
5528     d--;
5529     while (d >= SvPVX(sv)) {
5530         if (isDIGIT(*d)) {
5531             if (++*d <= '9')
5532                 return;
5533             *(d--) = '0';
5534         }
5535         else {
5536 #ifdef EBCDIC
5537             /* MKS: The original code here died if letters weren't consecutive.
5538              * at least it didn't have to worry about non-C locales.  The
5539              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5540              * arranged in order (although not consecutively) and that only
5541              * [A-Za-z] are accepted by isALPHA in the C locale.
5542              */
5543             if (*d != 'z' && *d != 'Z') {
5544                 do { ++*d; } while (!isALPHA(*d));
5545                 return;
5546             }
5547             *(d--) -= 'z' - 'a';
5548 #else
5549             ++*d;
5550             if (isALPHA(*d))
5551                 return;
5552             *(d--) -= 'z' - 'a' + 1;
5553 #endif
5554         }
5555     }
5556     /* oh,oh, the number grew */
5557     SvGROW(sv, SvCUR(sv) + 2);
5558     SvCUR(sv)++;
5559     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5560         *d = d[-1];
5561     if (isDIGIT(d[1]))
5562         *d = '1';
5563     else
5564         *d = d[1];
5565 }
5566
5567 /*
5568 =for apidoc sv_dec
5569
5570 Auto-decrement of the value in the SV.
5571
5572 =cut
5573 */
5574
5575 void
5576 Perl_sv_dec(pTHX_ register SV *sv)
5577 {
5578     int flags;
5579
5580     if (!sv)
5581         return;
5582     if (SvGMAGICAL(sv))
5583         mg_get(sv);
5584     if (SvTHINKFIRST(sv)) {
5585         if (SvREADONLY(sv)) {
5586             if (PL_curcop != &PL_compiling)
5587                 Perl_croak(aTHX_ PL_no_modify);
5588         }
5589         if (SvROK(sv)) {
5590             IV i;
5591             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5592                 return;
5593             i = PTR2IV(SvRV(sv));
5594             sv_unref(sv);
5595             sv_setiv(sv, i);
5596         }
5597     }
5598     /* Unlike sv_inc we don't have to worry about string-never-numbers
5599        and keeping them magic. But we mustn't warn on punting */
5600     flags = SvFLAGS(sv);
5601     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5602         /* It's publicly an integer, or privately an integer-not-float */
5603       oops_its_int:
5604         if (SvIsUV(sv)) {
5605             if (SvUVX(sv) == 0) {
5606                 (void)SvIOK_only(sv);
5607                 SvIVX(sv) = -1;
5608             }
5609             else {
5610                 (void)SvIOK_only_UV(sv);
5611                 --SvUVX(sv);
5612             }
5613         } else {
5614             if (SvIVX(sv) == IV_MIN)
5615                 sv_setnv(sv, (NV)IV_MIN - 1.0);
5616             else {
5617                 (void)SvIOK_only(sv);
5618                 --SvIVX(sv);
5619             }
5620         }
5621         return;
5622     }
5623     if (flags & SVp_NOK) {
5624         SvNVX(sv) -= 1.0;
5625         (void)SvNOK_only(sv);
5626         return;
5627     }
5628     if (!(flags & SVp_POK)) {
5629         if ((flags & SVTYPEMASK) < SVt_PVNV)
5630             sv_upgrade(sv, SVt_NV);
5631         SvNVX(sv) = -1.0;
5632         (void)SvNOK_only(sv);
5633         return;
5634     }
5635 #ifdef PERL_PRESERVE_IVUV
5636     {
5637         I32 numtype = looks_like_number(sv);
5638         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5639             /* Need to try really hard to see if it's an integer.
5640                9.22337203685478e+18 is an integer.
5641                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5642                so $a="9.22337203685478e+18"; $a+0; $a--
5643                needs to be the same as $a="9.22337203685478e+18"; $a--
5644                or we go insane. */
5645
5646             (void) sv_2iv(sv);
5647             if (SvIOK(sv))
5648                 goto oops_its_int;
5649
5650             /* sv_2iv *should* have made this an NV */
5651             if (flags & SVp_NOK) {
5652                 (void)SvNOK_only(sv);
5653                 SvNVX(sv) -= 1.0;
5654                 return;
5655             }
5656             /* I don't think we can get here. Maybe I should assert this
5657                And if we do get here I suspect that sv_setnv will croak. NWC
5658                Fall through. */
5659 #if defined(USE_LONG_DOUBLE)
5660             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",
5661                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5662 #else
5663             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5664                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5665 #endif
5666         }
5667     }
5668 #endif /* PERL_PRESERVE_IVUV */
5669     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5670 }
5671
5672 /*
5673 =for apidoc sv_mortalcopy
5674
5675 Creates a new SV which is a copy of the original SV.  The new SV is marked
5676 as mortal.
5677
5678 =cut
5679 */
5680
5681 /* Make a string that will exist for the duration of the expression
5682  * evaluation.  Actually, it may have to last longer than that, but
5683  * hopefully we won't free it until it has been assigned to a
5684  * permanent location. */
5685
5686 SV *
5687 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5688 {
5689     register SV *sv;
5690
5691     new_SV(sv);
5692     sv_setsv(sv,oldstr);
5693     EXTEND_MORTAL(1);
5694     PL_tmps_stack[++PL_tmps_ix] = sv;
5695     SvTEMP_on(sv);
5696     return sv;
5697 }
5698
5699 /*
5700 =for apidoc sv_newmortal
5701
5702 Creates a new SV which is mortal.  The reference count of the SV is set to 1.
5703
5704 =cut
5705 */
5706
5707 SV *
5708 Perl_sv_newmortal(pTHX)
5709 {
5710     register SV *sv;
5711
5712     new_SV(sv);
5713     SvFLAGS(sv) = SVs_TEMP;
5714     EXTEND_MORTAL(1);
5715     PL_tmps_stack[++PL_tmps_ix] = sv;
5716     return sv;
5717 }
5718
5719 /*
5720 =for apidoc sv_2mortal
5721
5722 Marks an SV as mortal.  The SV will be destroyed when the current context
5723 ends.
5724
5725 =cut
5726 */
5727
5728 /* same thing without the copying */
5729
5730 SV *
5731 Perl_sv_2mortal(pTHX_ register SV *sv)
5732 {
5733     if (!sv)
5734         return sv;
5735     if (SvREADONLY(sv) && SvIMMORTAL(sv))
5736         return sv;
5737     EXTEND_MORTAL(1);
5738     PL_tmps_stack[++PL_tmps_ix] = sv;
5739     SvTEMP_on(sv);
5740     return sv;
5741 }
5742
5743 /*
5744 =for apidoc newSVpv
5745
5746 Creates a new SV and copies a string into it.  The reference count for the
5747 SV is set to 1.  If C<len> is zero, Perl will compute the length using
5748 strlen().  For efficiency, consider using C<newSVpvn> instead.
5749
5750 =cut
5751 */
5752
5753 SV *
5754 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5755 {
5756     register SV *sv;
5757
5758     new_SV(sv);
5759     if (!len)
5760         len = strlen(s);
5761     sv_setpvn(sv,s,len);
5762     return sv;
5763 }
5764
5765 /*
5766 =for apidoc newSVpvn
5767
5768 Creates a new SV and copies a string into it.  The reference count for the
5769 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
5770 string.  You are responsible for ensuring that the source string is at least
5771 C<len> bytes long.
5772
5773 =cut
5774 */
5775
5776 SV *
5777 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5778 {
5779     register SV *sv;
5780
5781     new_SV(sv);
5782     sv_setpvn(sv,s,len);
5783     return sv;
5784 }
5785
5786 /*
5787 =for apidoc newSVpvn_share
5788
5789 Creates a new SV and populates it with a string from
5790 the string table. Turns on READONLY and FAKE.
5791 The idea here is that as string table is used for shared hash
5792 keys these strings will have SvPVX == HeKEY and hash lookup
5793 will avoid string compare.
5794
5795 =cut
5796 */
5797
5798 SV *
5799 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5800 {
5801     register SV *sv;
5802     bool is_utf8 = FALSE;
5803     if (len < 0) {
5804         len = -len;
5805         is_utf8 = TRUE;
5806     }
5807     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5808         STRLEN tmplen = len;
5809         /* See the note in hv.c:hv_fetch() --jhi */
5810         src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5811         len = tmplen;
5812     }
5813     if (!hash)
5814         PERL_HASH(hash, src, len);
5815     new_SV(sv);
5816     sv_upgrade(sv, SVt_PVIV);
5817     SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5818     SvCUR(sv) = len;
5819     SvUVX(sv) = hash;
5820     SvLEN(sv) = 0;
5821     SvREADONLY_on(sv);
5822     SvFAKE_on(sv);
5823     SvPOK_on(sv);
5824     if (is_utf8)
5825         SvUTF8_on(sv);
5826     return sv;
5827 }
5828
5829 #if defined(PERL_IMPLICIT_CONTEXT)
5830 SV *
5831 Perl_newSVpvf_nocontext(const char* pat, ...)
5832 {
5833     dTHX;
5834     register SV *sv;
5835     va_list args;
5836     va_start(args, pat);
5837     sv = vnewSVpvf(pat, &args);
5838     va_end(args);
5839     return sv;
5840 }
5841 #endif
5842
5843 /*
5844 =for apidoc newSVpvf
5845
5846 Creates a new SV an initialize it with the string formatted like
5847 C<sprintf>.
5848
5849 =cut
5850 */
5851
5852 SV *
5853 Perl_newSVpvf(pTHX_ const char* pat, ...)
5854 {
5855     register SV *sv;
5856     va_list args;
5857     va_start(args, pat);
5858     sv = vnewSVpvf(pat, &args);
5859     va_end(args);
5860     return sv;
5861 }
5862
5863 SV *
5864 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5865 {
5866     register SV *sv;
5867     new_SV(sv);
5868     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5869     return sv;
5870 }
5871
5872 /*
5873 =for apidoc newSVnv
5874
5875 Creates a new SV and copies a floating point value into it.
5876 The reference count for the SV is set to 1.
5877
5878 =cut
5879 */
5880
5881 SV *
5882 Perl_newSVnv(pTHX_ NV n)
5883 {
5884     register SV *sv;
5885
5886     new_SV(sv);
5887     sv_setnv(sv,n);
5888     return sv;
5889 }
5890
5891 /*
5892 =for apidoc newSViv
5893
5894 Creates a new SV and copies an integer into it.  The reference count for the
5895 SV is set to 1.
5896
5897 =cut
5898 */
5899
5900 SV *
5901 Perl_newSViv(pTHX_ IV i)
5902 {
5903     register SV *sv;
5904
5905     new_SV(sv);
5906     sv_setiv(sv,i);
5907     return sv;
5908 }
5909
5910 /*
5911 =for apidoc newSVuv
5912
5913 Creates a new SV and copies an unsigned integer into it.
5914 The reference count for the SV is set to 1.
5915
5916 =cut
5917 */
5918
5919 SV *
5920 Perl_newSVuv(pTHX_ UV u)
5921 {
5922     register SV *sv;
5923
5924     new_SV(sv);
5925     sv_setuv(sv,u);
5926     return sv;
5927 }
5928
5929 /*
5930 =for apidoc newRV_noinc
5931
5932 Creates an RV wrapper for an SV.  The reference count for the original
5933 SV is B<not> incremented.
5934
5935 =cut
5936 */
5937
5938 SV *
5939 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5940 {
5941     register SV *sv;
5942
5943     new_SV(sv);
5944     sv_upgrade(sv, SVt_RV);
5945     SvTEMP_off(tmpRef);
5946     SvRV(sv) = tmpRef;
5947     SvROK_on(sv);
5948     return sv;
5949 }
5950
5951 /* newRV_inc is #defined to newRV in sv.h */
5952 SV *
5953 Perl_newRV(pTHX_ SV *tmpRef)
5954 {
5955     return newRV_noinc(SvREFCNT_inc(tmpRef));
5956 }
5957
5958 /*
5959 =for apidoc newSVsv
5960
5961 Creates a new SV which is an exact duplicate of the original SV.
5962
5963 =cut
5964 */
5965
5966 /* make an exact duplicate of old */
5967
5968 SV *
5969 Perl_newSVsv(pTHX_ register SV *old)
5970 {
5971     register SV *sv;
5972
5973     if (!old)
5974         return Nullsv;
5975     if (SvTYPE(old) == SVTYPEMASK) {
5976         if (ckWARN_d(WARN_INTERNAL))
5977             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5978         return Nullsv;
5979     }
5980     new_SV(sv);
5981     if (SvTEMP(old)) {
5982         SvTEMP_off(old);
5983         sv_setsv(sv,old);
5984         SvTEMP_on(old);
5985     }
5986     else
5987         sv_setsv(sv,old);
5988     return sv;
5989 }
5990
5991 void
5992 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5993 {
5994     register HE *entry;
5995     register GV *gv;
5996     register SV *sv;
5997     register I32 i;
5998     register PMOP *pm;
5999     register I32 max;
6000     char todo[PERL_UCHAR_MAX+1];
6001
6002     if (!stash)
6003         return;
6004
6005     if (!*s) {          /* reset ?? searches */
6006         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6007             pm->op_pmdynflags &= ~PMdf_USED;
6008         }
6009         return;
6010     }
6011
6012     /* reset variables */
6013
6014     if (!HvARRAY(stash))
6015         return;
6016
6017     Zero(todo, 256, char);
6018     while (*s) {
6019         i = (unsigned char)*s;
6020         if (s[1] == '-') {
6021             s += 2;
6022         }
6023         max = (unsigned char)*s++;
6024         for ( ; i <= max; i++) {
6025             todo[i] = 1;
6026         }
6027         for (i = 0; i <= (I32) HvMAX(stash); i++) {
6028             for (entry = HvARRAY(stash)[i];
6029                  entry;
6030                  entry = HeNEXT(entry))
6031             {
6032                 if (!todo[(U8)*HeKEY(entry)])
6033                     continue;
6034                 gv = (GV*)HeVAL(entry);
6035                 sv = GvSV(gv);
6036                 if (SvTHINKFIRST(sv)) {
6037                     if (!SvREADONLY(sv) && SvROK(sv))
6038                         sv_unref(sv);
6039                     continue;
6040                 }
6041                 (void)SvOK_off(sv);
6042                 if (SvTYPE(sv) >= SVt_PV) {
6043                     SvCUR_set(sv, 0);
6044                     if (SvPVX(sv) != Nullch)
6045                         *SvPVX(sv) = '\0';
6046                     SvTAINT(sv);
6047                 }
6048                 if (GvAV(gv)) {
6049                     av_clear(GvAV(gv));
6050                 }
6051                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6052                     hv_clear(GvHV(gv));
6053 #ifdef USE_ENVIRON_ARRAY
6054                     if (gv == PL_envgv)
6055                         environ[0] = Nullch;
6056 #endif
6057                 }
6058             }
6059         }
6060     }
6061 }
6062
6063 IO*
6064 Perl_sv_2io(pTHX_ SV *sv)
6065 {
6066     IO* io;
6067     GV* gv;
6068     STRLEN n_a;
6069
6070     switch (SvTYPE(sv)) {
6071     case SVt_PVIO:
6072         io = (IO*)sv;
6073         break;
6074     case SVt_PVGV:
6075         gv = (GV*)sv;
6076         io = GvIO(gv);
6077         if (!io)
6078             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6079         break;
6080     default:
6081         if (!SvOK(sv))
6082             Perl_croak(aTHX_ PL_no_usym, "filehandle");
6083         if (SvROK(sv))
6084             return sv_2io(SvRV(sv));
6085         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6086         if (gv)
6087             io = GvIO(gv);
6088         else
6089             io = 0;
6090         if (!io)
6091             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6092         break;
6093     }
6094     return io;
6095 }
6096
6097 CV *
6098 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6099 {
6100     GV *gv;
6101     CV *cv;
6102     STRLEN n_a;
6103
6104     if (!sv)
6105         return *gvp = Nullgv, Nullcv;
6106     switch (SvTYPE(sv)) {
6107     case SVt_PVCV:
6108         *st = CvSTASH(sv);
6109         *gvp = Nullgv;
6110         return (CV*)sv;
6111     case SVt_PVHV:
6112     case SVt_PVAV:
6113         *gvp = Nullgv;
6114         return Nullcv;
6115     case SVt_PVGV:
6116         gv = (GV*)sv;
6117         *gvp = gv;
6118         *st = GvESTASH(gv);
6119         goto fix_gv;
6120
6121     default:
6122         if (SvGMAGICAL(sv))
6123             mg_get(sv);
6124         if (SvROK(sv)) {
6125             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
6126             tryAMAGICunDEREF(to_cv);
6127
6128             sv = SvRV(sv);
6129             if (SvTYPE(sv) == SVt_PVCV) {
6130                 cv = (CV*)sv;
6131                 *gvp = Nullgv;
6132                 *st = CvSTASH(cv);
6133                 return cv;
6134             }
6135             else if(isGV(sv))
6136                 gv = (GV*)sv;
6137             else
6138                 Perl_croak(aTHX_ "Not a subroutine reference");
6139         }
6140         else if (isGV(sv))
6141             gv = (GV*)sv;
6142         else
6143             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6144         *gvp = gv;
6145         if (!gv)
6146             return Nullcv;
6147         *st = GvESTASH(gv);
6148     fix_gv:
6149         if (lref && !GvCVu(gv)) {
6150             SV *tmpsv;
6151             ENTER;
6152             tmpsv = NEWSV(704,0);
6153             gv_efullname3(tmpsv, gv, Nullch);
6154             /* XXX this is probably not what they think they're getting.
6155              * It has the same effect as "sub name;", i.e. just a forward
6156              * declaration! */
6157             newSUB(start_subparse(FALSE, 0),
6158                    newSVOP(OP_CONST, 0, tmpsv),
6159                    Nullop,
6160                    Nullop);
6161             LEAVE;
6162             if (!GvCVu(gv))
6163                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6164         }
6165         return GvCVu(gv);
6166     }
6167 }
6168
6169 /*
6170 =for apidoc sv_true
6171
6172 Returns true if the SV has a true value by Perl's rules.
6173
6174 =cut
6175 */
6176
6177 I32
6178 Perl_sv_true(pTHX_ register SV *sv)
6179 {
6180     if (!sv)
6181         return 0;
6182     if (SvPOK(sv)) {
6183         register XPV* tXpv;
6184         if ((tXpv = (XPV*)SvANY(sv)) &&
6185                 (tXpv->xpv_cur > 1 ||
6186                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6187             return 1;
6188         else
6189             return 0;
6190     }
6191     else {
6192         if (SvIOK(sv))
6193             return SvIVX(sv) != 0;
6194         else {
6195             if (SvNOK(sv))
6196                 return SvNVX(sv) != 0.0;
6197             else
6198                 return sv_2bool(sv);
6199         }
6200     }
6201 }
6202
6203 IV
6204 Perl_sv_iv(pTHX_ register SV *sv)
6205 {
6206     if (SvIOK(sv)) {
6207         if (SvIsUV(sv))
6208             return (IV)SvUVX(sv);
6209         return SvIVX(sv);
6210     }
6211     return sv_2iv(sv);
6212 }
6213
6214 UV
6215 Perl_sv_uv(pTHX_ register SV *sv)
6216 {
6217     if (SvIOK(sv)) {
6218         if (SvIsUV(sv))
6219             return SvUVX(sv);
6220         return (UV)SvIVX(sv);
6221     }
6222     return sv_2uv(sv);
6223 }
6224
6225 NV
6226 Perl_sv_nv(pTHX_ register SV *sv)
6227 {
6228     if (SvNOK(sv))
6229         return SvNVX(sv);
6230     return sv_2nv(sv);
6231 }
6232
6233 char *
6234 Perl_sv_pv(pTHX_ SV *sv)
6235 {
6236     STRLEN n_a;
6237
6238     if (SvPOK(sv))
6239         return SvPVX(sv);
6240
6241     return sv_2pv(sv, &n_a);
6242 }
6243
6244 char *
6245 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6246 {
6247     if (SvPOK(sv)) {
6248         *lp = SvCUR(sv);
6249         return SvPVX(sv);
6250     }
6251     return sv_2pv(sv, lp);
6252 }
6253
6254 /*
6255 =for apidoc sv_pvn_force
6256
6257 Get a sensible string out of the SV somehow.
6258
6259 =cut
6260 */
6261
6262 char *
6263 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6264 {
6265     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6266 }
6267
6268 /*
6269 =for apidoc sv_pvn_force_flags
6270
6271 Get a sensible string out of the SV somehow.
6272 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6273 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6274 implemented in terms of this function.
6275
6276 =cut
6277 */
6278
6279 char *
6280 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6281 {
6282     char *s;
6283
6284     if (SvTHINKFIRST(sv) && !SvROK(sv))
6285         sv_force_normal(sv);
6286
6287     if (SvPOK(sv)) {
6288         *lp = SvCUR(sv);
6289     }
6290     else {
6291         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6292             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6293                 PL_op_name[PL_op->op_type]);
6294         }
6295         else
6296             s = sv_2pv_flags(sv, lp, flags);
6297         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
6298             STRLEN len = *lp;
6299
6300             if (SvROK(sv))
6301                 sv_unref(sv);
6302             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
6303             SvGROW(sv, len + 1);
6304             Move(s,SvPVX(sv),len,char);
6305             SvCUR_set(sv, len);
6306             *SvEND(sv) = '\0';
6307         }
6308         if (!SvPOK(sv)) {
6309             SvPOK_on(sv);               /* validate pointer */
6310             SvTAINT(sv);
6311             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6312                                   PTR2UV(sv),SvPVX(sv)));
6313         }
6314     }
6315     return SvPVX(sv);
6316 }
6317
6318 char *
6319 Perl_sv_pvbyte(pTHX_ SV *sv)
6320 {
6321     sv_utf8_downgrade(sv,0);
6322     return sv_pv(sv);
6323 }
6324
6325 char *
6326 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6327 {
6328     sv_utf8_downgrade(sv,0);
6329     return sv_pvn(sv,lp);
6330 }
6331
6332 char *
6333 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6334 {
6335     sv_utf8_downgrade(sv,0);
6336     return sv_pvn_force(sv,lp);
6337 }
6338
6339 char *
6340 Perl_sv_pvutf8(pTHX_ SV *sv)
6341 {
6342     sv_utf8_upgrade(sv);
6343     return sv_pv(sv);
6344 }
6345
6346 char *
6347 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6348 {
6349     sv_utf8_upgrade(sv);
6350     return sv_pvn(sv,lp);
6351 }
6352
6353 /*
6354 =for apidoc sv_pvutf8n_force
6355
6356 Get a sensible UTF8-encoded string out of the SV somehow. See
6357 L</sv_pvn_force>.
6358
6359 =cut
6360 */
6361
6362 char *
6363 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6364 {
6365     sv_utf8_upgrade(sv);
6366     return sv_pvn_force(sv,lp);
6367 }
6368
6369 /*
6370 =for apidoc sv_reftype
6371
6372 Returns a string describing what the SV is a reference to.
6373
6374 =cut
6375 */
6376
6377 char *
6378 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6379 {
6380     if (ob && SvOBJECT(sv))
6381         return HvNAME(SvSTASH(sv));
6382     else {
6383         switch (SvTYPE(sv)) {
6384         case SVt_NULL:
6385         case SVt_IV:
6386         case SVt_NV:
6387         case SVt_RV:
6388         case SVt_PV:
6389         case SVt_PVIV:
6390         case SVt_PVNV:
6391         case SVt_PVMG:
6392         case SVt_PVBM:
6393                                 if (SvROK(sv))
6394                                     return "REF";
6395                                 else
6396                                     return "SCALAR";
6397         case SVt_PVLV:          return "LVALUE";
6398         case SVt_PVAV:          return "ARRAY";
6399         case SVt_PVHV:          return "HASH";
6400         case SVt_PVCV:          return "CODE";
6401         case SVt_PVGV:          return "GLOB";
6402         case SVt_PVFM:          return "FORMAT";
6403         case SVt_PVIO:          return "IO";
6404         default:                return "UNKNOWN";
6405         }
6406     }
6407 }
6408
6409 /*
6410 =for apidoc sv_isobject
6411
6412 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6413 object.  If the SV is not an RV, or if the object is not blessed, then this
6414 will return false.
6415
6416 =cut
6417 */
6418
6419 int
6420 Perl_sv_isobject(pTHX_ SV *sv)
6421 {
6422     if (!sv)
6423         return 0;
6424     if (SvGMAGICAL(sv))
6425         mg_get(sv);
6426     if (!SvROK(sv))
6427         return 0;
6428     sv = (SV*)SvRV(sv);
6429     if (!SvOBJECT(sv))
6430         return 0;
6431     return 1;
6432 }
6433
6434 /*
6435 =for apidoc sv_isa
6436
6437 Returns a boolean indicating whether the SV is blessed into the specified
6438 class.  This does not check for subtypes; use C<sv_derived_from> to verify
6439 an inheritance relationship.
6440
6441 =cut
6442 */
6443
6444 int
6445 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6446 {
6447     if (!sv)
6448         return 0;
6449     if (SvGMAGICAL(sv))
6450         mg_get(sv);
6451     if (!SvROK(sv))
6452         return 0;
6453     sv = (SV*)SvRV(sv);
6454     if (!SvOBJECT(sv))
6455         return 0;
6456
6457     return strEQ(HvNAME(SvSTASH(sv)), name);
6458 }
6459
6460 /*
6461 =for apidoc newSVrv
6462
6463 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
6464 it will be upgraded to one.  If C<classname> is non-null then the new SV will
6465 be blessed in the specified package.  The new SV is returned and its
6466 reference count is 1.
6467
6468 =cut
6469 */
6470
6471 SV*
6472 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6473 {
6474     SV *sv;
6475
6476     new_SV(sv);
6477
6478     SV_CHECK_THINKFIRST(rv);
6479     SvAMAGIC_off(rv);
6480
6481     if (SvTYPE(rv) >= SVt_PVMG) {
6482         U32 refcnt = SvREFCNT(rv);
6483         SvREFCNT(rv) = 0;
6484         sv_clear(rv);
6485         SvFLAGS(rv) = 0;
6486         SvREFCNT(rv) = refcnt;
6487     }
6488
6489     if (SvTYPE(rv) < SVt_RV)
6490         sv_upgrade(rv, SVt_RV);
6491     else if (SvTYPE(rv) > SVt_RV) {
6492         (void)SvOOK_off(rv);
6493         if (SvPVX(rv) && SvLEN(rv))
6494             Safefree(SvPVX(rv));
6495         SvCUR_set(rv, 0);
6496         SvLEN_set(rv, 0);
6497     }
6498
6499     (void)SvOK_off(rv);
6500     SvRV(rv) = sv;
6501     SvROK_on(rv);
6502
6503     if (classname) {
6504         HV* stash = gv_stashpv(classname, TRUE);
6505         (void)sv_bless(rv, stash);
6506     }
6507     return sv;
6508 }
6509
6510 /*
6511 =for apidoc sv_setref_pv
6512
6513 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
6514 argument will be upgraded to an RV.  That RV will be modified to point to
6515 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6516 into the SV.  The C<classname> argument indicates the package for the
6517 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6518 will be returned and will have a reference count of 1.
6519
6520 Do not use with other Perl types such as HV, AV, SV, CV, because those
6521 objects will become corrupted by the pointer copy process.
6522
6523 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6524
6525 =cut
6526 */
6527
6528 SV*
6529 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6530 {
6531     if (!pv) {
6532         sv_setsv(rv, &PL_sv_undef);
6533         SvSETMAGIC(rv);
6534     }
6535     else
6536         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6537     return rv;
6538 }
6539
6540 /*
6541 =for apidoc sv_setref_iv
6542
6543 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
6544 argument will be upgraded to an RV.  That RV will be modified to point to
6545 the new SV.  The C<classname> argument indicates the package for the
6546 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6547 will be returned and will have a reference count of 1.
6548
6549 =cut
6550 */
6551
6552 SV*
6553 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6554 {
6555     sv_setiv(newSVrv(rv,classname), iv);
6556     return rv;
6557 }
6558
6559 /*
6560 =for apidoc sv_setref_uv
6561
6562 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
6563 argument will be upgraded to an RV.  That RV will be modified to point to
6564 the new SV.  The C<classname> argument indicates the package for the
6565 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6566 will be returned and will have a reference count of 1.
6567
6568 =cut
6569 */
6570
6571 SV*
6572 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6573 {
6574     sv_setuv(newSVrv(rv,classname), uv);
6575     return rv;
6576 }
6577
6578 /*
6579 =for apidoc sv_setref_nv
6580
6581 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
6582 argument will be upgraded to an RV.  That RV will be modified to point to
6583 the new SV.  The C<classname> argument indicates the package for the
6584 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6585 will be returned and will have a reference count of 1.
6586
6587 =cut
6588 */
6589
6590 SV*
6591 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6592 {
6593     sv_setnv(newSVrv(rv,classname), nv);
6594     return rv;
6595 }
6596
6597 /*
6598 =for apidoc sv_setref_pvn
6599
6600 Copies a string into a new SV, optionally blessing the SV.  The length of the
6601 string must be specified with C<n>.  The C<rv> argument will be upgraded to
6602 an RV.  That RV will be modified to point to the new SV.  The C<classname>
6603 argument indicates the package for the blessing.  Set C<classname> to
6604 C<Nullch> to avoid the blessing.  The new SV will be returned and will have
6605 a reference count of 1.
6606
6607 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6608
6609 =cut
6610 */
6611
6612 SV*
6613 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6614 {
6615     sv_setpvn(newSVrv(rv,classname), pv, n);
6616     return rv;
6617 }
6618
6619 /*
6620 =for apidoc sv_bless
6621
6622 Blesses an SV into a specified package.  The SV must be an RV.  The package
6623 must be designated by its stash (see C<gv_stashpv()>).  The reference count
6624 of the SV is unaffected.
6625
6626 =cut
6627 */
6628
6629 SV*
6630 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6631 {
6632     SV *tmpRef;
6633     if (!SvROK(sv))
6634         Perl_croak(aTHX_ "Can't bless non-reference value");
6635     tmpRef = SvRV(sv);
6636     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6637         if (SvREADONLY(tmpRef))
6638             Perl_croak(aTHX_ PL_no_modify);
6639         if (SvOBJECT(tmpRef)) {
6640             if (SvTYPE(tmpRef) != SVt_PVIO)
6641                 --PL_sv_objcount;
6642             SvREFCNT_dec(SvSTASH(tmpRef));
6643         }
6644     }
6645     SvOBJECT_on(tmpRef);
6646     if (SvTYPE(tmpRef) != SVt_PVIO)
6647         ++PL_sv_objcount;
6648     (void)SvUPGRADE(tmpRef, SVt_PVMG);
6649     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6650
6651     if (Gv_AMG(stash))
6652         SvAMAGIC_on(sv);
6653     else
6654         SvAMAGIC_off(sv);
6655
6656     return sv;
6657 }
6658
6659 STATIC void
6660 S_sv_unglob(pTHX_ SV *sv)
6661 {
6662     void *xpvmg;
6663
6664     assert(SvTYPE(sv) == SVt_PVGV);
6665     SvFAKE_off(sv);
6666     if (GvGP(sv))
6667         gp_free((GV*)sv);
6668     if (GvSTASH(sv)) {
6669         SvREFCNT_dec(GvSTASH(sv));
6670         GvSTASH(sv) = Nullhv;
6671     }
6672     sv_unmagic(sv, PERL_MAGIC_glob);
6673     Safefree(GvNAME(sv));
6674     GvMULTI_off(sv);
6675
6676     /* need to keep SvANY(sv) in the right arena */
6677     xpvmg = new_XPVMG();
6678     StructCopy(SvANY(sv), xpvmg, XPVMG);
6679     del_XPVGV(SvANY(sv));
6680     SvANY(sv) = xpvmg;
6681
6682     SvFLAGS(sv) &= ~SVTYPEMASK;
6683     SvFLAGS(sv) |= SVt_PVMG;
6684 }
6685
6686 /*
6687 =for apidoc sv_unref_flags
6688
6689 Unsets the RV status of the SV, and decrements the reference count of
6690 whatever was being referenced by the RV.  This can almost be thought of
6691 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
6692 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6693 (otherwise the decrementing is conditional on the reference count being
6694 different from one or the reference being a readonly SV).
6695 See C<SvROK_off>.
6696
6697 =cut
6698 */
6699
6700 void
6701 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6702 {
6703     SV* rv = SvRV(sv);
6704
6705     if (SvWEAKREF(sv)) {
6706         sv_del_backref(sv);
6707         SvWEAKREF_off(sv);
6708         SvRV(sv) = 0;
6709         return;
6710     }
6711     SvRV(sv) = 0;
6712     SvROK_off(sv);
6713     if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6714         SvREFCNT_dec(rv);
6715     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6716         sv_2mortal(rv);         /* Schedule for freeing later */
6717 }
6718
6719 /*
6720 =for apidoc sv_unref
6721
6722 Unsets the RV status of the SV, and decrements the reference count of
6723 whatever was being referenced by the RV.  This can almost be thought of
6724 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
6725 being zero.  See C<SvROK_off>.
6726
6727 =cut
6728 */
6729
6730 void
6731 Perl_sv_unref(pTHX_ SV *sv)
6732 {
6733     sv_unref_flags(sv, 0);
6734 }
6735
6736 void
6737 Perl_sv_taint(pTHX_ SV *sv)
6738 {
6739     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
6740 }
6741
6742 void
6743 Perl_sv_untaint(pTHX_ SV *sv)
6744 {
6745     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6746         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6747         if (mg)
6748             mg->mg_len &= ~1;
6749     }
6750 }
6751
6752 bool
6753 Perl_sv_tainted(pTHX_ SV *sv)
6754 {
6755     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6756         MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6757         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6758             return TRUE;
6759     }
6760     return FALSE;
6761 }
6762
6763 /*
6764 =for apidoc sv_setpviv
6765
6766 Copies an integer into the given SV, also updating its string value.
6767 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
6768
6769 =cut
6770 */
6771
6772 void
6773 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6774 {
6775     char buf[TYPE_CHARS(UV)];
6776     char *ebuf;
6777     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6778
6779     sv_setpvn(sv, ptr, ebuf - ptr);
6780 }
6781
6782
6783 /*
6784 =for apidoc sv_setpviv_mg
6785
6786 Like C<sv_setpviv>, but also handles 'set' magic.
6787
6788 =cut
6789 */
6790
6791 void
6792 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6793 {
6794     char buf[TYPE_CHARS(UV)];
6795     char *ebuf;
6796     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6797
6798     sv_setpvn(sv, ptr, ebuf - ptr);
6799     SvSETMAGIC(sv);
6800 }
6801
6802 #if defined(PERL_IMPLICIT_CONTEXT)
6803 void
6804 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6805 {
6806     dTHX;
6807     va_list args;
6808     va_start(args, pat);
6809     sv_vsetpvf(sv, pat, &args);
6810     va_end(args);
6811 }
6812
6813
6814 void
6815 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6816 {
6817     dTHX;
6818     va_list args;
6819     va_start(args, pat);
6820     sv_vsetpvf_mg(sv, pat, &args);
6821     va_end(args);
6822 }
6823 #endif
6824
6825 /*
6826 =for apidoc sv_setpvf
6827
6828 Processes its arguments like C<sprintf> and sets an SV to the formatted
6829 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
6830
6831 =cut
6832 */
6833
6834 void
6835 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6836 {
6837     va_list args;
6838     va_start(args, pat);
6839     sv_vsetpvf(sv, pat, &args);
6840     va_end(args);
6841 }
6842
6843 void
6844 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6845 {
6846     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6847 }
6848
6849 /*
6850 =for apidoc sv_setpvf_mg
6851
6852 Like C<sv_setpvf>, but also handles 'set' magic.
6853
6854 =cut
6855 */
6856
6857 void
6858 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6859 {
6860     va_list args;
6861     va_start(args, pat);
6862     sv_vsetpvf_mg(sv, pat, &args);
6863     va_end(args);
6864 }
6865
6866 void
6867 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6868 {
6869     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6870     SvSETMAGIC(sv);
6871 }
6872
6873 #if defined(PERL_IMPLICIT_CONTEXT)
6874 void
6875 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6876 {
6877     dTHX;
6878     va_list args;
6879     va_start(args, pat);
6880     sv_vcatpvf(sv, pat, &args);
6881     va_end(args);
6882 }
6883
6884 void
6885 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6886 {
6887     dTHX;
6888     va_list args;
6889     va_start(args, pat);
6890     sv_vcatpvf_mg(sv, pat, &args);
6891     va_end(args);
6892 }
6893 #endif
6894
6895 /*
6896 =for apidoc sv_catpvf
6897
6898 Processes its arguments like C<sprintf> and appends the formatted
6899 output to an SV.  If the appended data contains "wide" characters
6900 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6901 and characters >255 formatted with %c), the original SV might get
6902 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.
6903 C<SvSETMAGIC()> must typically be called after calling this function
6904 to handle 'set' magic.
6905
6906 =cut */
6907
6908 void
6909 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6910 {
6911     va_list args;
6912     va_start(args, pat);
6913     sv_vcatpvf(sv, pat, &args);
6914     va_end(args);
6915 }
6916
6917 void
6918 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6919 {
6920     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6921 }
6922
6923 /*
6924 =for apidoc sv_catpvf_mg
6925
6926 Like C<sv_catpvf>, but also handles 'set' magic.
6927
6928 =cut
6929 */
6930
6931 void
6932 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6933 {
6934     va_list args;
6935     va_start(args, pat);
6936     sv_vcatpvf_mg(sv, pat, &args);
6937     va_end(args);
6938 }
6939
6940 void
6941 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6942 {
6943     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6944     SvSETMAGIC(sv);
6945 }
6946
6947 /*
6948 =for apidoc sv_vsetpvfn
6949
6950 Works like C<vcatpvfn> but copies the text into the SV instead of
6951 appending it.
6952
6953 =cut
6954 */
6955
6956 void
6957 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6958 {
6959     sv_setpvn(sv, "", 0);
6960     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6961 }
6962
6963 STATIC I32
6964 S_expect_number(pTHX_ char** pattern)
6965 {
6966     I32 var = 0;
6967     switch (**pattern) {
6968     case '1': case '2': case '3':
6969     case '4': case '5': case '6':
6970     case '7': case '8': case '9':
6971         while (isDIGIT(**pattern))
6972             var = var * 10 + (*(*pattern)++ - '0');
6973     }
6974     return var;
6975 }
6976 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6977
6978 /*
6979 =for apidoc sv_vcatpvfn
6980
6981 Processes its arguments like C<vsprintf> and appends the formatted output
6982 to an SV.  Uses an array of SVs if the C style variable argument list is
6983 missing (NULL).  When running with taint checks enabled, indicates via
6984 C<maybe_tainted> if results are untrustworthy (often due to the use of
6985 locales).
6986
6987 =cut
6988 */
6989
6990 void
6991 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6992 {
6993     char *p;
6994     char *q;
6995     char *patend;
6996     STRLEN origlen;
6997     I32 svix = 0;
6998     static char nullstr[] = "(null)";
6999     SV *argsv = Nullsv;
7000
7001     /* no matter what, this is a string now */
7002     (void)SvPV_force(sv, origlen);
7003
7004     /* special-case "", "%s", and "%_" */
7005     if (patlen == 0)
7006         return;
7007     if (patlen == 2 && pat[0] == '%') {
7008         switch (pat[1]) {
7009         case 's':
7010             if (args) {
7011                 char *s = va_arg(*args, char*);
7012                 sv_catpv(sv, s ? s : nullstr);
7013             }
7014             else if (svix < svmax) {
7015                 sv_catsv(sv, *svargs);
7016                 if (DO_UTF8(*svargs))
7017                     SvUTF8_on(sv);
7018             }
7019             return;
7020         case '_':
7021             if (args) {
7022                 argsv = va_arg(*args, SV*);
7023                 sv_catsv(sv, argsv);
7024                 if (DO_UTF8(argsv))
7025                     SvUTF8_on(sv);
7026                 return;
7027             }
7028             /* See comment on '_' below */
7029             break;
7030         }
7031     }
7032
7033     patend = (char*)pat + patlen;
7034     for (p = (char*)pat; p < patend; p = q) {
7035         bool alt = FALSE;
7036         bool left = FALSE;
7037         bool vectorize = FALSE;
7038         bool vectorarg = FALSE;
7039         bool vec_utf = FALSE;
7040         char fill = ' ';
7041         char plus = 0;
7042         char intsize = 0;
7043         STRLEN width = 0;
7044         STRLEN zeros = 0;
7045         bool has_precis = FALSE;
7046         STRLEN precis = 0;
7047         bool is_utf = FALSE;
7048
7049         char esignbuf[4];
7050         U8 utf8buf[UTF8_MAXLEN+1];
7051         STRLEN esignlen = 0;
7052
7053         char *eptr = Nullch;
7054         STRLEN elen = 0;
7055         /* Times 4: a decimal digit takes more than 3 binary digits.
7056          * NV_DIG: mantissa takes than many decimal digits.
7057          * Plus 32: Playing safe. */
7058         char ebuf[IV_DIG * 4 + NV_DIG + 32];
7059         /* large enough for "%#.#f" --chip */
7060         /* what about long double NVs? --jhi */
7061
7062         SV *vecsv;
7063         U8 *vecstr = Null(U8*);
7064         STRLEN veclen = 0;
7065         char c;
7066         int i;
7067         unsigned base = 0;
7068         IV iv;
7069         UV uv;
7070         NV nv;
7071         STRLEN have;
7072         STRLEN need;
7073         STRLEN gap;
7074         char *dotstr = ".";
7075         STRLEN dotstrlen = 1;
7076         I32 efix = 0; /* explicit format parameter index */
7077         I32 ewix = 0; /* explicit width index */
7078         I32 epix = 0; /* explicit precision index */
7079         I32 evix = 0; /* explicit vector index */
7080         bool asterisk = FALSE;
7081
7082         /* echo everything up to the next format specification */
7083         for (q = p; q < patend && *q != '%'; ++q) ;
7084         if (q > p) {
7085             sv_catpvn(sv, p, q - p);
7086             p = q;
7087         }
7088         if (q++ >= patend)
7089             break;
7090
7091 /*
7092     We allow format specification elements in this order:
7093         \d+\$              explicit format parameter index
7094         [-+ 0#]+           flags
7095         \*?(\d+\$)?v       vector with optional (optionally specified) arg
7096         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
7097         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7098         [hlqLV]            size
7099     [%bcdefginopsux_DFOUX] format (mandatory)
7100 */
7101         if (EXPECT_NUMBER(q, width)) {
7102             if (*q == '$') {
7103                 ++q;
7104                 efix = width;
7105             } else {
7106                 goto gotwidth;
7107             }
7108         }
7109
7110         /* FLAGS */
7111
7112         while (*q) {
7113             switch (*q) {
7114             case ' ':
7115             case '+':
7116                 plus = *q++;
7117                 continue;
7118
7119             case '-':
7120                 left = TRUE;
7121                 q++;
7122                 continue;
7123
7124             case '0':
7125                 fill = *q++;
7126                 continue;
7127
7128             case '#':
7129                 alt = TRUE;
7130                 q++;
7131                 continue;
7132
7133             default:
7134                 break;
7135             }
7136             break;
7137         }
7138
7139       tryasterisk:
7140         if (*q == '*') {
7141             q++;
7142             if (EXPECT_NUMBER(q, ewix))
7143                 if (*q++ != '$')
7144                     goto unknown;
7145             asterisk = TRUE;
7146         }
7147         if (*q == 'v') {
7148             q++;
7149             if (vectorize)
7150                 goto unknown;
7151             if ((vectorarg = asterisk)) {
7152                 evix = ewix;
7153                 ewix = 0;
7154                 asterisk = FALSE;
7155             }
7156             vectorize = TRUE;
7157             goto tryasterisk;
7158         }
7159
7160         if (!asterisk)
7161             EXPECT_NUMBER(q, width);
7162
7163         if (vectorize) {
7164             if (vectorarg) {
7165                 if (args)
7166                     vecsv = va_arg(*args, SV*);
7167                 else
7168                     vecsv = (evix ? evix <= svmax : svix < svmax) ?
7169                         svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7170                 dotstr = SvPVx(vecsv, dotstrlen);
7171                 if (DO_UTF8(vecsv))
7172                     is_utf = TRUE;
7173             }
7174             if (args) {
7175                 vecsv = va_arg(*args, SV*);
7176                 vecstr = (U8*)SvPVx(vecsv,veclen);
7177                 vec_utf = DO_UTF8(vecsv);
7178             }
7179             else if (efix ? efix <= svmax : svix < svmax) {
7180                 vecsv = svargs[efix ? efix-1 : svix++];
7181                 vecstr = (U8*)SvPVx(vecsv,veclen);
7182                 vec_utf = DO_UTF8(vecsv);
7183             }
7184             else {
7185                 vecstr = (U8*)"";
7186                 veclen = 0;
7187             }
7188         }
7189
7190         if (asterisk) {
7191             if (args)
7192                 i = va_arg(*args, int);
7193             else
7194                 i = (ewix ? ewix <= svmax : svix < svmax) ?
7195                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7196             left |= (i < 0);
7197             width = (i < 0) ? -i : i;
7198         }
7199       gotwidth:
7200
7201         /* PRECISION */
7202
7203         if (*q == '.') {
7204             q++;
7205             if (*q == '*') {
7206                 q++;
7207                 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7208                     goto unknown;
7209                 if (args)
7210                     i = va_arg(*args, int);
7211                 else
7212                     i = (ewix ? ewix <= svmax : svix < svmax)
7213                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7214                 precis = (i < 0) ? 0 : i;
7215             }
7216             else {
7217                 precis = 0;
7218                 while (isDIGIT(*q))
7219                     precis = precis * 10 + (*q++ - '0');
7220             }
7221             has_precis = TRUE;
7222         }
7223
7224         /* SIZE */
7225
7226         switch (*q) {
7227 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7228         case 'L':                       /* Ld */
7229             /* FALL THROUGH */
7230 #endif
7231 #ifdef HAS_QUAD
7232         case 'q':                       /* qd */
7233             intsize = 'q';
7234             q++;
7235             break;
7236 #endif
7237         case 'l':
7238 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7239              if (*(q + 1) == 'l') {     /* lld, llf */
7240                 intsize = 'q';
7241                 q += 2;
7242                 break;
7243              }
7244 #endif
7245             /* FALL THROUGH */
7246         case 'h':
7247             /* FALL THROUGH */
7248         case 'V':
7249             intsize = *q++;
7250             break;
7251         }
7252
7253         /* CONVERSION */
7254
7255         if (*q == '%') {
7256             eptr = q++;
7257             elen = 1;
7258             goto string;
7259         }
7260
7261         if (!args)
7262             argsv = (efix ? efix <= svmax : svix < svmax) ?
7263                     svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7264
7265         switch (c = *q++) {
7266
7267             /* STRINGS */
7268
7269         case 'c':
7270             uv = args ? va_arg(*args, int) : SvIVx(argsv);
7271             if ((uv > 255 ||
7272                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7273                 && !IN_BYTES) {
7274                 eptr = (char*)utf8buf;
7275                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7276                 is_utf = TRUE;
7277             }
7278             else {
7279                 c = (char)uv;
7280                 eptr = &c;
7281                 elen = 1;
7282             }
7283             goto string;
7284
7285         case 's':
7286             if (args) {
7287                 eptr = va_arg(*args, char*);
7288                 if (eptr)
7289 #ifdef MACOS_TRADITIONAL
7290                   /* On MacOS, %#s format is used for Pascal strings */
7291                   if (alt)
7292                     elen = *eptr++;
7293                   else
7294 #endif
7295                     elen = strlen(eptr);
7296                 else {
7297                     eptr = nullstr;
7298                     elen = sizeof nullstr - 1;
7299                 }
7300             }
7301             else {
7302                 eptr = SvPVx(argsv, elen);
7303                 if (DO_UTF8(argsv)) {
7304                     if (has_precis && precis < elen) {
7305                         I32 p = precis;
7306                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7307                         precis = p;
7308                     }
7309                     if (width) { /* fudge width (can't fudge elen) */
7310                         width += elen - sv_len_utf8(argsv);
7311                     }
7312                     is_utf = TRUE;
7313                 }
7314             }
7315             goto string;
7316
7317         case '_':
7318             /*
7319              * The "%_" hack might have to be changed someday,
7320              * if ISO or ANSI decide to use '_' for something.
7321              * So we keep it hidden from users' code.
7322              */
7323             if (!args)
7324                 goto unknown;
7325             argsv = va_arg(*args, SV*);
7326             eptr = SvPVx(argsv, elen);
7327             if (DO_UTF8(argsv))
7328                 is_utf = TRUE;
7329
7330         string:
7331             vectorize = FALSE;
7332             if (has_precis && elen > precis)
7333                 elen = precis;
7334             break;
7335
7336             /* INTEGERS */
7337
7338         case 'p':
7339             if (alt)
7340                 goto unknown;
7341             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7342             base = 16;
7343             goto integer;
7344
7345         case 'D':
7346 #ifdef IV_IS_QUAD
7347             intsize = 'q';
7348 #else
7349             intsize = 'l';
7350 #endif
7351             /* FALL THROUGH */
7352         case 'd':
7353         case 'i':
7354             if (vectorize) {
7355                 STRLEN ulen;
7356                 if (!veclen)
7357                     continue;
7358                 if (vec_utf)
7359                     iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7360                 else {
7361                     iv = *vecstr;
7362                     ulen = 1;
7363                 }
7364                 vecstr += ulen;
7365                 veclen -= ulen;
7366             }
7367             else if (args) {
7368                 switch (intsize) {
7369                 case 'h':       iv = (short)va_arg(*args, int); break;
7370                 default:        iv = va_arg(*args, int); break;
7371                 case 'l':       iv = va_arg(*args, long); break;
7372                 case 'V':       iv = va_arg(*args, IV); break;
7373 #ifdef HAS_QUAD
7374                 case 'q':       iv = va_arg(*args, Quad_t); break;
7375 #endif
7376                 }
7377             }
7378             else {
7379                 iv = SvIVx(argsv);
7380                 switch (intsize) {
7381                 case 'h':       iv = (short)iv; break;
7382                 default:        break;
7383                 case 'l':       iv = (long)iv; break;
7384                 case 'V':       break;
7385 #ifdef HAS_QUAD
7386                 case 'q':       iv = (Quad_t)iv; break;
7387 #endif
7388                 }
7389             }
7390             if (iv >= 0) {
7391                 uv = iv;
7392                 if (plus)
7393                     esignbuf[esignlen++] = plus;
7394             }
7395             else {
7396                 uv = -iv;
7397                 esignbuf[esignlen++] = '-';
7398             }
7399             base = 10;
7400             goto integer;
7401
7402         case 'U':
7403 #ifdef IV_IS_QUAD
7404             intsize = 'q';
7405 #else
7406             intsize = 'l';
7407 #endif
7408             /* FALL THROUGH */
7409         case 'u':
7410             base = 10;
7411             goto uns_integer;
7412
7413         case 'b':
7414             base = 2;
7415             goto uns_integer;
7416
7417         case 'O':
7418 #ifdef IV_IS_QUAD
7419             intsize = 'q';
7420 #else
7421             intsize = 'l';
7422 #endif
7423             /* FALL THROUGH */
7424         case 'o':
7425             base = 8;
7426             goto uns_integer;
7427
7428         case 'X':
7429         case 'x':
7430             base = 16;
7431
7432         uns_integer:
7433             if (vectorize) {
7434                 STRLEN ulen;
7435         vector:
7436                 if (!veclen)
7437                     continue;
7438                 if (vec_utf)
7439                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7440                 else {
7441                     uv = *vecstr;
7442                     ulen = 1;
7443                 }
7444                 vecstr += ulen;
7445                 veclen -= ulen;
7446             }
7447             else if (args) {
7448                 switch (intsize) {
7449                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
7450                 default:   uv = va_arg(*args, unsigned); break;
7451                 case 'l':  uv = va_arg(*args, unsigned long); break;
7452                 case 'V':  uv = va_arg(*args, UV); break;
7453 #ifdef HAS_QUAD
7454                 case 'q':  uv = va_arg(*args, Quad_t); break;
7455 #endif
7456                 }
7457             }
7458             else {
7459                 uv = SvUVx(argsv);
7460                 switch (intsize) {
7461                 case 'h':       uv = (unsigned short)uv; break;
7462                 default:        break;
7463                 case 'l':       uv = (unsigned long)uv; break;
7464                 case 'V':       break;
7465 #ifdef HAS_QUAD
7466                 case 'q':       uv = (Quad_t)uv; break;
7467 #endif
7468                 }
7469             }
7470
7471         integer:
7472             eptr = ebuf + sizeof ebuf;
7473             switch (base) {
7474                 unsigned dig;
7475             case 16:
7476                 if (!uv)
7477                     alt = FALSE;
7478                 p = (char*)((c == 'X')
7479                             ? "0123456789ABCDEF" : "0123456789abcdef");
7480                 do {
7481                     dig = uv & 15;
7482                     *--eptr = p[dig];
7483                 } while (uv >>= 4);
7484                 if (alt) {
7485                     esignbuf[esignlen++] = '0';
7486                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
7487                 }
7488                 break;
7489             case 8:
7490                 do {
7491                     dig = uv & 7;
7492                     *--eptr = '0' + dig;
7493                 } while (uv >>= 3);
7494                 if (alt && *eptr != '0')
7495                     *--eptr = '0';
7496                 break;
7497             case 2:
7498                 do {
7499                     dig = uv & 1;
7500                     *--eptr = '0' + dig;
7501                 } while (uv >>= 1);
7502                 if (alt) {
7503                     esignbuf[esignlen++] = '0';
7504                     esignbuf[esignlen++] = 'b';
7505                 }
7506                 break;
7507             default:            /* it had better be ten or less */
7508 #if defined(PERL_Y2KWARN)
7509                 if (ckWARN(WARN_Y2K)) {
7510                     STRLEN n;
7511                     char *s = SvPV(sv,n);
7512                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7513                         && (n == 2 || !isDIGIT(s[n-3])))
7514                     {
7515                         Perl_warner(aTHX_ WARN_Y2K,
7516                                     "Possible Y2K bug: %%%c %s",
7517                                     c, "format string following '19'");
7518                     }
7519                 }
7520 #endif
7521                 do {
7522                     dig = uv % base;
7523                     *--eptr = '0' + dig;
7524                 } while (uv /= base);
7525                 break;
7526             }
7527             elen = (ebuf + sizeof ebuf) - eptr;
7528             if (has_precis) {
7529                 if (precis > elen)
7530                     zeros = precis - elen;
7531                 else if (precis == 0 && elen == 1 && *eptr == '0')
7532                     elen = 0;
7533             }
7534             break;
7535
7536             /* FLOATING POINT */
7537
7538         case 'F':
7539             c = 'f';            /* maybe %F isn't supported here */
7540             /* FALL THROUGH */
7541         case 'e': case 'E':
7542         case 'f':
7543         case 'g': case 'G':
7544
7545             /* This is evil, but floating point is even more evil */
7546
7547             vectorize = FALSE;
7548             nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7549
7550             need = 0;
7551             if (c != 'e' && c != 'E') {
7552                 i = PERL_INT_MIN;
7553                 (void)Perl_frexp(nv, &i);
7554                 if (i == PERL_INT_MIN)
7555                     Perl_die(aTHX_ "panic: frexp");
7556                 if (i > 0)
7557                     need = BIT_DIGITS(i);
7558             }
7559             need += has_precis ? precis : 6; /* known default */
7560             if (need < width)
7561                 need = width;
7562
7563             need += 20; /* fudge factor */
7564             if (PL_efloatsize < need) {
7565                 Safefree(PL_efloatbuf);
7566                 PL_efloatsize = need + 20; /* more fudge */
7567                 New(906, PL_efloatbuf, PL_efloatsize, char);
7568                 PL_efloatbuf[0] = '\0';
7569             }
7570
7571             eptr = ebuf + sizeof ebuf;
7572             *--eptr = '\0';
7573             *--eptr = c;
7574 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7575             {
7576                 /* Copy the one or more characters in a long double
7577                  * format before the 'base' ([efgEFG]) character to
7578                  * the format string. */
7579                 static char const prifldbl[] = PERL_PRIfldbl;
7580                 char const *p = prifldbl + sizeof(prifldbl) - 3;
7581                 while (p >= prifldbl) { *--eptr = *p--; }
7582             }
7583 #endif
7584             if (has_precis) {
7585                 base = precis;
7586                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7587                 *--eptr = '.';
7588             }
7589             if (width) {
7590                 base = width;
7591                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7592             }
7593             if (fill == '0')
7594                 *--eptr = fill;
7595             if (left)
7596                 *--eptr = '-';
7597             if (plus)
7598                 *--eptr = plus;
7599             if (alt)
7600                 *--eptr = '#';
7601             *--eptr = '%';
7602
7603             /* No taint.  Otherwise we are in the strange situation
7604              * where printf() taints but print($float) doesn't.
7605              * --jhi */
7606             (void)sprintf(PL_efloatbuf, eptr, nv);
7607
7608             eptr = PL_efloatbuf;
7609             elen = strlen(PL_efloatbuf);
7610             break;
7611
7612             /* SPECIAL */
7613
7614         case 'n':
7615             vectorize = FALSE;
7616             i = SvCUR(sv) - origlen;
7617             if (args) {
7618                 switch (intsize) {
7619                 case 'h':       *(va_arg(*args, short*)) = i; break;
7620                 default:        *(va_arg(*args, int*)) = i; break;
7621                 case 'l':       *(va_arg(*args, long*)) = i; break;
7622                 case 'V':       *(va_arg(*args, IV*)) = i; break;
7623 #ifdef HAS_QUAD
7624                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
7625 #endif
7626                 }
7627             }
7628             else
7629                 sv_setuv_mg(argsv, (UV)i);
7630             continue;   /* not "break" */
7631
7632             /* UNKNOWN */
7633
7634         default:
7635       unknown:
7636             vectorize = FALSE;
7637             if (!args && ckWARN(WARN_PRINTF) &&
7638                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7639                 SV *msg = sv_newmortal();
7640                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7641                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7642                 if (c) {
7643                     if (isPRINT(c))
7644                         Perl_sv_catpvf(aTHX_ msg,
7645                                        "\"%%%c\"", c & 0xFF);
7646                     else
7647                         Perl_sv_catpvf(aTHX_ msg,
7648                                        "\"%%\\%03"UVof"\"",
7649                                        (UV)c & 0xFF);
7650                 } else
7651                     sv_catpv(msg, "end of string");
7652                 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7653             }
7654
7655             /* output mangled stuff ... */
7656             if (c == '\0')
7657                 --q;
7658             eptr = p;
7659             elen = q - p;
7660
7661             /* ... right here, because formatting flags should not apply */
7662             SvGROW(sv, SvCUR(sv) + elen + 1);
7663             p = SvEND(sv);
7664             Copy(eptr, p, elen, char);
7665             p += elen;
7666             *p = '\0';
7667             SvCUR(sv) = p - SvPVX(sv);
7668             continue;   /* not "break" */
7669         }
7670
7671         have = esignlen + zeros + elen;
7672         need = (have > width ? have : width);
7673         gap = need - have;
7674
7675         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7676         p = SvEND(sv);
7677         if (esignlen && fill == '0') {
7678             for (i = 0; i < esignlen; i++)
7679                 *p++ = esignbuf[i];
7680         }
7681         if (gap && !left) {
7682             memset(p, fill, gap);
7683             p += gap;
7684         }
7685         if (esignlen && fill != '0') {
7686             for (i = 0; i < esignlen; i++)
7687                 *p++ = esignbuf[i];
7688         }
7689         if (zeros) {
7690             for (i = zeros; i; i--)
7691                 *p++ = '0';
7692         }
7693         if (elen) {
7694             Copy(eptr, p, elen, char);
7695             p += elen;
7696         }
7697         if (gap && left) {
7698             memset(p, ' ', gap);
7699             p += gap;
7700         }
7701         if (vectorize) {
7702             if (veclen) {
7703                 Copy(dotstr, p, dotstrlen, char);
7704                 p += dotstrlen;
7705             }
7706             else
7707                 vectorize = FALSE;              /* done iterating over vecstr */
7708         }
7709         if (is_utf)
7710             SvUTF8_on(sv);
7711         *p = '\0';
7712         SvCUR(sv) = p - SvPVX(sv);
7713         if (vectorize) {
7714             esignlen = 0;
7715             goto vector;
7716         }
7717     }
7718 }
7719
7720 #if defined(USE_ITHREADS)
7721
7722 #if defined(USE_THREADS)
7723 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
7724 #endif
7725
7726 #ifndef GpREFCNT_inc
7727 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7728 #endif
7729
7730
7731 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
7732 #define av_dup(s)       (AV*)sv_dup((SV*)s)
7733 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7734 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
7735 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7736 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
7737 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7738 #define io_dup(s)       (IO*)sv_dup((SV*)s)
7739 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7740 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
7741 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7742 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
7743 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
7744
7745 REGEXP *
7746 Perl_re_dup(pTHX_ REGEXP *r)
7747 {
7748     /* XXX fix when pmop->op_pmregexp becomes shared */
7749     return ReREFCNT_inc(r);
7750 }
7751
7752 PerlIO *
7753 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7754 {
7755     PerlIO *ret;
7756     if (!fp)
7757         return (PerlIO*)NULL;
7758
7759     /* look for it in the table first */
7760     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7761     if (ret)
7762         return ret;
7763
7764     /* create anew and remember what it is */
7765     ret = PerlIO_fdupopen(aTHX_ fp);
7766     ptr_table_store(PL_ptr_table, fp, ret);
7767     return ret;
7768 }
7769
7770 DIR *
7771 Perl_dirp_dup(pTHX_ DIR *dp)
7772 {
7773     if (!dp)
7774         return (DIR*)NULL;
7775     /* XXX TODO */
7776     return dp;
7777 }
7778
7779 GP *
7780 Perl_gp_dup(pTHX_ GP *gp)
7781 {
7782     GP *ret;
7783     if (!gp)
7784         return (GP*)NULL;
7785     /* look for it in the table first */
7786     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7787     if (ret)
7788         return ret;
7789
7790     /* create anew and remember what it is */
7791     Newz(0, ret, 1, GP);
7792     ptr_table_store(PL_ptr_table, gp, ret);
7793
7794     /* clone */
7795     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
7796     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
7797     ret->gp_io          = io_dup_inc(gp->gp_io);
7798     ret->gp_form        = cv_dup_inc(gp->gp_form);
7799     ret->gp_av          = av_dup_inc(gp->gp_av);
7800     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
7801     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
7802     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
7803     ret->gp_cvgen       = gp->gp_cvgen;
7804     ret->gp_flags       = gp->gp_flags;
7805     ret->gp_line        = gp->gp_line;
7806     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
7807     return ret;
7808 }
7809
7810 MAGIC *
7811 Perl_mg_dup(pTHX_ MAGIC *mg)
7812 {
7813     MAGIC *mgprev = (MAGIC*)NULL;
7814     MAGIC *mgret;
7815     if (!mg)
7816         return (MAGIC*)NULL;
7817     /* look for it in the table first */
7818     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7819     if (mgret)
7820         return mgret;
7821
7822     for (; mg; mg = mg->mg_moremagic) {
7823         MAGIC *nmg;
7824         Newz(0, nmg, 1, MAGIC);
7825         if (mgprev)
7826             mgprev->mg_moremagic = nmg;
7827         else
7828             mgret = nmg;
7829         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
7830         nmg->mg_private = mg->mg_private;
7831         nmg->mg_type    = mg->mg_type;
7832         nmg->mg_flags   = mg->mg_flags;
7833         if (mg->mg_type == PERL_MAGIC_qr) {
7834             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7835         }
7836         else {
7837             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7838                               ? sv_dup_inc(mg->mg_obj)
7839                               : sv_dup(mg->mg_obj);
7840         }
7841         nmg->mg_len     = mg->mg_len;
7842         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
7843         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7844             if (mg->mg_len >= 0) {
7845                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
7846                 if (mg->mg_type == PERL_MAGIC_overload_table &&
7847                         AMT_AMAGIC((AMT*)mg->mg_ptr))
7848                 {
7849                     AMT *amtp = (AMT*)mg->mg_ptr;
7850                     AMT *namtp = (AMT*)nmg->mg_ptr;
7851                     I32 i;
7852                     for (i = 1; i < NofAMmeth; i++) {
7853                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
7854                     }
7855                 }
7856             }
7857             else if (mg->mg_len == HEf_SVKEY)
7858                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7859         }
7860         mgprev = nmg;
7861     }
7862     return mgret;
7863 }
7864
7865 PTR_TBL_t *
7866 Perl_ptr_table_new(pTHX)
7867 {
7868     PTR_TBL_t *tbl;
7869     Newz(0, tbl, 1, PTR_TBL_t);
7870     tbl->tbl_max        = 511;
7871     tbl->tbl_items      = 0;
7872     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7873     return tbl;
7874 }
7875
7876 void *
7877 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7878 {
7879     PTR_TBL_ENT_t *tblent;
7880     UV hash = PTR2UV(sv);
7881     assert(tbl);
7882     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7883     for (; tblent; tblent = tblent->next) {
7884         if (tblent->oldval == sv)
7885             return tblent->newval;
7886     }
7887     return (void*)NULL;
7888 }
7889
7890 void
7891 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7892 {
7893     PTR_TBL_ENT_t *tblent, **otblent;
7894     /* XXX this may be pessimal on platforms where pointers aren't good
7895      * hash values e.g. if they grow faster in the most significant
7896      * bits */
7897     UV hash = PTR2UV(oldv);
7898     bool i = 1;
7899
7900     assert(tbl);
7901     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7902     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7903         if (tblent->oldval == oldv) {
7904             tblent->newval = newv;
7905             tbl->tbl_items++;
7906             return;
7907         }
7908     }
7909     Newz(0, tblent, 1, PTR_TBL_ENT_t);
7910     tblent->oldval = oldv;
7911     tblent->newval = newv;
7912     tblent->next = *otblent;
7913     *otblent = tblent;
7914     tbl->tbl_items++;
7915     if (i && tbl->tbl_items > tbl->tbl_max)
7916         ptr_table_split(tbl);
7917 }
7918
7919 void
7920 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7921 {
7922     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7923     UV oldsize = tbl->tbl_max + 1;
7924     UV newsize = oldsize * 2;
7925     UV i;
7926
7927     Renew(ary, newsize, PTR_TBL_ENT_t*);
7928     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7929     tbl->tbl_max = --newsize;
7930     tbl->tbl_ary = ary;
7931     for (i=0; i < oldsize; i++, ary++) {
7932         PTR_TBL_ENT_t **curentp, **entp, *ent;
7933         if (!*ary)
7934             continue;
7935         curentp = ary + oldsize;
7936         for (entp = ary, ent = *ary; ent; ent = *entp) {
7937             if ((newsize & PTR2UV(ent->oldval)) != i) {
7938                 *entp = ent->next;
7939                 ent->next = *curentp;
7940                 *curentp = ent;
7941                 continue;
7942             }
7943             else
7944                 entp = &ent->next;
7945         }
7946     }
7947 }
7948
7949 void
7950 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7951 {
7952     register PTR_TBL_ENT_t **array;
7953     register PTR_TBL_ENT_t *entry;
7954     register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7955     UV riter = 0;
7956     UV max;
7957
7958     if (!tbl || !tbl->tbl_items) {
7959         return;
7960     }
7961
7962     array = tbl->tbl_ary;
7963     entry = array[0];
7964     max = tbl->tbl_max;
7965
7966     for (;;) {
7967         if (entry) {
7968             oentry = entry;
7969             entry = entry->next;
7970             Safefree(oentry);
7971         }
7972         if (!entry) {
7973             if (++riter > max) {
7974                 break;
7975             }
7976             entry = array[riter];
7977         }
7978     }
7979
7980     tbl->tbl_items = 0;
7981 }
7982
7983 void
7984 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7985 {
7986     if (!tbl) {
7987         return;
7988     }
7989     ptr_table_clear(tbl);
7990     Safefree(tbl->tbl_ary);
7991     Safefree(tbl);
7992 }
7993
7994 #ifdef DEBUGGING
7995 char *PL_watch_pvx;
7996 #endif
7997
7998 STATIC SV *
7999 S_gv_share(pTHX_ SV *sstr)
8000 {
8001     GV *gv = (GV*)sstr;
8002     SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8003
8004     if (GvIO(gv) || GvFORM(gv)) {
8005         GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8006     }
8007     else if (!GvCV(gv)) {
8008         GvCV(gv) = (CV*)sv;
8009     }
8010     else {
8011         /* CvPADLISTs cannot be shared */
8012         if (!CvXSUB(GvCV(gv))) {
8013             GvSHARED_off(gv);
8014         }
8015     }
8016
8017     if (!GvSHARED(gv)) {
8018 #if 0
8019         PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8020                       HvNAME(GvSTASH(gv)), GvNAME(gv));
8021 #endif
8022         return Nullsv;
8023     }
8024
8025     /*
8026      * write attempts will die with
8027      * "Modification of a read-only value attempted"
8028      */
8029     if (!GvSV(gv)) {
8030         GvSV(gv) = sv;
8031     }
8032     else {
8033         SvREADONLY_on(GvSV(gv));
8034     }
8035
8036     if (!GvAV(gv)) {
8037         GvAV(gv) = (AV*)sv;
8038     }
8039     else {
8040         SvREADONLY_on(GvAV(gv));
8041     }
8042
8043     if (!GvHV(gv)) {
8044         GvHV(gv) = (HV*)sv;
8045     }
8046     else {
8047         SvREADONLY_on(GvAV(gv));
8048     }
8049
8050     return sstr; /* he_dup() will SvREFCNT_inc() */
8051 }
8052
8053 SV *
8054 Perl_sv_dup(pTHX_ SV *sstr)
8055 {
8056     SV *dstr;
8057
8058     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8059         return Nullsv;
8060     /* look for it in the table first */
8061     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8062     if (dstr)
8063         return dstr;
8064
8065     /* create anew and remember what it is */
8066     new_SV(dstr);
8067     ptr_table_store(PL_ptr_table, sstr, dstr);
8068
8069     /* clone */
8070     SvFLAGS(dstr)       = SvFLAGS(sstr);
8071     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
8072     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
8073
8074 #ifdef DEBUGGING
8075     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8076         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8077                       PL_watch_pvx, SvPVX(sstr));
8078 #endif
8079
8080     switch (SvTYPE(sstr)) {
8081     case SVt_NULL:
8082         SvANY(dstr)     = NULL;
8083         break;
8084     case SVt_IV:
8085         SvANY(dstr)     = new_XIV();
8086         SvIVX(dstr)     = SvIVX(sstr);
8087         break;
8088     case SVt_NV:
8089         SvANY(dstr)     = new_XNV();
8090         SvNVX(dstr)     = SvNVX(sstr);
8091         break;
8092     case SVt_RV:
8093         SvANY(dstr)     = new_XRV();
8094         SvRV(dstr)      = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
8095                         ? sv_dup(SvRV(sstr))
8096                         : sv_dup_inc(SvRV(sstr));
8097         break;
8098     case SVt_PV:
8099         SvANY(dstr)     = new_XPV();
8100         SvCUR(dstr)     = SvCUR(sstr);
8101         SvLEN(dstr)     = SvLEN(sstr);
8102         if (SvROK(sstr))
8103             SvRV(dstr)  = SvWEAKREF(SvRV(sstr))
8104                         ? sv_dup(SvRV(sstr))
8105                         : sv_dup_inc(SvRV(sstr));
8106         else if (SvPVX(sstr) && SvLEN(sstr))
8107             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8108         else
8109             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
8110         break;
8111     case SVt_PVIV:
8112         SvANY(dstr)     = new_XPVIV();
8113         SvCUR(dstr)     = SvCUR(sstr);
8114         SvLEN(dstr)     = SvLEN(sstr);
8115         SvIVX(dstr)     = SvIVX(sstr);
8116         if (SvROK(sstr))
8117             SvRV(dstr)  = SvWEAKREF(SvRV(sstr))
8118                         ? sv_dup(SvRV(sstr))
8119                         : sv_dup_inc(SvRV(sstr));
8120         else if (SvPVX(sstr) && SvLEN(sstr))
8121             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8122         else
8123             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
8124         break;
8125     case SVt_PVNV:
8126         SvANY(dstr)     = new_XPVNV();
8127         SvCUR(dstr)     = SvCUR(sstr);
8128         SvLEN(dstr)     = SvLEN(sstr);
8129         SvIVX(dstr)     = SvIVX(sstr);
8130         SvNVX(dstr)     = SvNVX(sstr);
8131         if (SvROK(sstr))
8132             SvRV(dstr)  = SvWEAKREF(SvRV(sstr))
8133                         ? sv_dup(SvRV(sstr))
8134                         : sv_dup_inc(SvRV(sstr));
8135         else if (SvPVX(sstr) && SvLEN(sstr))
8136             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8137         else
8138             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
8139         break;
8140     case SVt_PVMG:
8141         SvANY(dstr)     = new_XPVMG();
8142         SvCUR(dstr)     = SvCUR(sstr);
8143         SvLEN(dstr)     = SvLEN(sstr);
8144         SvIVX(dstr)     = SvIVX(sstr);
8145         SvNVX(dstr)     = SvNVX(sstr);
8146         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
8147         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
8148         if (SvROK(sstr))
8149             SvRV(dstr)  = SvWEAKREF(SvRV(sstr))
8150                         ? sv_dup(SvRV(sstr))
8151                         : sv_dup_inc(SvRV(sstr));
8152         else if (SvPVX(sstr) && SvLEN(sstr))
8153             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8154         else
8155             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
8156         break;
8157     case SVt_PVBM:
8158         SvANY(dstr)     = new_XPVBM();
8159         SvCUR(dstr)     = SvCUR(sstr);
8160         SvLEN(dstr)     = SvLEN(sstr);
8161         SvIVX(dstr)     = SvIVX(sstr);
8162         SvNVX(dstr)     = SvNVX(sstr);
8163         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
8164         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
8165         if (SvROK(sstr))
8166             SvRV(dstr)  = SvWEAKREF(SvRV(sstr))
8167                         ? sv_dup(SvRV(sstr))
8168                         : sv_dup_inc(SvRV(sstr));
8169         else if (SvPVX(sstr) && SvLEN(sstr))
8170             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8171         else
8172             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
8173         BmRARE(dstr)    = BmRARE(sstr);
8174         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
8175         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8176         break;
8177     case SVt_PVLV:
8178         SvANY(dstr)     = new_XPVLV();
8179         SvCUR(dstr)     = SvCUR(sstr);
8180         SvLEN(dstr)     = SvLEN(sstr);
8181         SvIVX(dstr)     = SvIVX(sstr);
8182         SvNVX(dstr)     = SvNVX(sstr);
8183         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
8184         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
8185         if (SvROK(sstr))
8186             SvRV(dstr)  = SvWEAKREF(SvRV(sstr))
8187                         ? sv_dup(SvRV(sstr))
8188                         : sv_dup_inc(SvRV(sstr));
8189         else if (SvPVX(sstr) && SvLEN(sstr))
8190             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8191         else
8192             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
8193         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
8194         LvTARGLEN(dstr) = LvTARGLEN(sstr);
8195         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
8196         LvTYPE(dstr)    = LvTYPE(sstr);
8197         break;
8198     case SVt_PVGV:
8199         if (GvSHARED((GV*)sstr)) {
8200             SV *share;
8201             if ((share = gv_share(sstr))) {
8202                 del_SV(dstr);
8203                 dstr = share;
8204 #if 0
8205                 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8206                               HvNAME(GvSTASH(share)), GvNAME(share));
8207 #endif
8208                 break;
8209             }
8210         }
8211         SvANY(dstr)     = new_XPVGV();
8212         SvCUR(dstr)     = SvCUR(sstr);
8213         SvLEN(dstr)     = SvLEN(sstr);
8214         SvIVX(dstr)     = SvIVX(sstr);
8215         SvNVX(dstr)     = SvNVX(sstr);
8216         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
8217         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
8218         if (SvROK(sstr))
8219             SvRV(dstr)  = SvWEAKREF(SvRV(sstr))
8220                         ? sv_dup(SvRV(sstr))
8221                         : sv_dup_inc(SvRV(sstr));
8222         else if (SvPVX(sstr) && SvLEN(sstr))
8223             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8224         else
8225             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
8226         GvNAMELEN(dstr) = GvNAMELEN(sstr);
8227         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8228         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
8229         GvFLAGS(dstr)   = GvFLAGS(sstr);
8230         GvGP(dstr)      = gp_dup(GvGP(sstr));
8231         (void)GpREFCNT_inc(GvGP(dstr));
8232         break;
8233     case SVt_PVIO:
8234         SvANY(dstr)     = new_XPVIO();
8235         SvCUR(dstr)     = SvCUR(sstr);
8236         SvLEN(dstr)     = SvLEN(sstr);
8237         SvIVX(dstr)     = SvIVX(sstr);
8238         SvNVX(dstr)     = SvNVX(sstr);
8239         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
8240         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
8241         if (SvROK(sstr))
8242             SvRV(dstr)  = SvWEAKREF(SvRV(sstr))
8243                         ? sv_dup(SvRV(sstr))
8244                         : sv_dup_inc(SvRV(sstr));
8245         else if (SvPVX(sstr) && SvLEN(sstr))
8246             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8247         else
8248             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
8249         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8250         if (IoOFP(sstr) == IoIFP(sstr))
8251             IoOFP(dstr) = IoIFP(dstr);
8252         else
8253             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8254         /* PL_rsfp_filters entries have fake IoDIRP() */
8255         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8256             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
8257         else
8258             IoDIRP(dstr)        = IoDIRP(sstr);
8259         IoLINES(dstr)           = IoLINES(sstr);
8260         IoPAGE(dstr)            = IoPAGE(sstr);
8261         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
8262         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
8263         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
8264         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
8265         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
8266         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
8267         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
8268         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
8269         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
8270         IoTYPE(dstr)            = IoTYPE(sstr);
8271         IoFLAGS(dstr)           = IoFLAGS(sstr);
8272         break;
8273     case SVt_PVAV:
8274         SvANY(dstr)     = new_XPVAV();
8275         SvCUR(dstr)     = SvCUR(sstr);
8276         SvLEN(dstr)     = SvLEN(sstr);
8277         SvIVX(dstr)     = SvIVX(sstr);
8278         SvNVX(dstr)     = SvNVX(sstr);
8279         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
8280         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
8281         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8282         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8283         if (AvARRAY((AV*)sstr)) {
8284             SV **dst_ary, **src_ary;
8285             SSize_t items = AvFILLp((AV*)sstr) + 1;
8286
8287             src_ary = AvARRAY((AV*)sstr);
8288             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8289             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8290             SvPVX(dstr) = (char*)dst_ary;
8291             AvALLOC((AV*)dstr) = dst_ary;
8292             if (AvREAL((AV*)sstr)) {
8293                 while (items-- > 0)
8294                     *dst_ary++ = sv_dup_inc(*src_ary++);
8295             }
8296             else {
8297                 while (items-- > 0)
8298                     *dst_ary++ = sv_dup(*src_ary++);
8299             }
8300             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8301             while (items-- > 0) {
8302                 *dst_ary++ = &PL_sv_undef;
8303             }
8304         }
8305         else {
8306             SvPVX(dstr)         = Nullch;
8307             AvALLOC((AV*)dstr)  = (SV**)NULL;
8308         }
8309         break;
8310     case SVt_PVHV:
8311         SvANY(dstr)     = new_XPVHV();
8312         SvCUR(dstr)     = SvCUR(sstr);
8313         SvLEN(dstr)     = SvLEN(sstr);
8314         SvIVX(dstr)     = SvIVX(sstr);
8315         SvNVX(dstr)     = SvNVX(sstr);
8316         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
8317         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
8318         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
8319         if (HvARRAY((HV*)sstr)) {
8320             STRLEN i = 0;
8321             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8322             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8323             Newz(0, dxhv->xhv_array,
8324                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8325             while (i <= sxhv->xhv_max) {
8326                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8327                                                     !!HvSHAREKEYS(sstr));
8328                 ++i;
8329             }
8330             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8331         }
8332         else {
8333             SvPVX(dstr)         = Nullch;
8334             HvEITER((HV*)dstr)  = (HE*)NULL;
8335         }
8336         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
8337         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
8338         break;
8339     case SVt_PVFM:
8340         SvANY(dstr)     = new_XPVFM();
8341         FmLINES(dstr)   = FmLINES(sstr);
8342         goto dup_pvcv;
8343         /* NOTREACHED */
8344     case SVt_PVCV:
8345         SvANY(dstr)     = new_XPVCV();
8346 dup_pvcv:
8347         SvCUR(dstr)     = SvCUR(sstr);
8348         SvLEN(dstr)     = SvLEN(sstr);
8349         SvIVX(dstr)     = SvIVX(sstr);
8350         SvNVX(dstr)     = SvNVX(sstr);
8351         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
8352         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
8353         if (SvPVX(sstr) && SvLEN(sstr))
8354             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8355         else
8356             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
8357         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8358         CvSTART(dstr)   = CvSTART(sstr);
8359         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
8360         CvXSUB(dstr)    = CvXSUB(sstr);
8361         CvXSUBANY(dstr) = CvXSUBANY(sstr);
8362         CvGV(dstr)      = gv_dup(CvGV(sstr));
8363         CvDEPTH(dstr)   = CvDEPTH(sstr);
8364         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8365             /* XXX padlists are real, but pretend to be not */
8366             AvREAL_on(CvPADLIST(sstr));
8367             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
8368             AvREAL_off(CvPADLIST(sstr));
8369             AvREAL_off(CvPADLIST(dstr));
8370         }
8371         else
8372             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
8373         if (!CvANON(sstr) || CvCLONED(sstr))
8374             CvOUTSIDE(dstr)     = cv_dup_inc(CvOUTSIDE(sstr));
8375         else
8376             CvOUTSIDE(dstr)     = cv_dup(CvOUTSIDE(sstr));
8377         CvFLAGS(dstr)   = CvFLAGS(sstr);
8378         break;
8379     default:
8380         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8381         break;
8382     }
8383
8384     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8385         ++PL_sv_objcount;
8386
8387     return dstr;
8388 }
8389
8390 PERL_CONTEXT *
8391 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8392 {
8393     PERL_CONTEXT *ncxs;
8394
8395     if (!cxs)
8396         return (PERL_CONTEXT*)NULL;
8397
8398     /* look for it in the table first */
8399     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8400     if (ncxs)
8401         return ncxs;
8402
8403     /* create anew and remember what it is */
8404     Newz(56, ncxs, max + 1, PERL_CONTEXT);
8405     ptr_table_store(PL_ptr_table, cxs, ncxs);
8406
8407     while (ix >= 0) {
8408         PERL_CONTEXT *cx = &cxs[ix];
8409         PERL_CONTEXT *ncx = &ncxs[ix];
8410         ncx->cx_type    = cx->cx_type;
8411         if (CxTYPE(cx) == CXt_SUBST) {
8412             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8413         }
8414         else {
8415             ncx->blk_oldsp      = cx->blk_oldsp;
8416             ncx->blk_oldcop     = cx->blk_oldcop;
8417             ncx->blk_oldretsp   = cx->blk_oldretsp;
8418             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
8419             ncx->blk_oldscopesp = cx->blk_oldscopesp;
8420             ncx->blk_oldpm      = cx->blk_oldpm;
8421             ncx->blk_gimme      = cx->blk_gimme;
8422             switch (CxTYPE(cx)) {
8423             case CXt_SUB:
8424                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
8425                                            ? cv_dup_inc(cx->blk_sub.cv)
8426                                            : cv_dup(cx->blk_sub.cv));
8427                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
8428                                            ? av_dup_inc(cx->blk_sub.argarray)
8429                                            : Nullav);
8430                 ncx->blk_sub.savearray  = av_dup_inc(cx->blk_sub.savearray);
8431                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
8432                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
8433                 ncx->blk_sub.lval       = cx->blk_sub.lval;
8434                 break;
8435             case CXt_EVAL:
8436                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8437                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8438                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8439                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8440                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
8441                 break;
8442             case CXt_LOOP:
8443                 ncx->blk_loop.label     = cx->blk_loop.label;
8444                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
8445                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
8446                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
8447                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
8448                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
8449                                            ? cx->blk_loop.iterdata
8450                                            : gv_dup((GV*)cx->blk_loop.iterdata));
8451                 ncx->blk_loop.oldcurpad
8452                     = (SV**)ptr_table_fetch(PL_ptr_table,
8453                                             cx->blk_loop.oldcurpad);
8454                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
8455                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
8456                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
8457                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
8458                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
8459                 break;
8460             case CXt_FORMAT:
8461                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
8462                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
8463                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
8464                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
8465                 break;
8466             case CXt_BLOCK:
8467             case CXt_NULL:
8468                 break;
8469             }
8470         }
8471         --ix;
8472     }
8473     return ncxs;
8474 }
8475
8476 PERL_SI *
8477 Perl_si_dup(pTHX_ PERL_SI *si)
8478 {
8479     PERL_SI *nsi;
8480
8481     if (!si)
8482         return (PERL_SI*)NULL;
8483
8484     /* look for it in the table first */
8485     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8486     if (nsi)
8487         return nsi;
8488
8489     /* create anew and remember what it is */
8490     Newz(56, nsi, 1, PERL_SI);
8491     ptr_table_store(PL_ptr_table, si, nsi);
8492
8493     nsi->si_stack       = av_dup_inc(si->si_stack);
8494     nsi->si_cxix        = si->si_cxix;
8495     nsi->si_cxmax       = si->si_cxmax;
8496     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8497     nsi->si_type        = si->si_type;
8498     nsi->si_prev        = si_dup(si->si_prev);
8499     nsi->si_next        = si_dup(si->si_next);
8500     nsi->si_markoff     = si->si_markoff;
8501
8502     return nsi;
8503 }
8504
8505 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
8506 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
8507 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
8508 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
8509 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
8510 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
8511 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
8512 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
8513 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
8514 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
8515 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8516 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8517
8518 /* XXXXX todo */
8519 #define pv_dup_inc(p)   SAVEPV(p)
8520 #define pv_dup(p)       SAVEPV(p)
8521 #define svp_dup_inc(p,pp)       any_dup(p,pp)
8522
8523 void *
8524 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8525 {
8526     void *ret;
8527
8528     if (!v)
8529         return (void*)NULL;
8530
8531     /* look for it in the table first */
8532     ret = ptr_table_fetch(PL_ptr_table, v);
8533     if (ret)
8534         return ret;
8535
8536     /* see if it is part of the interpreter structure */
8537     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8538         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8539     else
8540         ret = v;
8541
8542     return ret;
8543 }
8544
8545 ANY *
8546 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8547 {
8548     ANY *ss     = proto_perl->Tsavestack;
8549     I32 ix      = proto_perl->Tsavestack_ix;
8550     I32 max     = proto_perl->Tsavestack_max;
8551     ANY *nss;
8552     SV *sv;
8553     GV *gv;
8554     AV *av;
8555     HV *hv;
8556     void* ptr;
8557     int intval;
8558     long longval;
8559     GP *gp;
8560     IV iv;
8561     I32 i;
8562     char *c;
8563     void (*dptr) (void*);
8564     void (*dxptr) (pTHXo_ void*);
8565     OP *o;
8566
8567     Newz(54, nss, max, ANY);
8568
8569     while (ix > 0) {
8570         i = POPINT(ss,ix);
8571         TOPINT(nss,ix) = i;
8572         switch (i) {
8573         case SAVEt_ITEM:                        /* normal string */
8574             sv = (SV*)POPPTR(ss,ix);
8575             TOPPTR(nss,ix) = sv_dup_inc(sv);
8576             sv = (SV*)POPPTR(ss,ix);
8577             TOPPTR(nss,ix) = sv_dup_inc(sv);
8578             break;
8579         case SAVEt_SV:                          /* scalar reference */
8580             sv = (SV*)POPPTR(ss,ix);
8581             TOPPTR(nss,ix) = sv_dup_inc(sv);
8582             gv = (GV*)POPPTR(ss,ix);
8583             TOPPTR(nss,ix) = gv_dup_inc(gv);
8584             break;
8585         case SAVEt_GENERIC_PVREF:               /* generic char* */
8586             c = (char*)POPPTR(ss,ix);
8587             TOPPTR(nss,ix) = pv_dup(c);
8588             ptr = POPPTR(ss,ix);
8589             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8590             break;
8591         case SAVEt_GENERIC_SVREF:               /* generic sv */
8592         case SAVEt_SVREF:                       /* scalar reference */
8593             sv = (SV*)POPPTR(ss,ix);
8594             TOPPTR(nss,ix) = sv_dup_inc(sv);
8595             ptr = POPPTR(ss,ix);
8596             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8597             break;
8598         case SAVEt_AV:                          /* array reference */
8599             av = (AV*)POPPTR(ss,ix);
8600             TOPPTR(nss,ix) = av_dup_inc(av);
8601             gv = (GV*)POPPTR(ss,ix);
8602             TOPPTR(nss,ix) = gv_dup(gv);
8603             break;
8604         case SAVEt_HV:                          /* hash reference */
8605             hv = (HV*)POPPTR(ss,ix);
8606             TOPPTR(nss,ix) = hv_dup_inc(hv);
8607             gv = (GV*)POPPTR(ss,ix);
8608             TOPPTR(nss,ix) = gv_dup(gv);
8609             break;
8610         case SAVEt_INT:                         /* int reference */
8611             ptr = POPPTR(ss,ix);
8612             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8613             intval = (int)POPINT(ss,ix);
8614             TOPINT(nss,ix) = intval;
8615             break;
8616         case SAVEt_LONG:                        /* long reference */
8617             ptr = POPPTR(ss,ix);
8618             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8619             longval = (long)POPLONG(ss,ix);
8620             TOPLONG(nss,ix) = longval;
8621             break;
8622         case SAVEt_I32:                         /* I32 reference */
8623         case SAVEt_I16:                         /* I16 reference */
8624         case SAVEt_I8:                          /* I8 reference */
8625             ptr = POPPTR(ss,ix);
8626             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8627             i = POPINT(ss,ix);
8628             TOPINT(nss,ix) = i;
8629             break;
8630         case SAVEt_IV:                          /* IV reference */
8631             ptr = POPPTR(ss,ix);
8632             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8633             iv = POPIV(ss,ix);
8634             TOPIV(nss,ix) = iv;
8635             break;
8636         case SAVEt_SPTR:                        /* SV* reference */
8637             ptr = POPPTR(ss,ix);
8638             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8639             sv = (SV*)POPPTR(ss,ix);
8640             TOPPTR(nss,ix) = sv_dup(sv);
8641             break;
8642         case SAVEt_VPTR:                        /* random* reference */
8643             ptr = POPPTR(ss,ix);
8644             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8645             ptr = POPPTR(ss,ix);
8646             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8647             break;
8648         case SAVEt_PPTR:                        /* char* reference */
8649             ptr = POPPTR(ss,ix);
8650             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8651             c = (char*)POPPTR(ss,ix);
8652             TOPPTR(nss,ix) = pv_dup(c);
8653             break;
8654         case SAVEt_HPTR:                        /* HV* reference */
8655             ptr = POPPTR(ss,ix);
8656             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8657             hv = (HV*)POPPTR(ss,ix);
8658             TOPPTR(nss,ix) = hv_dup(hv);
8659             break;
8660         case SAVEt_APTR:                        /* AV* reference */
8661             ptr = POPPTR(ss,ix);
8662             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8663             av = (AV*)POPPTR(ss,ix);
8664             TOPPTR(nss,ix) = av_dup(av);
8665             break;
8666         case SAVEt_NSTAB:
8667             gv = (GV*)POPPTR(ss,ix);
8668             TOPPTR(nss,ix) = gv_dup(gv);
8669             break;
8670         case SAVEt_GP:                          /* scalar reference */
8671             gp = (GP*)POPPTR(ss,ix);
8672             TOPPTR(nss,ix) = gp = gp_dup(gp);
8673             (void)GpREFCNT_inc(gp);
8674             gv = (GV*)POPPTR(ss,ix);
8675             TOPPTR(nss,ix) = gv_dup_inc(c);
8676             c = (char*)POPPTR(ss,ix);
8677             TOPPTR(nss,ix) = pv_dup(c);
8678             iv = POPIV(ss,ix);
8679             TOPIV(nss,ix) = iv;
8680             iv = POPIV(ss,ix);
8681             TOPIV(nss,ix) = iv;
8682             break;
8683         case SAVEt_FREESV:
8684         case SAVEt_MORTALIZESV:
8685             sv = (SV*)POPPTR(ss,ix);
8686             TOPPTR(nss,ix) = sv_dup_inc(sv);
8687             break;
8688         case SAVEt_FREEOP:
8689             ptr = POPPTR(ss,ix);
8690             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8691                 /* these are assumed to be refcounted properly */
8692                 switch (((OP*)ptr)->op_type) {
8693                 case OP_LEAVESUB:
8694                 case OP_LEAVESUBLV:
8695                 case OP_LEAVEEVAL:
8696                 case OP_LEAVE:
8697                 case OP_SCOPE:
8698                 case OP_LEAVEWRITE:
8699                     TOPPTR(nss,ix) = ptr;
8700                     o = (OP*)ptr;
8701                     OpREFCNT_inc(o);
8702                     break;
8703                 default:
8704                     TOPPTR(nss,ix) = Nullop;
8705                     break;
8706                 }
8707             }
8708             else
8709                 TOPPTR(nss,ix) = Nullop;
8710             break;
8711         case SAVEt_FREEPV:
8712             c = (char*)POPPTR(ss,ix);
8713             TOPPTR(nss,ix) = pv_dup_inc(c);
8714             break;
8715         case SAVEt_CLEARSV:
8716             longval = POPLONG(ss,ix);
8717             TOPLONG(nss,ix) = longval;
8718             break;
8719         case SAVEt_DELETE:
8720             hv = (HV*)POPPTR(ss,ix);
8721             TOPPTR(nss,ix) = hv_dup_inc(hv);
8722             c = (char*)POPPTR(ss,ix);
8723             TOPPTR(nss,ix) = pv_dup_inc(c);
8724             i = POPINT(ss,ix);
8725             TOPINT(nss,ix) = i;
8726             break;
8727         case SAVEt_DESTRUCTOR:
8728             ptr = POPPTR(ss,ix);
8729             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
8730             dptr = POPDPTR(ss,ix);
8731             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8732             break;
8733         case SAVEt_DESTRUCTOR_X:
8734             ptr = POPPTR(ss,ix);
8735             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
8736             dxptr = POPDXPTR(ss,ix);
8737             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8738             break;
8739         case SAVEt_REGCONTEXT:
8740         case SAVEt_ALLOC:
8741             i = POPINT(ss,ix);
8742             TOPINT(nss,ix) = i;
8743             ix -= i;
8744             break;
8745         case SAVEt_STACK_POS:           /* Position on Perl stack */
8746             i = POPINT(ss,ix);
8747             TOPINT(nss,ix) = i;
8748             break;
8749         case SAVEt_AELEM:               /* array element */
8750             sv = (SV*)POPPTR(ss,ix);
8751             TOPPTR(nss,ix) = sv_dup_inc(sv);
8752             i = POPINT(ss,ix);
8753             TOPINT(nss,ix) = i;
8754             av = (AV*)POPPTR(ss,ix);
8755             TOPPTR(nss,ix) = av_dup_inc(av);
8756             break;
8757         case SAVEt_HELEM:               /* hash element */
8758             sv = (SV*)POPPTR(ss,ix);
8759             TOPPTR(nss,ix) = sv_dup_inc(sv);
8760             sv = (SV*)POPPTR(ss,ix);
8761             TOPPTR(nss,ix) = sv_dup_inc(sv);
8762             hv = (HV*)POPPTR(ss,ix);
8763             TOPPTR(nss,ix) = hv_dup_inc(hv);
8764             break;
8765         case SAVEt_OP:
8766             ptr = POPPTR(ss,ix);
8767             TOPPTR(nss,ix) = ptr;
8768             break;
8769         case SAVEt_HINTS:
8770             i = POPINT(ss,ix);
8771             TOPINT(nss,ix) = i;
8772             break;
8773         case SAVEt_COMPPAD:
8774             av = (AV*)POPPTR(ss,ix);
8775             TOPPTR(nss,ix) = av_dup(av);
8776             break;
8777         case SAVEt_PADSV:
8778             longval = (long)POPLONG(ss,ix);
8779             TOPLONG(nss,ix) = longval;
8780             ptr = POPPTR(ss,ix);
8781             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8782             sv = (SV*)POPPTR(ss,ix);
8783             TOPPTR(nss,ix) = sv_dup(sv);
8784             break;
8785         default:
8786             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8787         }
8788     }
8789
8790     return nss;
8791 }
8792
8793 #ifdef PERL_OBJECT
8794 #include "XSUB.h"
8795 #endif
8796
8797 PerlInterpreter *
8798 perl_clone(PerlInterpreter *proto_perl, UV flags)
8799 {
8800 #ifdef PERL_OBJECT
8801     CPerlObj *pPerl = (CPerlObj*)proto_perl;
8802 #endif
8803
8804 #ifdef PERL_IMPLICIT_SYS
8805     return perl_clone_using(proto_perl, flags,
8806                             proto_perl->IMem,
8807                             proto_perl->IMemShared,
8808                             proto_perl->IMemParse,
8809                             proto_perl->IEnv,
8810                             proto_perl->IStdIO,
8811                             proto_perl->ILIO,
8812                             proto_perl->IDir,
8813                             proto_perl->ISock,
8814                             proto_perl->IProc);
8815 }
8816
8817 PerlInterpreter *
8818 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8819                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
8820                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8821                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8822                  struct IPerlDir* ipD, struct IPerlSock* ipS,
8823                  struct IPerlProc* ipP)
8824 {
8825     /* XXX many of the string copies here can be optimized if they're
8826      * constants; they need to be allocated as common memory and just
8827      * their pointers copied. */
8828
8829     IV i;
8830 #  ifdef PERL_OBJECT
8831     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8832                                         ipD, ipS, ipP);
8833     PERL_SET_THX(pPerl);
8834 #  else         /* !PERL_OBJECT */
8835     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8836     PERL_SET_THX(my_perl);
8837
8838 #    ifdef DEBUGGING
8839     memset(my_perl, 0xab, sizeof(PerlInterpreter));
8840     PL_markstack = 0;
8841     PL_scopestack = 0;
8842     PL_savestack = 0;
8843     PL_retstack = 0;
8844     PL_sig_pending = 0;
8845 #    else       /* !DEBUGGING */
8846     Zero(my_perl, 1, PerlInterpreter);
8847 #    endif      /* DEBUGGING */
8848
8849     /* host pointers */
8850     PL_Mem              = ipM;
8851     PL_MemShared        = ipMS;
8852     PL_MemParse         = ipMP;
8853     PL_Env              = ipE;
8854     PL_StdIO            = ipStd;
8855     PL_LIO              = ipLIO;
8856     PL_Dir              = ipD;
8857     PL_Sock             = ipS;
8858     PL_Proc             = ipP;
8859 #  endif        /* PERL_OBJECT */
8860 #else           /* !PERL_IMPLICIT_SYS */
8861     IV i;
8862     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8863     PERL_SET_THX(my_perl);
8864
8865 #    ifdef DEBUGGING
8866     memset(my_perl, 0xab, sizeof(PerlInterpreter));
8867     PL_markstack = 0;
8868     PL_scopestack = 0;
8869     PL_savestack = 0;
8870     PL_retstack = 0;
8871     PL_sig_pending = 0;
8872 #    else       /* !DEBUGGING */
8873     Zero(my_perl, 1, PerlInterpreter);
8874 #    endif      /* DEBUGGING */
8875 #endif          /* PERL_IMPLICIT_SYS */
8876
8877     /* arena roots */
8878     PL_xiv_arenaroot    = NULL;
8879     PL_xiv_root         = NULL;
8880     PL_xnv_arenaroot    = NULL;
8881     PL_xnv_root         = NULL;
8882     PL_xrv_arenaroot    = NULL;
8883     PL_xrv_root         = NULL;
8884     PL_xpv_arenaroot    = NULL;
8885     PL_xpv_root         = NULL;
8886     PL_xpviv_arenaroot  = NULL;
8887     PL_xpviv_root       = NULL;
8888     PL_xpvnv_arenaroot  = NULL;
8889     PL_xpvnv_root       = NULL;
8890     PL_xpvcv_arenaroot  = NULL;
8891     PL_xpvcv_root       = NULL;
8892     PL_xpvav_arenaroot  = NULL;
8893     PL_xpvav_root       = NULL;
8894     PL_xpvhv_arenaroot  = NULL;
8895     PL_xpvhv_root       = NULL;
8896     PL_xpvmg_arenaroot  = NULL;
8897     PL_xpvmg_root       = NULL;
8898     PL_xpvlv_arenaroot  = NULL;
8899     PL_xpvlv_root       = NULL;
8900     PL_xpvbm_arenaroot  = NULL;
8901     PL_xpvbm_root       = NULL;
8902     PL_he_arenaroot     = NULL;
8903     PL_he_root          = NULL;
8904     PL_nice_chunk       = NULL;
8905     PL_nice_chunk_size  = 0;
8906     PL_sv_count         = 0;
8907     PL_sv_objcount      = 0;
8908     PL_sv_root          = Nullsv;
8909     PL_sv_arenaroot     = Nullsv;
8910
8911     PL_debug            = proto_perl->Idebug;
8912
8913     /* create SV map for pointer relocation */
8914     PL_ptr_table = ptr_table_new();
8915
8916     /* initialize these special pointers as early as possible */
8917     SvANY(&PL_sv_undef)         = NULL;
8918     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
8919     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
8920     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8921
8922 #ifdef PERL_OBJECT
8923     SvUPGRADE(&PL_sv_no, SVt_PVNV);
8924 #else
8925     SvANY(&PL_sv_no)            = new_XPVNV();
8926 #endif
8927     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
8928     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8929     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
8930     SvCUR(&PL_sv_no)            = 0;
8931     SvLEN(&PL_sv_no)            = 1;
8932     SvNVX(&PL_sv_no)            = 0;
8933     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8934
8935 #ifdef PERL_OBJECT
8936     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8937 #else
8938     SvANY(&PL_sv_yes)           = new_XPVNV();
8939 #endif
8940     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
8941     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8942     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
8943     SvCUR(&PL_sv_yes)           = 1;
8944     SvLEN(&PL_sv_yes)           = 2;
8945     SvNVX(&PL_sv_yes)           = 1;
8946     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8947
8948     /* create shared string table */
8949     PL_strtab           = newHV();
8950     HvSHAREKEYS_off(PL_strtab);
8951     hv_ksplit(PL_strtab, 512);
8952     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8953
8954     PL_compiling                = proto_perl->Icompiling;
8955     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
8956     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
8957     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8958     if (!specialWARN(PL_compiling.cop_warnings))
8959         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8960     if (!specialCopIO(PL_compiling.cop_io))
8961         PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8962     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8963
8964     /* pseudo environmental stuff */
8965     PL_origargc         = proto_perl->Iorigargc;
8966     i = PL_origargc;
8967     New(0, PL_origargv, i+1, char*);
8968     PL_origargv[i] = '\0';
8969     while (i-- > 0) {
8970         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
8971     }
8972     PL_envgv            = gv_dup(proto_perl->Ienvgv);
8973     PL_incgv            = gv_dup(proto_perl->Iincgv);
8974     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
8975     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
8976     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
8977     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
8978
8979     /* switches */
8980     PL_minus_c          = proto_perl->Iminus_c;
8981     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
8982     PL_localpatches     = proto_perl->Ilocalpatches;
8983     PL_splitstr         = proto_perl->Isplitstr;
8984     PL_preprocess       = proto_perl->Ipreprocess;
8985     PL_minus_n          = proto_perl->Iminus_n;
8986     PL_minus_p          = proto_perl->Iminus_p;
8987     PL_minus_l          = proto_perl->Iminus_l;
8988     PL_minus_a          = proto_perl->Iminus_a;
8989     PL_minus_F          = proto_perl->Iminus_F;
8990     PL_doswitches       = proto_perl->Idoswitches;
8991     PL_dowarn           = proto_perl->Idowarn;
8992     PL_doextract        = proto_perl->Idoextract;
8993     PL_sawampersand     = proto_perl->Isawampersand;
8994     PL_unsafe           = proto_perl->Iunsafe;
8995     PL_inplace          = SAVEPV(proto_perl->Iinplace);
8996     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
8997     PL_perldb           = proto_perl->Iperldb;
8998     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8999
9000     /* magical thingies */
9001     /* XXX time(&PL_basetime) when asked for? */
9002     PL_basetime         = proto_perl->Ibasetime;
9003     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
9004
9005     PL_maxsysfd         = proto_perl->Imaxsysfd;
9006     PL_multiline        = proto_perl->Imultiline;
9007     PL_statusvalue      = proto_perl->Istatusvalue;
9008 #ifdef VMS
9009     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
9010 #endif
9011
9012     /* shortcuts to various I/O objects */
9013     PL_stdingv          = gv_dup(proto_perl->Istdingv);
9014     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
9015     PL_defgv            = gv_dup(proto_perl->Idefgv);
9016     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
9017     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
9018     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack);
9019
9020     /* shortcuts to regexp stuff */
9021     PL_replgv           = gv_dup(proto_perl->Ireplgv);
9022
9023     /* shortcuts to misc objects */
9024     PL_errgv            = gv_dup(proto_perl->Ierrgv);
9025
9026     /* shortcuts to debugging objects */
9027     PL_DBgv             = gv_dup(proto_perl->IDBgv);
9028     PL_DBline           = gv_dup(proto_perl->IDBline);
9029     PL_DBsub            = gv_dup(proto_perl->IDBsub);
9030     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
9031     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
9032     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
9033     PL_lineary          = av_dup(proto_perl->Ilineary);
9034     PL_dbargs           = av_dup(proto_perl->Idbargs);
9035
9036     /* symbol tables */
9037     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
9038     PL_curstash         = hv_dup(proto_perl->Tcurstash);
9039     PL_debstash         = hv_dup(proto_perl->Idebstash);
9040     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
9041     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
9042
9043     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
9044     PL_endav            = av_dup_inc(proto_perl->Iendav);
9045     PL_checkav          = av_dup_inc(proto_perl->Icheckav);
9046     PL_initav           = av_dup_inc(proto_perl->Iinitav);
9047
9048     PL_sub_generation   = proto_perl->Isub_generation;
9049
9050     /* funky return mechanisms */
9051     PL_forkprocess      = proto_perl->Iforkprocess;
9052
9053     /* subprocess state */
9054     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
9055
9056     /* internal state */
9057     PL_tainting         = proto_perl->Itainting;
9058     PL_maxo             = proto_perl->Imaxo;
9059     if (proto_perl->Iop_mask)
9060         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9061     else
9062         PL_op_mask      = Nullch;
9063
9064     /* current interpreter roots */
9065     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
9066     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
9067     PL_main_start       = proto_perl->Imain_start;
9068     PL_eval_root        = proto_perl->Ieval_root;
9069     PL_eval_start       = proto_perl->Ieval_start;
9070
9071     /* runtime control stuff */
9072     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9073     PL_copline          = proto_perl->Icopline;
9074
9075     PL_filemode         = proto_perl->Ifilemode;
9076     PL_lastfd           = proto_perl->Ilastfd;
9077     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
9078     PL_Argv             = NULL;
9079     PL_Cmd              = Nullch;
9080     PL_gensym           = proto_perl->Igensym;
9081     PL_preambled        = proto_perl->Ipreambled;
9082     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
9083     PL_laststatval      = proto_perl->Ilaststatval;
9084     PL_laststype        = proto_perl->Ilaststype;
9085     PL_mess_sv          = Nullsv;
9086
9087     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv);
9088     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
9089
9090     /* interpreter atexit processing */
9091     PL_exitlistlen      = proto_perl->Iexitlistlen;
9092     if (PL_exitlistlen) {
9093         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9094         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9095     }
9096     else
9097         PL_exitlist     = (PerlExitListEntry*)NULL;
9098     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
9099
9100     PL_profiledata      = NULL;
9101     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
9102     /* PL_rsfp_filters entries have fake IoDIRP() */
9103     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
9104
9105     PL_compcv                   = cv_dup(proto_perl->Icompcv);
9106     PL_comppad                  = av_dup(proto_perl->Icomppad);
9107     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
9108     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
9109     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
9110     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
9111                                                         proto_perl->Tcurpad);
9112
9113 #ifdef HAVE_INTERP_INTERN
9114     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9115 #endif
9116
9117     /* more statics moved here */
9118     PL_generation       = proto_perl->Igeneration;
9119     PL_DBcv             = cv_dup(proto_perl->IDBcv);
9120
9121     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
9122     PL_in_clean_all     = proto_perl->Iin_clean_all;
9123
9124     PL_uid              = proto_perl->Iuid;
9125     PL_euid             = proto_perl->Ieuid;
9126     PL_gid              = proto_perl->Igid;
9127     PL_egid             = proto_perl->Iegid;
9128     PL_nomemok          = proto_perl->Inomemok;
9129     PL_an               = proto_perl->Ian;
9130     PL_cop_seqmax       = proto_perl->Icop_seqmax;
9131     PL_op_seqmax        = proto_perl->Iop_seqmax;
9132     PL_evalseq          = proto_perl->Ievalseq;
9133     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
9134     PL_origalen         = proto_perl->Iorigalen;
9135     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
9136     PL_osname           = SAVEPV(proto_perl->Iosname);
9137     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
9138     PL_sighandlerp      = proto_perl->Isighandlerp;
9139
9140
9141     PL_runops           = proto_perl->Irunops;
9142
9143     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9144
9145 #ifdef CSH
9146     PL_cshlen           = proto_perl->Icshlen;
9147     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9148 #endif
9149
9150     PL_lex_state        = proto_perl->Ilex_state;
9151     PL_lex_defer        = proto_perl->Ilex_defer;
9152     PL_lex_expect       = proto_perl->Ilex_expect;
9153     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
9154     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
9155     PL_lex_starts       = proto_perl->Ilex_starts;
9156     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
9157     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
9158     PL_lex_op           = proto_perl->Ilex_op;
9159     PL_lex_inpat        = proto_perl->Ilex_inpat;
9160     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
9161     PL_lex_brackets     = proto_perl->Ilex_brackets;
9162     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9163     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
9164     PL_lex_casemods     = proto_perl->Ilex_casemods;
9165     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9166     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
9167
9168     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9169     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9170     PL_nexttoke         = proto_perl->Inexttoke;
9171
9172     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
9173     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9174     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9175     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9176     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9177     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9178     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9179     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9180     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9181     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9182     PL_pending_ident    = proto_perl->Ipending_ident;
9183     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
9184
9185     PL_expect           = proto_perl->Iexpect;
9186
9187     PL_multi_start      = proto_perl->Imulti_start;
9188     PL_multi_end        = proto_perl->Imulti_end;
9189     PL_multi_open       = proto_perl->Imulti_open;
9190     PL_multi_close      = proto_perl->Imulti_close;
9191
9192     PL_error_count      = proto_perl->Ierror_count;
9193     PL_subline          = proto_perl->Isubline;
9194     PL_subname          = sv_dup_inc(proto_perl->Isubname);
9195
9196     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
9197     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
9198     PL_padix                    = proto_perl->Ipadix;
9199     PL_padix_floor              = proto_perl->Ipadix_floor;
9200     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
9201
9202     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9203     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9204     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9205     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9206     PL_last_lop_op      = proto_perl->Ilast_lop_op;
9207     PL_in_my            = proto_perl->Iin_my;
9208     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
9209 #ifdef FCRYPT
9210     PL_cryptseen        = proto_perl->Icryptseen;
9211 #endif
9212
9213     PL_hints            = proto_perl->Ihints;
9214
9215     PL_amagic_generation        = proto_perl->Iamagic_generation;
9216
9217 #ifdef USE_LOCALE_COLLATE
9218     PL_collation_ix     = proto_perl->Icollation_ix;
9219     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
9220     PL_collation_standard       = proto_perl->Icollation_standard;
9221     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
9222     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
9223 #endif /* USE_LOCALE_COLLATE */
9224
9225 #ifdef USE_LOCALE_NUMERIC
9226     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
9227     PL_numeric_standard = proto_perl->Inumeric_standard;
9228     PL_numeric_local    = proto_perl->Inumeric_local;
9229     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
9230 #endif /* !USE_LOCALE_NUMERIC */
9231
9232     /* utf8 character classes */
9233     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
9234     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
9235     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
9236     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
9237     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
9238     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
9239     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
9240     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
9241     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
9242     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
9243     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
9244     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
9245     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
9246     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
9247     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
9248     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
9249     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
9250
9251     /* swatch cache */
9252     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
9253     PL_last_swash_klen  = 0;
9254     PL_last_swash_key[0]= '\0';
9255     PL_last_swash_tmps  = (U8*)NULL;
9256     PL_last_swash_slen  = 0;
9257
9258     /* perly.c globals */
9259     PL_yydebug          = proto_perl->Iyydebug;
9260     PL_yynerrs          = proto_perl->Iyynerrs;
9261     PL_yyerrflag        = proto_perl->Iyyerrflag;
9262     PL_yychar           = proto_perl->Iyychar;
9263     PL_yyval            = proto_perl->Iyyval;
9264     PL_yylval           = proto_perl->Iyylval;
9265
9266     PL_glob_index       = proto_perl->Iglob_index;
9267     PL_srand_called     = proto_perl->Isrand_called;
9268     PL_uudmap['M']      = 0;            /* reinits on demand */
9269     PL_bitcount         = Nullch;       /* reinits on demand */
9270
9271     if (proto_perl->Ipsig_pend) {
9272         Newz(0, PL_psig_pend, SIG_SIZE, int);
9273     }
9274     else {
9275         PL_psig_pend    = (int*)NULL;
9276     }
9277
9278     if (proto_perl->Ipsig_ptr) {
9279         Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
9280         Newz(0, PL_psig_name, SIG_SIZE, SV*);
9281         for (i = 1; i < SIG_SIZE; i++) {
9282             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9283             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9284         }
9285     }
9286     else {
9287         PL_psig_ptr     = (SV**)NULL;
9288         PL_psig_name    = (SV**)NULL;
9289     }
9290
9291     /* thrdvar.h stuff */
9292
9293     if (flags & CLONEf_COPY_STACKS) {
9294         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9295         PL_tmps_ix              = proto_perl->Ttmps_ix;
9296         PL_tmps_max             = proto_perl->Ttmps_max;
9297         PL_tmps_floor           = proto_perl->Ttmps_floor;
9298         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9299         i = 0;
9300         while (i <= PL_tmps_ix) {
9301             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9302             ++i;
9303         }
9304
9305         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9306         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9307         Newz(54, PL_markstack, i, I32);
9308         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
9309                                                   - proto_perl->Tmarkstack);
9310         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
9311                                                   - proto_perl->Tmarkstack);
9312         Copy(proto_perl->Tmarkstack, PL_markstack,
9313              PL_markstack_ptr - PL_markstack + 1, I32);
9314
9315         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9316          * NOTE: unlike the others! */
9317         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
9318         PL_scopestack_max       = proto_perl->Tscopestack_max;
9319         Newz(54, PL_scopestack, PL_scopestack_max, I32);
9320         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9321
9322         /* next push_return() sets PL_retstack[PL_retstack_ix]
9323          * NOTE: unlike the others! */
9324         PL_retstack_ix          = proto_perl->Tretstack_ix;
9325         PL_retstack_max         = proto_perl->Tretstack_max;
9326         Newz(54, PL_retstack, PL_retstack_max, OP*);
9327         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9328
9329         /* NOTE: si_dup() looks at PL_markstack */
9330         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
9331
9332         /* PL_curstack          = PL_curstackinfo->si_stack; */
9333         PL_curstack             = av_dup(proto_perl->Tcurstack);
9334         PL_mainstack            = av_dup(proto_perl->Tmainstack);
9335
9336         /* next PUSHs() etc. set *(PL_stack_sp+1) */
9337         PL_stack_base           = AvARRAY(PL_curstack);
9338         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
9339                                                    - proto_perl->Tstack_base);
9340         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
9341
9342         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9343          * NOTE: unlike the others! */
9344         PL_savestack_ix         = proto_perl->Tsavestack_ix;
9345         PL_savestack_max        = proto_perl->Tsavestack_max;
9346         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9347         PL_savestack            = ss_dup(proto_perl);
9348     }
9349     else {
9350         init_stacks();
9351         ENTER;                  /* perl_destruct() wants to LEAVE; */
9352     }
9353
9354     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
9355     PL_top_env          = &PL_start_env;
9356
9357     PL_op               = proto_perl->Top;
9358
9359     PL_Sv               = Nullsv;
9360     PL_Xpv              = (XPV*)NULL;
9361     PL_na               = proto_perl->Tna;
9362
9363     PL_statbuf          = proto_perl->Tstatbuf;
9364     PL_statcache        = proto_perl->Tstatcache;
9365     PL_statgv           = gv_dup(proto_perl->Tstatgv);
9366     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
9367 #ifdef HAS_TIMES
9368     PL_timesbuf         = proto_perl->Ttimesbuf;
9369 #endif
9370
9371     PL_tainted          = proto_perl->Ttainted;
9372     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
9373     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
9374     PL_rs               = sv_dup_inc(proto_perl->Trs);
9375     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
9376     PL_ofs_sv           = sv_dup_inc(proto_perl->Tofs_sv);
9377     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
9378     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
9379     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
9380     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
9381     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
9382
9383     PL_restartop        = proto_perl->Trestartop;
9384     PL_in_eval          = proto_perl->Tin_eval;
9385     PL_delaymagic       = proto_perl->Tdelaymagic;
9386     PL_dirty            = proto_perl->Tdirty;
9387     PL_localizing       = proto_perl->Tlocalizing;
9388
9389 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9390     PL_protect          = proto_perl->Tprotect;
9391 #endif
9392     PL_errors           = sv_dup_inc(proto_perl->Terrors);
9393     PL_av_fetch_sv      = Nullsv;
9394     PL_hv_fetch_sv      = Nullsv;
9395     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
9396     PL_modcount         = proto_perl->Tmodcount;
9397     PL_lastgotoprobe    = Nullop;
9398     PL_dumpindent       = proto_perl->Tdumpindent;
9399
9400     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9401     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
9402     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
9403     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
9404     PL_sortcxix         = proto_perl->Tsortcxix;
9405     PL_efloatbuf        = Nullch;               /* reinits on demand */
9406     PL_efloatsize       = 0;                    /* reinits on demand */
9407
9408     /* regex stuff */
9409
9410     PL_screamfirst      = NULL;
9411     PL_screamnext       = NULL;
9412     PL_maxscream        = -1;                   /* reinits on demand */
9413     PL_lastscream       = Nullsv;
9414
9415     PL_watchaddr        = NULL;
9416     PL_watchok          = Nullch;
9417
9418     PL_regdummy         = proto_perl->Tregdummy;
9419     PL_regcomp_parse    = Nullch;
9420     PL_regxend          = Nullch;
9421     PL_regcode          = (regnode*)NULL;
9422     PL_regnaughty       = 0;
9423     PL_regsawback       = 0;
9424     PL_regprecomp       = Nullch;
9425     PL_regnpar          = 0;
9426     PL_regsize          = 0;
9427     PL_regflags         = 0;
9428     PL_regseen          = 0;
9429     PL_seen_zerolen     = 0;
9430     PL_seen_evals       = 0;
9431     PL_regcomp_rx       = (regexp*)NULL;
9432     PL_extralen         = 0;
9433     PL_colorset         = 0;            /* reinits PL_colors[] */
9434     /*PL_colors[6]      = {0,0,0,0,0,0};*/
9435     PL_reg_whilem_seen  = 0;
9436     PL_reginput         = Nullch;
9437     PL_regbol           = Nullch;
9438     PL_regeol           = Nullch;
9439     PL_regstartp        = (I32*)NULL;
9440     PL_regendp          = (I32*)NULL;
9441     PL_reglastparen     = (U32*)NULL;
9442     PL_regtill          = Nullch;
9443     PL_reg_start_tmp    = (char**)NULL;
9444     PL_reg_start_tmpl   = 0;
9445     PL_regdata          = (struct reg_data*)NULL;
9446     PL_bostr            = Nullch;
9447     PL_reg_flags        = 0;
9448     PL_reg_eval_set     = 0;
9449     PL_regnarrate       = 0;
9450     PL_regprogram       = (regnode*)NULL;
9451     PL_regindent        = 0;
9452     PL_regcc            = (CURCUR*)NULL;
9453     PL_reg_call_cc      = (struct re_cc_state*)NULL;
9454     PL_reg_re           = (regexp*)NULL;
9455     PL_reg_ganch        = Nullch;
9456     PL_reg_sv           = Nullsv;
9457     PL_reg_magic        = (MAGIC*)NULL;
9458     PL_reg_oldpos       = 0;
9459     PL_reg_oldcurpm     = (PMOP*)NULL;
9460     PL_reg_curpm        = (PMOP*)NULL;
9461     PL_reg_oldsaved     = Nullch;
9462     PL_reg_oldsavedlen  = 0;
9463     PL_reg_maxiter      = 0;
9464     PL_reg_leftiter     = 0;
9465     PL_reg_poscache     = Nullch;
9466     PL_reg_poscache_size= 0;
9467
9468     /* RE engine - function pointers */
9469     PL_regcompp         = proto_perl->Tregcompp;
9470     PL_regexecp         = proto_perl->Tregexecp;
9471     PL_regint_start     = proto_perl->Tregint_start;
9472     PL_regint_string    = proto_perl->Tregint_string;
9473     PL_regfree          = proto_perl->Tregfree;
9474
9475     PL_reginterp_cnt    = 0;
9476     PL_reg_starttry     = 0;
9477
9478     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9479         ptr_table_free(PL_ptr_table);
9480         PL_ptr_table = NULL;
9481     }
9482
9483 #ifdef PERL_OBJECT
9484     return (PerlInterpreter*)pPerl;
9485 #else
9486     return my_perl;
9487 #endif
9488 }
9489
9490 #else   /* !USE_ITHREADS */
9491
9492 #ifdef PERL_OBJECT
9493 #include "XSUB.h"
9494 #endif
9495
9496 #endif /* USE_ITHREADS */
9497
9498 static void
9499 do_report_used(pTHXo_ SV *sv)
9500 {
9501     if (SvTYPE(sv) != SVTYPEMASK) {
9502         PerlIO_printf(Perl_debug_log, "****\n");
9503         sv_dump(sv);
9504     }
9505 }
9506
9507 static void
9508 do_clean_objs(pTHXo_ SV *sv)
9509 {
9510     SV* rv;
9511
9512     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9513         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
9514         if (SvWEAKREF(sv)) {
9515             sv_del_backref(sv);
9516             SvWEAKREF_off(sv);
9517             SvRV(sv) = 0;
9518         } else {
9519             SvROK_off(sv);
9520             SvRV(sv) = 0;
9521             SvREFCNT_dec(rv);
9522         }
9523     }
9524
9525     /* XXX Might want to check arrays, etc. */
9526 }
9527
9528 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9529 static void
9530 do_clean_named_objs(pTHXo_ SV *sv)
9531 {
9532     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9533         if ( SvOBJECT(GvSV(sv)) ||
9534              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9535              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9536              (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9537              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9538         {
9539             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
9540             SvREFCNT_dec(sv);
9541         }
9542     }
9543 }
9544 #endif
9545
9546 static void
9547 do_clean_all(pTHXo_ SV *sv)
9548 {
9549     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
9550     SvFLAGS(sv) |= SVf_BREAK;
9551     SvREFCNT_dec(sv);
9552 }
9553