sv.c

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