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