sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (c) 1991-1999, 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 #ifdef PURIFY
  30
  31 #define new_SV(p) \
  32     STMT_START {                                        \
  33         LOCK_SV_MUTEX;                                  \
  34         (p) = (SV*)safemalloc(sizeof(SV));              \
  35         reg_add(p);                                     \
  36         UNLOCK_SV_MUTEX;                                \
  37         SvANY(p) = 0;                                   \
  38         SvREFCNT(p) = 1;                                \
  39         SvFLAGS(p) = 0;                                 \
  40     } STMT_END
  41
  42 #define del_SV(p) \
  43     STMT_START {                                        \
  44         LOCK_SV_MUTEX;                                  \
  45         reg_remove(p);                                  \
  46         Safefree((char*)(p));                           \
  47         UNLOCK_SV_MUTEX;                                \
  48     } STMT_END
  49
  50 static SV **registry;
  51 static I32 registry_size;
  52
  53 #define REGHASH(sv,size)  ((((U32)(sv)) >> 2) % (size))
  54
  55 #define REG_REPLACE(sv,a,b) \
  56     STMT_START {                                        \
  57         void* p = sv->sv_any;                           \
  58         I32 h = REGHASH(sv, registry_size);             \
  59         I32 i = h;                                      \
  60         while (registry[i] != (a)) {                    \
  61             if (++i >= registry_size)                   \
  62                 i = 0;                                  \
  63             if (i == h)                                 \
  64                 Perl_die(aTHX_ "SV registry bug");                      \
  65         }                                               \
  66         registry[i] = (b);                              \
  67     } STMT_END
  68
  69 #define REG_ADD(sv)     REG_REPLACE(sv,Nullsv,sv)
  70 #define REG_REMOVE(sv)  REG_REPLACE(sv,sv,Nullsv)
  71
  72 STATIC void
  73 S_reg_add(pTHX_ SV *sv)
  74 {
  75     if (PL_sv_count >= (registry_size >> 1))
  76     {
  77         SV **oldreg = registry;
  78         I32 oldsize = registry_size;
  79
  80         registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
  81         Newz(707, registry, registry_size, SV*);
  82
  83         if (oldreg) {
  84             I32 i;
  85
  86             for (i = 0; i < oldsize; ++i) {
  87                 SV* oldsv = oldreg[i];
  88                 if (oldsv)
  89                     REG_ADD(oldsv);
  90             }
  91             Safefree(oldreg);
  92         }
  93     }
  94
  95     REG_ADD(sv);
  96     ++PL_sv_count;
  97 }
  98
  99 STATIC void
 100 S_reg_remove(pTHX_ SV *sv)
 101 {
 102     REG_REMOVE(sv);
 103     --PL_sv_count;
 104 }
 105
 106 STATIC void
 107 S_visit(pTHX_ SVFUNC_t f)
 108 {
 109     I32 i;
 110
 111     for (i = 0; i < registry_size; ++i) {
 112         SV* sv = registry[i];
 113         if (sv && SvTYPE(sv) != SVTYPEMASK)
 114             (*f)(sv);
 115     }
 116 }
 117
 118 void
 119 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
 120 {
 121     if (!(flags & SVf_FAKE))
 122         Safefree(ptr);
 123 }
 124
 125 #else /* ! PURIFY */
 126
 127 /*
 128  * "A time to plant, and a time to uproot what was planted..."
 129  */
 130
 131 #define plant_SV(p) \
 132     STMT_START {                                        \
 133         SvANY(p) = (void *)PL_sv_root;                  \
 134         SvFLAGS(p) = SVTYPEMASK;                        \
 135         PL_sv_root = (p);                               \
 136         --PL_sv_count;                                  \
 137     } STMT_END
 138
 139 /* sv_mutex must be held while calling uproot_SV() */
 140 #define uproot_SV(p) \
 141     STMT_START {                                        \
 142         (p) = PL_sv_root;                               \
 143         PL_sv_root = (SV*)SvANY(p);                     \
 144         ++PL_sv_count;                                  \
 145     } STMT_END
 146
 147 #define new_SV(p) \
 148     STMT_START {                                        \
 149         LOCK_SV_MUTEX;                                  \
 150         if (PL_sv_root)                                 \
 151             uproot_SV(p);                               \
 152         else                                            \
 153             (p) = more_sv();                            \
 154         UNLOCK_SV_MUTEX;                                \
 155         SvANY(p) = 0;                                   \
 156         SvREFCNT(p) = 1;                                \
 157         SvFLAGS(p) = 0;                                 \
 158     } STMT_END
 159
 160 #ifdef DEBUGGING
 161
 162 #define del_SV(p) \
 163     STMT_START {                                        \
 164         LOCK_SV_MUTEX;                                  \
 165         if (PL_debug & 32768)                           \
 166             del_sv(p);                                  \
 167         else                                            \
 168             plant_SV(p);                                \
 169         UNLOCK_SV_MUTEX;                                \
 170     } STMT_END
 171
 172 STATIC void
 173 S_del_sv(pTHX_ SV *p)
 174 {
 175     if (PL_debug & 32768) {
 176         SV* sva;
 177         SV* sv;
 178         SV* svend;
 179         int ok = 0;
 180         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
 181             sv = sva + 1;
 182             svend = &sva[SvREFCNT(sva)];
 183             if (p >= sv && p < svend)
 184                 ok = 1;
 185         }
 186         if (!ok) {
 187             if (ckWARN_d(WARN_INTERNAL))
 188                 Perl_warner(aTHX_ WARN_INTERNAL,
 189                             "Attempt to free non-arena SV: 0x%"UVxf,
 190                             PTR2UV(p));
 191             return;
 192         }
 193     }
 194     plant_SV(p);
 195 }
 196
 197 #else /* ! DEBUGGING */
 198
 199 #define del_SV(p)   plant_SV(p)
 200
 201 #endif /* DEBUGGING */
 202
 203 void
 204 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
 205 {
 206     SV* sva = (SV*)ptr;
 207     register SV* sv;
 208     register SV* svend;
 209     Zero(sva, size, char);
 210
 211     /* The first SV in an arena isn't an SV. */
 212     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 213     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 214     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 215
 216     PL_sv_arenaroot = sva;
 217     PL_sv_root = sva + 1;
 218
 219     svend = &sva[SvREFCNT(sva) - 1];
 220     sv = sva + 1;
 221     while (sv < svend) {
 222         SvANY(sv) = (void *)(SV*)(sv + 1);
 223         SvFLAGS(sv) = SVTYPEMASK;
 224         sv++;
 225     }
 226     SvANY(sv) = 0;
 227     SvFLAGS(sv) = SVTYPEMASK;
 228 }
 229
 230 /* sv_mutex must be held while calling more_sv() */
 231 STATIC SV*
 232 S_more_sv(pTHX)
 233 {
 234     register SV* sv;
 235
 236     if (PL_nice_chunk) {
 237         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 238         PL_nice_chunk = Nullch;
 239     }
 240     else {
 241         char *chunk;                /* must use New here to match call to */
 242         New(704,chunk,1008,char);   /* Safefree() in sv_free_arenas()     */
 243         sv_add_arena(chunk, 1008, 0);
 244     }
 245     uproot_SV(sv);
 246     return sv;
 247 }
 248
 249 STATIC void
 250 S_visit(pTHX_ SVFUNC_t f)
 251 {
 252     SV* sva;
 253     SV* sv;
 254     register SV* svend;
 255
 256     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 257         svend = &sva[SvREFCNT(sva)];
 258         for (sv = sva + 1; sv < svend; ++sv) {
 259             if (SvTYPE(sv) != SVTYPEMASK)
 260                 (FCALL)(aTHXo_ sv);
 261         }
 262     }
 263 }
 264
 265 #endif /* PURIFY */
 266
 267 void
 268 Perl_sv_report_used(pTHX)
 269 {
 270     visit(do_report_used);
 271 }
 272
 273 void
 274 Perl_sv_clean_objs(pTHX)
 275 {
 276     PL_in_clean_objs = TRUE;
 277     visit(do_clean_objs);
 278 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 279     /* some barnacles may yet remain, clinging to typeglobs */
 280     visit(do_clean_named_objs);
 281 #endif
 282     PL_in_clean_objs = FALSE;
 283 }
 284
 285 void
 286 Perl_sv_clean_all(pTHX)
 287 {
 288     PL_in_clean_all = TRUE;
 289     visit(do_clean_all);
 290     PL_in_clean_all = FALSE;
 291 }
 292
 293 void
 294 Perl_sv_free_arenas(pTHX)
 295 {
 296     SV* sva;
 297     SV* svanext;
 298
 299     /* Free arenas here, but be careful about fake ones.  (We assume
 300        contiguity of the fake ones with the corresponding real ones.) */
 301
 302     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 303         svanext = (SV*) SvANY(sva);
 304         while (svanext && SvFAKE(svanext))
 305             svanext = (SV*) SvANY(svanext);
 306
 307         if (!SvFAKE(sva))
 308             Safefree((void *)sva);
 309     }
 310
 311     if (PL_nice_chunk)
 312         Safefree(PL_nice_chunk);
 313     PL_nice_chunk = Nullch;
 314     PL_nice_chunk_size = 0;
 315     PL_sv_arenaroot = 0;
 316     PL_sv_root = 0;
 317 }
 318
 319 void
 320 Perl_report_uninit(pTHX)
 321 {
 322     if (PL_op)
 323         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
 324                     " in ", PL_op_desc[PL_op->op_type]);
 325     else
 326         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
 327 }
 328
 329 STATIC XPVIV*
 330 S_new_xiv(pTHX)
 331 {
 332     IV* xiv;
 333     LOCK_SV_MUTEX;
 334     if (!PL_xiv_root)
 335         more_xiv();
 336     xiv = PL_xiv_root;
 337     /*
 338      * See comment in more_xiv() -- RAM.
 339      */
 340     PL_xiv_root = *(IV**)xiv;
 341     UNLOCK_SV_MUTEX;
 342     return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
 343 }
 344
 345 STATIC void
 346 S_del_xiv(pTHX_ XPVIV *p)
 347 {
 348     IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
 349     LOCK_SV_MUTEX;
 350     *(IV**)xiv = PL_xiv_root;
 351     PL_xiv_root = xiv;
 352     UNLOCK_SV_MUTEX;
 353 }
 354
 355 STATIC void
 356 S_more_xiv(pTHX)
 357 {
 358     register IV* xiv;
 359     register IV* xivend;
 360     XPV* ptr;
 361     New(705, ptr, 1008/sizeof(XPV), XPV);
 362     ptr->xpv_pv = (char*)PL_xiv_arenaroot;              /* linked list of xiv arenas */
 363     PL_xiv_arenaroot = ptr;                     /* to keep Purify happy */
 364
 365     xiv = (IV*) ptr;
 366     xivend = &xiv[1008 / sizeof(IV) - 1];
 367     xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1;   /* fudge by size of XPV */
 368     PL_xiv_root = xiv;
 369     while (xiv < xivend) {
 370         *(IV**)xiv = (IV *)(xiv + 1);
 371         xiv++;
 372     }
 373     *(IV**)xiv = 0;
 374 }
 375
 376 STATIC XPVNV*
 377 S_new_xnv(pTHX)
 378 {
 379     NV* xnv;
 380     LOCK_SV_MUTEX;
 381     if (!PL_xnv_root)
 382         more_xnv();
 383     xnv = PL_xnv_root;
 384     PL_xnv_root = *(NV**)xnv;
 385     UNLOCK_SV_MUTEX;
 386     return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
 387 }
 388
 389 STATIC void
 390 S_del_xnv(pTHX_ XPVNV *p)
 391 {
 392     NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
 393     LOCK_SV_MUTEX;
 394     *(NV**)xnv = PL_xnv_root;
 395     PL_xnv_root = xnv;
 396     UNLOCK_SV_MUTEX;
 397 }
 398
 399 STATIC void
 400 S_more_xnv(pTHX)
 401 {
 402     register NV* xnv;
 403     register NV* xnvend;
 404     New(711, xnv, 1008/sizeof(NV), NV);
 405     xnvend = &xnv[1008 / sizeof(NV) - 1];
 406     xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
 407     PL_xnv_root = xnv;
 408     while (xnv < xnvend) {
 409         *(NV**)xnv = (NV*)(xnv + 1);
 410         xnv++;
 411     }
 412     *(NV**)xnv = 0;
 413 }
 414
 415 STATIC XRV*
 416 S_new_xrv(pTHX)
 417 {
 418     XRV* xrv;
 419     LOCK_SV_MUTEX;
 420     if (!PL_xrv_root)
 421         more_xrv();
 422     xrv = PL_xrv_root;
 423     PL_xrv_root = (XRV*)xrv->xrv_rv;
 424     UNLOCK_SV_MUTEX;
 425     return xrv;
 426 }
 427
 428 STATIC void
 429 S_del_xrv(pTHX_ XRV *p)
 430 {
 431     LOCK_SV_MUTEX;
 432     p->xrv_rv = (SV*)PL_xrv_root;
 433     PL_xrv_root = p;
 434     UNLOCK_SV_MUTEX;
 435 }
 436
 437 STATIC void
 438 S_more_xrv(pTHX)
 439 {
 440     register XRV* xrv;
 441     register XRV* xrvend;
 442     New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
 443     xrv = PL_xrv_root;
 444     xrvend = &xrv[1008 / sizeof(XRV) - 1];
 445     while (xrv < xrvend) {
 446         xrv->xrv_rv = (SV*)(xrv + 1);
 447         xrv++;
 448     }
 449     xrv->xrv_rv = 0;
 450 }
 451
 452 STATIC XPV*
 453 S_new_xpv(pTHX)
 454 {
 455     XPV* xpv;
 456     LOCK_SV_MUTEX;
 457     if (!PL_xpv_root)
 458         more_xpv();
 459     xpv = PL_xpv_root;
 460     PL_xpv_root = (XPV*)xpv->xpv_pv;
 461     UNLOCK_SV_MUTEX;
 462     return xpv;
 463 }
 464
 465 STATIC void
 466 S_del_xpv(pTHX_ XPV *p)
 467 {
 468     LOCK_SV_MUTEX;
 469     p->xpv_pv = (char*)PL_xpv_root;
 470     PL_xpv_root = p;
 471     UNLOCK_SV_MUTEX;
 472 }
 473
 474 STATIC void
 475 S_more_xpv(pTHX)
 476 {
 477     register XPV* xpv;
 478     register XPV* xpvend;
 479     New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
 480     xpv = PL_xpv_root;
 481     xpvend = &xpv[1008 / sizeof(XPV) - 1];
 482     while (xpv < xpvend) {
 483         xpv->xpv_pv = (char*)(xpv + 1);
 484         xpv++;
 485     }
 486     xpv->xpv_pv = 0;
 487 }
 488
 489 STATIC XPVIV*
 490 S_new_xpviv(pTHX)
 491 {
 492     XPVIV* xpviv;
 493     LOCK_SV_MUTEX;
 494     if (!PL_xpviv_root)
 495         more_xpviv();
 496     xpviv = PL_xpviv_root;
 497     PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
 498     UNLOCK_SV_MUTEX;
 499     return xpviv;
 500 }
 501
 502 STATIC void
 503 S_del_xpviv(pTHX_ XPVIV *p)
 504 {
 505     LOCK_SV_MUTEX;
 506     p->xpv_pv = (char*)PL_xpviv_root;
 507     PL_xpviv_root = p;
 508     UNLOCK_SV_MUTEX;
 509 }
 510
 511
 512 STATIC void
 513 S_more_xpviv(pTHX)
 514 {
 515     register XPVIV* xpviv;
 516     register XPVIV* xpvivend;
 517     New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
 518     xpviv = PL_xpviv_root;
 519     xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
 520     while (xpviv < xpvivend) {
 521         xpviv->xpv_pv = (char*)(xpviv + 1);
 522         xpviv++;
 523     }
 524     xpviv->xpv_pv = 0;
 525 }
 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
 551 STATIC void
 552 S_more_xpvnv(pTHX)
 553 {
 554     register XPVNV* xpvnv;
 555     register XPVNV* xpvnvend;
 556     New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
 557     xpvnv = PL_xpvnv_root;
 558     xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
 559     while (xpvnv < xpvnvend) {
 560         xpvnv->xpv_pv = (char*)(xpvnv + 1);
 561         xpvnv++;
 562     }
 563     xpvnv->xpv_pv = 0;
 564 }
 565
 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
 591 STATIC void
 592 S_more_xpvcv(pTHX)
 593 {
 594     register XPVCV* xpvcv;
 595     register XPVCV* xpvcvend;
 596     New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
 597     xpvcv = PL_xpvcv_root;
 598     xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
 599     while (xpvcv < xpvcvend) {
 600         xpvcv->xpv_pv = (char*)(xpvcv + 1);
 601         xpvcv++;
 602     }
 603     xpvcv->xpv_pv = 0;
 604 }
 605
 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
 631 STATIC void
 632 S_more_xpvav(pTHX)
 633 {
 634     register XPVAV* xpvav;
 635     register XPVAV* xpvavend;
 636     New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
 637     xpvav = PL_xpvav_root;
 638     xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
 639     while (xpvav < xpvavend) {
 640         xpvav->xav_array = (char*)(xpvav + 1);
 641         xpvav++;
 642     }
 643     xpvav->xav_array = 0;
 644 }
 645
 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
 671 STATIC void
 672 S_more_xpvhv(pTHX)
 673 {
 674     register XPVHV* xpvhv;
 675     register XPVHV* xpvhvend;
 676     New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
 677     xpvhv = PL_xpvhv_root;
 678     xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
 679     while (xpvhv < xpvhvend) {
 680         xpvhv->xhv_array = (char*)(xpvhv + 1);
 681         xpvhv++;
 682     }
 683     xpvhv->xhv_array = 0;
 684 }
 685
 686
 687 STATIC XPVMG*
 688 S_new_xpvmg(pTHX)
 689 {
 690     XPVMG* xpvmg;
 691     LOCK_SV_MUTEX;
 692     if (!PL_xpvmg_root)
 693         more_xpvmg();
 694     xpvmg = PL_xpvmg_root;
 695     PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
 696     UNLOCK_SV_MUTEX;
 697     return xpvmg;
 698 }
 699
 700 STATIC void
 701 S_del_xpvmg(pTHX_ XPVMG *p)
 702 {
 703     LOCK_SV_MUTEX;
 704     p->xpv_pv = (char*)PL_xpvmg_root;
 705     PL_xpvmg_root = p;
 706     UNLOCK_SV_MUTEX;
 707 }
 708
 709
 710 STATIC void
 711 S_more_xpvmg(pTHX)
 712 {
 713     register XPVMG* xpvmg;
 714     register XPVMG* xpvmgend;
 715     New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
 716     xpvmg = PL_xpvmg_root;
 717     xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
 718     while (xpvmg < xpvmgend) {
 719         xpvmg->xpv_pv = (char*)(xpvmg + 1);
 720         xpvmg++;
 721     }
 722     xpvmg->xpv_pv = 0;
 723 }
 724
 725
 726
 727 STATIC XPVLV*
 728 S_new_xpvlv(pTHX)
 729 {
 730     XPVLV* xpvlv;
 731     LOCK_SV_MUTEX;
 732     if (!PL_xpvlv_root)
 733         more_xpvlv();
 734     xpvlv = PL_xpvlv_root;
 735     PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
 736     UNLOCK_SV_MUTEX;
 737     return xpvlv;
 738 }
 739
 740 STATIC void
 741 S_del_xpvlv(pTHX_ XPVLV *p)
 742 {
 743     LOCK_SV_MUTEX;
 744     p->xpv_pv = (char*)PL_xpvlv_root;
 745     PL_xpvlv_root = p;
 746     UNLOCK_SV_MUTEX;
 747 }
 748
 749
 750 STATIC void
 751 S_more_xpvlv(pTHX)
 752 {
 753     register XPVLV* xpvlv;
 754     register XPVLV* xpvlvend;
 755     New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
 756     xpvlv = PL_xpvlv_root;
 757     xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
 758     while (xpvlv < xpvlvend) {
 759         xpvlv->xpv_pv = (char*)(xpvlv + 1);
 760         xpvlv++;
 761     }
 762     xpvlv->xpv_pv = 0;
 763 }
 764
 765
 766 STATIC XPVBM*
 767 S_new_xpvbm(pTHX)
 768 {
 769     XPVBM* xpvbm;
 770     LOCK_SV_MUTEX;
 771     if (!PL_xpvbm_root)
 772         more_xpvbm();
 773     xpvbm = PL_xpvbm_root;
 774     PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
 775     UNLOCK_SV_MUTEX;
 776     return xpvbm;
 777 }
 778
 779 STATIC void
 780 S_del_xpvbm(pTHX_ XPVBM *p)
 781 {
 782     LOCK_SV_MUTEX;
 783     p->xpv_pv = (char*)PL_xpvbm_root;
 784     PL_xpvbm_root = p;
 785     UNLOCK_SV_MUTEX;
 786 }
 787
 788
 789 STATIC void
 790 S_more_xpvbm(pTHX)
 791 {
 792     register XPVBM* xpvbm;
 793     register XPVBM* xpvbmend;
 794     New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
 795     xpvbm = PL_xpvbm_root;
 796     xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
 797     while (xpvbm < xpvbmend) {
 798         xpvbm->xpv_pv = (char*)(xpvbm + 1);
 799         xpvbm++;
 800     }
 801     xpvbm->xpv_pv = 0;
 802 }
 803
 804 #ifdef PURIFY
 805 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
 806 #define del_XIV(p) Safefree((char*)p)
 807 #else
 808 #define new_XIV() (void*)new_xiv()
 809 #define del_XIV(p) del_xiv((XPVIV*) p)
 810 #endif
 811
 812 #ifdef PURIFY
 813 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
 814 #define del_XNV(p) Safefree((char*)p)
 815 #else
 816 #define new_XNV() (void*)new_xnv()
 817 #define del_XNV(p) del_xnv((XPVNV*) p)
 818 #endif
 819
 820 #ifdef PURIFY
 821 #define new_XRV() (void*)safemalloc(sizeof(XRV))
 822 #define del_XRV(p) Safefree((char*)p)
 823 #else
 824 #define new_XRV() (void*)new_xrv()
 825 #define del_XRV(p) del_xrv((XRV*) p)
 826 #endif
 827
 828 #ifdef PURIFY
 829 #define new_XPV() (void*)safemalloc(sizeof(XPV))
 830 #define del_XPV(p) Safefree((char*)p)
 831 #else
 832 #define new_XPV() (void*)new_xpv()
 833 #define del_XPV(p) del_xpv((XPV *)p)
 834 #endif
 835
 836 #ifdef PURIFY
 837 #  define my_safemalloc(s) safemalloc(s)
 838 #  define my_safefree(s) safefree(s)
 839 #else
 840 STATIC void*
 841 S_my_safemalloc(MEM_SIZE size)
 842 {
 843     char *p;
 844     New(717, p, size, char);
 845     return (void*)p;
 846 }
 847 #  define my_safefree(s) Safefree(s)
 848 #endif
 849
 850 #ifdef PURIFY
 851 #define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
 852 #define del_XPVIV(p) Safefree((char*)p)
 853 #else
 854 #define new_XPVIV() (void*)new_xpviv()
 855 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
 856 #endif
 857
 858 #ifdef PURIFY
 859 #define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
 860 #define del_XPVNV(p) Safefree((char*)p)
 861 #else
 862 #define new_XPVNV() (void*)new_xpvnv()
 863 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
 864 #endif
 865
 866
 867 #ifdef PURIFY
 868 #define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
 869 #define del_XPVCV(p) Safefree((char*)p)
 870 #else
 871 #define new_XPVCV() (void*)new_xpvcv()
 872 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
 873 #endif
 874
 875 #ifdef PURIFY
 876 #define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
 877 #define del_XPVAV(p) Safefree((char*)p)
 878 #else
 879 #define new_XPVAV() (void*)new_xpvav()
 880 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
 881 #endif
 882
 883 #ifdef PURIFY
 884 #define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
 885 #define del_XPVHV(p) Safefree((char*)p)
 886 #else
 887 #define new_XPVHV() (void*)new_xpvhv()
 888 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
 889 #endif
 890
 891 #ifdef PURIFY
 892 #define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
 893 #define del_XPVMG(p) Safefree((char*)p)
 894 #else
 895 #define new_XPVMG() (void*)new_xpvmg()
 896 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
 897 #endif
 898
 899 #ifdef PURIFY
 900 #define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
 901 #define del_XPVLV(p) Safefree((char*)p)
 902 #else
 903 #define new_XPVLV() (void*)new_xpvlv()
 904 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
 905 #endif
 906
 907 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
 908 #define del_XPVGV(p) my_safefree((char*)p)
 909
 910 #ifdef PURIFY
 911 #define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
 912 #define del_XPVBM(p) Safefree((char*)p)
 913 #else
 914 #define new_XPVBM() (void*)new_xpvbm()
 915 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
 916 #endif
 917
 918 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
 919 #define del_XPVFM(p) my_safefree((char*)p)
 920
 921 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
 922 #define del_XPVIO(p) my_safefree((char*)p)
 923
 924 bool
 925 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
 926 {
 927     char*       pv;
 928     U32         cur;
 929     U32         len;
 930     IV          iv;
 931     NV          nv;
 932     MAGIC*      magic;
 933     HV*         stash;
 934
 935     if (SvTYPE(sv) == mt)
 936         return TRUE;
 937
 938     if (mt < SVt_PVIV)
 939         (void)SvOOK_off(sv);
 940
 941     switch (SvTYPE(sv)) {
 942     case SVt_NULL:
 943         pv      = 0;
 944         cur     = 0;
 945         len     = 0;
 946         iv      = 0;
 947         nv      = 0.0;
 948         magic   = 0;
 949         stash   = 0;
 950         break;
 951     case SVt_IV:
 952         pv      = 0;
 953         cur     = 0;
 954         len     = 0;
 955         iv      = SvIVX(sv);
 956         nv      = (NV)SvIVX(sv);
 957         del_XIV(SvANY(sv));
 958         magic   = 0;
 959         stash   = 0;
 960         if (mt == SVt_NV)
 961             mt = SVt_PVNV;
 962         else if (mt < SVt_PVIV)
 963             mt = SVt_PVIV;
 964         break;
 965     case SVt_NV:
 966         pv      = 0;
 967         cur     = 0;
 968         len     = 0;
 969         nv      = SvNVX(sv);
 970         iv      = I_V(nv);
 971         magic   = 0;
 972         stash   = 0;
 973         del_XNV(SvANY(sv));
 974         SvANY(sv) = 0;
 975         if (mt < SVt_PVNV)
 976             mt = SVt_PVNV;
 977         break;
 978     case SVt_RV:
 979         pv      = (char*)SvRV(sv);
 980         cur     = 0;
 981         len     = 0;
 982         iv      = PTR2IV(pv);
 983         nv      = PTR2NV(pv);
 984         del_XRV(SvANY(sv));
 985         magic   = 0;
 986         stash   = 0;
 987         break;
 988     case SVt_PV:
 989         pv      = SvPVX(sv);
 990         cur     = SvCUR(sv);
 991         len     = SvLEN(sv);
 992         iv      = 0;
 993         nv      = 0.0;
 994         magic   = 0;
 995         stash   = 0;
 996         del_XPV(SvANY(sv));
 997         if (mt <= SVt_IV)
 998             mt = SVt_PVIV;
 999         else if (mt == SVt_NV)
1000             mt = SVt_PVNV;
1001         break;
1002     case SVt_PVIV:
1003         pv      = SvPVX(sv);
1004         cur     = SvCUR(sv);
1005         len     = SvLEN(sv);
1006         iv      = SvIVX(sv);
1007         nv      = 0.0;
1008         magic   = 0;
1009         stash   = 0;
1010         del_XPVIV(SvANY(sv));
1011         break;
1012     case SVt_PVNV:
1013         pv      = SvPVX(sv);
1014         cur     = SvCUR(sv);
1015         len     = SvLEN(sv);
1016         iv      = SvIVX(sv);
1017         nv      = SvNVX(sv);
1018         magic   = 0;
1019         stash   = 0;
1020         del_XPVNV(SvANY(sv));
1021         break;
1022     case SVt_PVMG:
1023         pv      = SvPVX(sv);
1024         cur     = SvCUR(sv);
1025         len     = SvLEN(sv);
1026         iv      = SvIVX(sv);
1027         nv      = SvNVX(sv);
1028         magic   = SvMAGIC(sv);
1029         stash   = SvSTASH(sv);
1030         del_XPVMG(SvANY(sv));
1031         break;
1032     default:
1033         Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1034     }
1035
1036     switch (mt) {
1037     case SVt_NULL:
1038         Perl_croak(aTHX_ "Can't upgrade to undef");
1039     case SVt_IV:
1040         SvANY(sv) = new_XIV();
1041         SvIVX(sv)       = iv;
1042         break;
1043     case SVt_NV:
1044         SvANY(sv) = new_XNV();
1045         SvNVX(sv)       = nv;
1046         break;
1047     case SVt_RV:
1048         SvANY(sv) = new_XRV();
1049         SvRV(sv) = (SV*)pv;
1050         break;
1051     case SVt_PV:
1052         SvANY(sv) = new_XPV();
1053         SvPVX(sv)       = pv;
1054         SvCUR(sv)       = cur;
1055         SvLEN(sv)       = len;
1056         break;
1057     case SVt_PVIV:
1058         SvANY(sv) = new_XPVIV();
1059         SvPVX(sv)       = pv;
1060         SvCUR(sv)       = cur;
1061         SvLEN(sv)       = len;
1062         SvIVX(sv)       = iv;
1063         if (SvNIOK(sv))
1064             (void)SvIOK_on(sv);
1065         SvNOK_off(sv);
1066         break;
1067     case SVt_PVNV:
1068         SvANY(sv) = new_XPVNV();
1069         SvPVX(sv)       = pv;
1070         SvCUR(sv)       = cur;
1071         SvLEN(sv)       = len;
1072         SvIVX(sv)       = iv;
1073         SvNVX(sv)       = nv;
1074         break;
1075     case SVt_PVMG:
1076         SvANY(sv) = new_XPVMG();
1077         SvPVX(sv)       = pv;
1078         SvCUR(sv)       = cur;
1079         SvLEN(sv)       = len;
1080         SvIVX(sv)       = iv;
1081         SvNVX(sv)       = nv;
1082         SvMAGIC(sv)     = magic;
1083         SvSTASH(sv)     = stash;
1084         break;
1085     case SVt_PVLV:
1086         SvANY(sv) = new_XPVLV();
1087         SvPVX(sv)       = pv;
1088         SvCUR(sv)       = cur;
1089         SvLEN(sv)       = len;
1090         SvIVX(sv)       = iv;
1091         SvNVX(sv)       = nv;
1092         SvMAGIC(sv)     = magic;
1093         SvSTASH(sv)     = stash;
1094         LvTARGOFF(sv)   = 0;
1095         LvTARGLEN(sv)   = 0;
1096         LvTARG(sv)      = 0;
1097         LvTYPE(sv)      = 0;
1098         break;
1099     case SVt_PVAV:
1100         SvANY(sv) = new_XPVAV();
1101         if (pv)
1102             Safefree(pv);
1103         SvPVX(sv)       = 0;
1104         AvMAX(sv)       = -1;
1105         AvFILLp(sv)     = -1;
1106         SvIVX(sv)       = 0;
1107         SvNVX(sv)       = 0.0;
1108         SvMAGIC(sv)     = magic;
1109         SvSTASH(sv)     = stash;
1110         AvALLOC(sv)     = 0;
1111         AvARYLEN(sv)    = 0;
1112         AvFLAGS(sv)     = 0;
1113         break;
1114     case SVt_PVHV:
1115         SvANY(sv) = new_XPVHV();
1116         if (pv)
1117             Safefree(pv);
1118         SvPVX(sv)       = 0;
1119         HvFILL(sv)      = 0;
1120         HvMAX(sv)       = 0;
1121         HvKEYS(sv)      = 0;
1122         SvNVX(sv)       = 0.0;
1123         SvMAGIC(sv)     = magic;
1124         SvSTASH(sv)     = stash;
1125         HvRITER(sv)     = 0;
1126         HvEITER(sv)     = 0;
1127         HvPMROOT(sv)    = 0;
1128         HvNAME(sv)      = 0;
1129         break;
1130     case SVt_PVCV:
1131         SvANY(sv) = new_XPVCV();
1132         Zero(SvANY(sv), 1, XPVCV);
1133         SvPVX(sv)       = pv;
1134         SvCUR(sv)       = cur;
1135         SvLEN(sv)       = len;
1136         SvIVX(sv)       = iv;
1137         SvNVX(sv)       = nv;
1138         SvMAGIC(sv)     = magic;
1139         SvSTASH(sv)     = stash;
1140         break;
1141     case SVt_PVGV:
1142         SvANY(sv) = new_XPVGV();
1143         SvPVX(sv)       = pv;
1144         SvCUR(sv)       = cur;
1145         SvLEN(sv)       = len;
1146         SvIVX(sv)       = iv;
1147         SvNVX(sv)       = nv;
1148         SvMAGIC(sv)     = magic;
1149         SvSTASH(sv)     = stash;
1150         GvGP(sv)        = 0;
1151         GvNAME(sv)      = 0;
1152         GvNAMELEN(sv)   = 0;
1153         GvSTASH(sv)     = 0;
1154         GvFLAGS(sv)     = 0;
1155         break;
1156     case SVt_PVBM:
1157         SvANY(sv) = new_XPVBM();
1158         SvPVX(sv)       = pv;
1159         SvCUR(sv)       = cur;
1160         SvLEN(sv)       = len;
1161         SvIVX(sv)       = iv;
1162         SvNVX(sv)       = nv;
1163         SvMAGIC(sv)     = magic;
1164         SvSTASH(sv)     = stash;
1165         BmRARE(sv)      = 0;
1166         BmUSEFUL(sv)    = 0;
1167         BmPREVIOUS(sv)  = 0;
1168         break;
1169     case SVt_PVFM:
1170         SvANY(sv) = new_XPVFM();
1171         Zero(SvANY(sv), 1, XPVFM);
1172         SvPVX(sv)       = pv;
1173         SvCUR(sv)       = cur;
1174         SvLEN(sv)       = len;
1175         SvIVX(sv)       = iv;
1176         SvNVX(sv)       = nv;
1177         SvMAGIC(sv)     = magic;
1178         SvSTASH(sv)     = stash;
1179         break;
1180     case SVt_PVIO:
1181         SvANY(sv) = new_XPVIO();
1182         Zero(SvANY(sv), 1, XPVIO);
1183         SvPVX(sv)       = pv;
1184         SvCUR(sv)       = cur;
1185         SvLEN(sv)       = len;
1186         SvIVX(sv)       = iv;
1187         SvNVX(sv)       = nv;
1188         SvMAGIC(sv)     = magic;
1189         SvSTASH(sv)     = stash;
1190         IoPAGE_LEN(sv)  = 60;
1191         break;
1192     }
1193     SvFLAGS(sv) &= ~SVTYPEMASK;
1194     SvFLAGS(sv) |= mt;
1195     return TRUE;
1196 }
1197
1198 int
1199 Perl_sv_backoff(pTHX_ register SV *sv)
1200 {
1201     assert(SvOOK(sv));
1202     if (SvIVX(sv)) {
1203         char *s = SvPVX(sv);
1204         SvLEN(sv) += SvIVX(sv);
1205         SvPVX(sv) -= SvIVX(sv);
1206         SvIV_set(sv, 0);
1207         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1208     }
1209     SvFLAGS(sv) &= ~SVf_OOK;
1210     return 0;
1211 }
1212
1213 char *
1214 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1215 {
1216     register char *s;
1217
1218 #ifdef HAS_64K_LIMIT
1219     if (newlen >= 0x10000) {
1220         PerlIO_printf(Perl_debug_log,
1221                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1222         my_exit(1);
1223     }
1224 #endif /* HAS_64K_LIMIT */
1225     if (SvROK(sv))
1226         sv_unref(sv);
1227     if (SvTYPE(sv) < SVt_PV) {
1228         sv_upgrade(sv, SVt_PV);
1229         s = SvPVX(sv);
1230     }
1231     else if (SvOOK(sv)) {       /* pv is offset? */
1232         sv_backoff(sv);
1233         s = SvPVX(sv);
1234         if (newlen > SvLEN(sv))
1235             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1236 #ifdef HAS_64K_LIMIT
1237         if (newlen >= 0x10000)
1238             newlen = 0xFFFF;
1239 #endif
1240     }
1241     else
1242         s = SvPVX(sv);
1243     if (newlen > SvLEN(sv)) {           /* need more room? */
1244         if (SvLEN(sv) && s) {
1245 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
1246             STRLEN l = malloced_size((void*)SvPVX(sv));
1247             if (newlen <= l) {
1248                 SvLEN_set(sv, l);
1249                 return s;
1250             } else
1251 #endif
1252             Renew(s,newlen,char);
1253         }
1254         else
1255             New(703,s,newlen,char);
1256         SvPV_set(sv, s);
1257         SvLEN_set(sv, newlen);
1258     }
1259     return s;
1260 }
1261
1262 void
1263 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1264 {
1265     SV_CHECK_THINKFIRST(sv);
1266     switch (SvTYPE(sv)) {
1267     case SVt_NULL:
1268         sv_upgrade(sv, SVt_IV);
1269         break;
1270     case SVt_NV:
1271         sv_upgrade(sv, SVt_PVNV);
1272         break;
1273     case SVt_RV:
1274     case SVt_PV:
1275         sv_upgrade(sv, SVt_PVIV);
1276         break;
1277
1278     case SVt_PVGV:
1279     case SVt_PVAV:
1280     case SVt_PVHV:
1281     case SVt_PVCV:
1282     case SVt_PVFM:
1283     case SVt_PVIO:
1284         {
1285             dTHR;
1286             Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1287                   PL_op_desc[PL_op->op_type]);
1288         }
1289     }
1290     (void)SvIOK_only(sv);                       /* validate number */
1291     SvIVX(sv) = i;
1292     SvTAINT(sv);
1293 }
1294
1295 void
1296 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1297 {
1298     sv_setiv(sv,i);
1299     SvSETMAGIC(sv);
1300 }
1301
1302 void
1303 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1304 {
1305     sv_setiv(sv, 0);
1306     SvIsUV_on(sv);
1307     SvUVX(sv) = u;
1308 }
1309
1310 void
1311 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1312 {
1313     sv_setuv(sv,u);
1314     SvSETMAGIC(sv);
1315 }
1316
1317 void
1318 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1319 {
1320     SV_CHECK_THINKFIRST(sv);
1321     switch (SvTYPE(sv)) {
1322     case SVt_NULL:
1323     case SVt_IV:
1324         sv_upgrade(sv, SVt_NV);
1325         break;
1326     case SVt_RV:
1327     case SVt_PV:
1328     case SVt_PVIV:
1329         sv_upgrade(sv, SVt_PVNV);
1330         break;
1331
1332     case SVt_PVGV:
1333     case SVt_PVAV:
1334     case SVt_PVHV:
1335     case SVt_PVCV:
1336     case SVt_PVFM:
1337     case SVt_PVIO:
1338         {
1339             dTHR;
1340             Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1341                   PL_op_name[PL_op->op_type]);
1342         }
1343     }
1344     SvNVX(sv) = num;
1345     (void)SvNOK_only(sv);                       /* validate number */
1346     SvTAINT(sv);
1347 }
1348
1349 void
1350 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1351 {
1352     sv_setnv(sv,num);
1353     SvSETMAGIC(sv);
1354 }
1355
1356 STATIC void
1357 S_not_a_number(pTHX_ SV *sv)
1358 {
1359     dTHR;
1360     char tmpbuf[64];
1361     char *d = tmpbuf;
1362     char *s;
1363     char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1364                   /* each *s can expand to 4 chars + "...\0",
1365                      i.e. need room for 8 chars */
1366
1367     for (s = SvPVX(sv); *s && d < limit; s++) {
1368         int ch = *s & 0xFF;
1369         if (ch & 128 && !isPRINT_LC(ch)) {
1370             *d++ = 'M';
1371             *d++ = '-';
1372             ch &= 127;
1373         }
1374         if (ch == '\n') {
1375             *d++ = '\\';
1376             *d++ = 'n';
1377         }
1378         else if (ch == '\r') {
1379             *d++ = '\\';
1380             *d++ = 'r';
1381         }
1382         else if (ch == '\f') {
1383             *d++ = '\\';
1384             *d++ = 'f';
1385         }
1386         else if (ch == '\\') {
1387             *d++ = '\\';
1388             *d++ = '\\';
1389         }
1390         else if (isPRINT_LC(ch))
1391             *d++ = ch;
1392         else {
1393             *d++ = '^';
1394             *d++ = toCTRL(ch);
1395         }
1396     }
1397     if (*s) {
1398         *d++ = '.';
1399         *d++ = '.';
1400         *d++ = '.';
1401     }
1402     *d = '\0';
1403
1404     if (PL_op)
1405         Perl_warner(aTHX_ WARN_NUMERIC,
1406                     "Argument \"%s\" isn't numeric in %s", tmpbuf,
1407                 PL_op_desc[PL_op->op_type]);
1408     else
1409         Perl_warner(aTHX_ WARN_NUMERIC,
1410                     "Argument \"%s\" isn't numeric", tmpbuf);
1411 }
1412
1413 /* the number can be converted to integer with atol() or atoll() */
1414 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1415 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1416 #define IS_NUMBER_NOT_IV         0x04 /* (IV)atof() may be != atof() */
1417 #define IS_NUMBER_NEG            0x08 /* not good to cache UV */
1418
1419 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1420    until proven guilty, assume that things are not that bad... */
1421
1422 IV
1423 Perl_sv_2iv(pTHX_ register SV *sv)
1424 {
1425     if (!sv)
1426         return 0;
1427     if (SvGMAGICAL(sv)) {
1428         mg_get(sv);
1429         if (SvIOKp(sv))
1430             return SvIVX(sv);
1431         if (SvNOKp(sv)) {
1432             return I_V(SvNVX(sv));
1433         }
1434         if (SvPOKp(sv) && SvLEN(sv))
1435             return asIV(sv);
1436         if (!SvROK(sv)) {
1437             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1438                 dTHR;
1439                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1440                     report_uninit();
1441             }
1442             return 0;
1443         }
1444     }
1445     if (SvTHINKFIRST(sv)) {
1446         if (SvROK(sv)) {
1447           SV* tmpstr;
1448           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1449               return SvIV(tmpstr);
1450           return PTR2IV(SvRV(sv));
1451         }
1452         if (SvREADONLY(sv) && !SvOK(sv)) {
1453             dTHR;
1454             if (ckWARN(WARN_UNINITIALIZED))
1455                 report_uninit();
1456             return 0;
1457         }
1458     }
1459     if (SvIOKp(sv)) {
1460         if (SvIsUV(sv)) {
1461             return (IV)(SvUVX(sv));
1462         }
1463         else {
1464             return SvIVX(sv);
1465         }
1466     }
1467     if (SvNOKp(sv)) {
1468         /* We can cache the IV/UV value even if it not good enough
1469          * to reconstruct NV, since the conversion to PV will prefer
1470          * NV over IV/UV.
1471          */
1472
1473         if (SvTYPE(sv) == SVt_NV)
1474             sv_upgrade(sv, SVt_PVNV);
1475
1476         (void)SvIOK_on(sv);
1477         if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1478             SvIVX(sv) = I_V(SvNVX(sv));
1479         else {
1480             SvUVX(sv) = U_V(SvNVX(sv));
1481             SvIsUV_on(sv);
1482           ret_iv_max:
1483             DEBUG_c(PerlIO_printf(Perl_debug_log,
1484                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1485                                   PTR2UV(sv),
1486                                   SvUVX(sv),
1487                                   SvUVX(sv)));
1488             return (IV)SvUVX(sv);
1489         }
1490     }
1491     else if (SvPOKp(sv) && SvLEN(sv)) {
1492         I32 numtype = looks_like_number(sv);
1493
1494         /* We want to avoid a possible problem when we cache an IV which
1495            may be later translated to an NV, and the resulting NV is not
1496            the translation of the initial data.
1497
1498            This means that if we cache such an IV, we need to cache the
1499            NV as well.  Moreover, we trade speed for space, and do not
1500            cache the NV if not needed.
1501          */
1502         if (numtype & IS_NUMBER_NOT_IV) {
1503             /* May be not an integer.  Need to cache NV if we cache IV
1504              * - otherwise future conversion to NV will be wrong.  */
1505             NV d;
1506
1507             d = Atof(SvPVX(sv));
1508
1509             if (SvTYPE(sv) < SVt_PVNV)
1510                 sv_upgrade(sv, SVt_PVNV);
1511             SvNVX(sv) = d;
1512             (void)SvNOK_on(sv);
1513             (void)SvIOK_on(sv);
1514 #if defined(USE_LONG_DOUBLE)
1515             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1516                                   PTR2UV(sv), SvNVX(sv)));
1517 #else
1518             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1519                                   PTR2UV(sv), SvNVX(sv)));
1520 #endif
1521             if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1522                 SvIVX(sv) = I_V(SvNVX(sv));
1523             else {
1524                 SvUVX(sv) = U_V(SvNVX(sv));
1525                 SvIsUV_on(sv);
1526                 goto ret_iv_max;
1527             }
1528         }
1529         else if (numtype) {
1530             /* The NV may be reconstructed from IV - safe to cache IV,
1531                which may be calculated by atol(). */
1532             if (SvTYPE(sv) == SVt_PV)
1533                 sv_upgrade(sv, SVt_PVIV);
1534             (void)SvIOK_on(sv);
1535             SvIVX(sv) = Atol(SvPVX(sv));
1536         }
1537         else {                          /* Not a number.  Cache 0. */
1538             dTHR;
1539
1540             if (SvTYPE(sv) < SVt_PVIV)
1541                 sv_upgrade(sv, SVt_PVIV);
1542             SvIVX(sv) = 0;
1543             (void)SvIOK_on(sv);
1544             if (ckWARN(WARN_NUMERIC))
1545                 not_a_number(sv);
1546         }
1547     }
1548     else  {
1549         dTHR;
1550         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1551             report_uninit();
1552         if (SvTYPE(sv) < SVt_IV)
1553             /* Typically the caller expects that sv_any is not NULL now.  */
1554             sv_upgrade(sv, SVt_IV);
1555         return 0;
1556     }
1557     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1558         PTR2UV(sv),SvIVX(sv)));
1559     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1560 }
1561
1562 UV
1563 Perl_sv_2uv(pTHX_ register SV *sv)
1564 {
1565     if (!sv)
1566         return 0;
1567     if (SvGMAGICAL(sv)) {
1568         mg_get(sv);
1569         if (SvIOKp(sv))
1570             return SvUVX(sv);
1571         if (SvNOKp(sv))
1572             return U_V(SvNVX(sv));
1573         if (SvPOKp(sv) && SvLEN(sv))
1574             return asUV(sv);
1575         if (!SvROK(sv)) {
1576             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1577                 dTHR;
1578                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1579                     report_uninit();
1580             }
1581             return 0;
1582         }
1583     }
1584     if (SvTHINKFIRST(sv)) {
1585         if (SvROK(sv)) {
1586           SV* tmpstr;
1587           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1588               return SvUV(tmpstr);
1589           return PTR2UV(SvRV(sv));
1590         }
1591         if (SvREADONLY(sv) && !SvOK(sv)) {
1592             dTHR;
1593             if (ckWARN(WARN_UNINITIALIZED))
1594                 report_uninit();
1595             return 0;
1596         }
1597     }
1598     if (SvIOKp(sv)) {
1599         if (SvIsUV(sv)) {
1600             return SvUVX(sv);
1601         }
1602         else {
1603             return (UV)SvIVX(sv);
1604         }
1605     }
1606     if (SvNOKp(sv)) {
1607         /* We can cache the IV/UV value even if it not good enough
1608          * to reconstruct NV, since the conversion to PV will prefer
1609          * NV over IV/UV.
1610          */
1611         if (SvTYPE(sv) == SVt_NV)
1612             sv_upgrade(sv, SVt_PVNV);
1613         (void)SvIOK_on(sv);
1614         if (SvNVX(sv) >= -0.5) {
1615             SvIsUV_on(sv);
1616             SvUVX(sv) = U_V(SvNVX(sv));
1617         }
1618         else {
1619             SvIVX(sv) = I_V(SvNVX(sv));
1620           ret_zero:
1621             DEBUG_c(PerlIO_printf(Perl_debug_log,
1622                                   "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1623                                   PTR2UV(sv),
1624                                   SvIVX(sv),
1625                                   (IV)(UV)SvIVX(sv)));
1626             return (UV)SvIVX(sv);
1627         }
1628     }
1629     else if (SvPOKp(sv) && SvLEN(sv)) {
1630         I32 numtype = looks_like_number(sv);
1631
1632         /* We want to avoid a possible problem when we cache a UV which
1633            may be later translated to an NV, and the resulting NV is not
1634            the translation of the initial data.
1635
1636            This means that if we cache such a UV, we need to cache the
1637            NV as well.  Moreover, we trade speed for space, and do not
1638            cache the NV if not needed.
1639          */
1640         if (numtype & IS_NUMBER_NOT_IV) {
1641             /* May be not an integer.  Need to cache NV if we cache IV
1642              * - otherwise future conversion to NV will be wrong.  */
1643             NV d;
1644
1645             d = Atof(SvPVX(sv));
1646
1647             if (SvTYPE(sv) < SVt_PVNV)
1648                 sv_upgrade(sv, SVt_PVNV);
1649             SvNVX(sv) = d;
1650             (void)SvNOK_on(sv);
1651             (void)SvIOK_on(sv);
1652 #if defined(USE_LONG_DOUBLE)
1653             DEBUG_c(PerlIO_printf(Perl_debug_log,
1654                                   "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1655                                   PTR2UV(sv), SvNVX(sv)));
1656 #else
1657             DEBUG_c(PerlIO_printf(Perl_debug_log,
1658                                   "0x%"UVxf" 2nv(%g)\n",
1659                                   PTR2UV(sv), SvNVX(sv)));
1660 #endif
1661             if (SvNVX(sv) < -0.5) {
1662                 SvIVX(sv) = I_V(SvNVX(sv));
1663                 goto ret_zero;
1664             } else {
1665                 SvUVX(sv) = U_V(SvNVX(sv));
1666                 SvIsUV_on(sv);
1667             }
1668         }
1669         else if (numtype & IS_NUMBER_NEG) {
1670             /* The NV may be reconstructed from IV - safe to cache IV,
1671                which may be calculated by atol(). */
1672             if (SvTYPE(sv) == SVt_PV)
1673                 sv_upgrade(sv, SVt_PVIV);
1674             (void)SvIOK_on(sv);
1675             SvIVX(sv) = (IV)Atol(SvPVX(sv));
1676         }
1677         else if (numtype) {             /* Non-negative */
1678             /* The NV may be reconstructed from UV - safe to cache UV,
1679                which may be calculated by strtoul()/atol. */
1680             if (SvTYPE(sv) == SVt_PV)
1681                 sv_upgrade(sv, SVt_PVIV);
1682             (void)SvIOK_on(sv);
1683             (void)SvIsUV_on(sv);
1684 #ifdef HAS_STRTOUL
1685             SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1686 #else                   /* no atou(), but we know the number fits into IV... */
1687                         /* The only problem may be if it is negative... */
1688             SvUVX(sv) = (UV)Atol(SvPVX(sv));
1689 #endif
1690         }
1691         else {                          /* Not a number.  Cache 0. */
1692             dTHR;
1693
1694             if (SvTYPE(sv) < SVt_PVIV)
1695                 sv_upgrade(sv, SVt_PVIV);
1696             SvUVX(sv) = 0;              /* We assume that 0s have the
1697                                            same bitmap in IV and UV. */
1698             (void)SvIOK_on(sv);
1699             (void)SvIsUV_on(sv);
1700             if (ckWARN(WARN_NUMERIC))
1701                 not_a_number(sv);
1702         }
1703     }
1704     else  {
1705         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1706             dTHR;
1707             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1708                 report_uninit();
1709         }
1710         if (SvTYPE(sv) < SVt_IV)
1711             /* Typically the caller expects that sv_any is not NULL now.  */
1712             sv_upgrade(sv, SVt_IV);
1713         return 0;
1714     }
1715
1716     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1717                           PTR2UV(sv),SvUVX(sv)));
1718     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1719 }
1720
1721 NV
1722 Perl_sv_2nv(pTHX_ register SV *sv)
1723 {
1724     if (!sv)
1725         return 0.0;
1726     if (SvGMAGICAL(sv)) {
1727         mg_get(sv);
1728         if (SvNOKp(sv))
1729             return SvNVX(sv);
1730         if (SvPOKp(sv) && SvLEN(sv)) {
1731             dTHR;
1732             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1733                 not_a_number(sv);
1734             return Atof(SvPVX(sv));
1735         }
1736         if (SvIOKp(sv)) {
1737             if (SvIsUV(sv))
1738                 return (NV)SvUVX(sv);
1739             else
1740                 return (NV)SvIVX(sv);
1741         }
1742         if (!SvROK(sv)) {
1743             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1744                 dTHR;
1745                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1746                     report_uninit();
1747             }
1748             return 0;
1749         }
1750     }
1751     if (SvTHINKFIRST(sv)) {
1752         if (SvROK(sv)) {
1753           SV* tmpstr;
1754           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1755               return SvNV(tmpstr);
1756           return PTR2NV(SvRV(sv));
1757         }
1758         if (SvREADONLY(sv) && !SvOK(sv)) {
1759             dTHR;
1760             if (ckWARN(WARN_UNINITIALIZED))
1761                 report_uninit();
1762             return 0.0;
1763         }
1764     }
1765     if (SvTYPE(sv) < SVt_NV) {
1766         if (SvTYPE(sv) == SVt_IV)
1767             sv_upgrade(sv, SVt_PVNV);
1768         else
1769             sv_upgrade(sv, SVt_NV);
1770 #if defined(USE_LONG_DOUBLE)
1771         DEBUG_c({
1772             RESTORE_NUMERIC_STANDARD();
1773             PerlIO_printf(Perl_debug_log,
1774                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1775                           PTR2UV(sv), SvNVX(sv));
1776             RESTORE_NUMERIC_LOCAL();
1777         });
1778 #else
1779         DEBUG_c({
1780             RESTORE_NUMERIC_STANDARD();
1781             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1782                           PTR2UV(sv), SvNVX(sv));
1783             RESTORE_NUMERIC_LOCAL();
1784         });
1785 #endif
1786     }
1787     else if (SvTYPE(sv) < SVt_PVNV)
1788         sv_upgrade(sv, SVt_PVNV);
1789     if (SvIOKp(sv) &&
1790             (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1791     {
1792         SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1793     }
1794     else if (SvPOKp(sv) && SvLEN(sv)) {
1795         dTHR;
1796         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1797             not_a_number(sv);
1798         SvNVX(sv) = Atof(SvPVX(sv));
1799     }
1800     else  {
1801         dTHR;
1802         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1803             report_uninit();
1804         if (SvTYPE(sv) < SVt_NV)
1805             /* Typically the caller expects that sv_any is not NULL now.  */
1806             sv_upgrade(sv, SVt_NV);
1807         return 0.0;
1808     }
1809     SvNOK_on(sv);
1810 #if defined(USE_LONG_DOUBLE)
1811     DEBUG_c({
1812         RESTORE_NUMERIC_STANDARD();
1813         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1814                       PTR2UV(sv), SvNVX(sv));
1815         RESTORE_NUMERIC_LOCAL();
1816     });
1817 #else
1818     DEBUG_c({
1819         RESTORE_NUMERIC_STANDARD();
1820         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1821                       PTR2UV(sv), SvNVX(sv));
1822         RESTORE_NUMERIC_LOCAL();
1823     });
1824 #endif
1825     return SvNVX(sv);
1826 }
1827
1828 STATIC IV
1829 S_asIV(pTHX_ SV *sv)
1830 {
1831     I32 numtype = looks_like_number(sv);
1832     NV d;
1833
1834     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1835         return Atol(SvPVX(sv));
1836     if (!numtype) {
1837         dTHR;
1838         if (ckWARN(WARN_NUMERIC))
1839             not_a_number(sv);
1840     }
1841     d = Atof(SvPVX(sv));
1842     return I_V(d);
1843 }
1844
1845 STATIC UV
1846 S_asUV(pTHX_ SV *sv)
1847 {
1848     I32 numtype = looks_like_number(sv);
1849
1850 #ifdef HAS_STRTOUL
1851     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1852         return Strtoul(SvPVX(sv), Null(char**), 10);
1853 #endif
1854     if (!numtype) {
1855         dTHR;
1856         if (ckWARN(WARN_NUMERIC))
1857             not_a_number(sv);
1858     }
1859     return U_V(Atof(SvPVX(sv)));
1860 }
1861
1862 /*
1863  * Returns a combination of (advisory only - can get false negatives)
1864  *      IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1865  *      IS_NUMBER_NEG
1866  * 0 if does not look like number.
1867  *
1868  * In fact possible values are 0 and
1869  * IS_NUMBER_TO_INT_BY_ATOL                             123
1870  * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV          123.1
1871  * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV          123e0
1872  * with a possible addition of IS_NUMBER_NEG.
1873  */
1874
1875 I32
1876 Perl_looks_like_number(pTHX_ SV *sv)
1877 {
1878     register char *s;
1879     register char *send;
1880     register char *sbegin;
1881     register char *nbegin;
1882     I32 numtype = 0;
1883     STRLEN len;
1884
1885     if (SvPOK(sv)) {
1886         sbegin = SvPVX(sv);
1887         len = SvCUR(sv);
1888     }
1889     else if (SvPOKp(sv))
1890         sbegin = SvPV(sv, len);
1891     else
1892         return 1;
1893     send = sbegin + len;
1894
1895     s = sbegin;
1896     while (isSPACE(*s))
1897         s++;
1898     if (*s == '-') {
1899         s++;
1900         numtype = IS_NUMBER_NEG;
1901     }
1902     else if (*s == '+')
1903         s++;
1904
1905     nbegin = s;
1906     /*
1907      * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1908      * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1909      * (int)atof().
1910      */
1911
1912     /* next must be digit or the radix separator */
1913     if (isDIGIT(*s)) {
1914         do {
1915             s++;
1916         } while (isDIGIT(*s));
1917
1918         if (s - nbegin >= TYPE_DIGITS(IV))      /* Cannot cache ato[ul]() */
1919             numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1920         else
1921             numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1922
1923         if (*s == '.'
1924 #ifdef USE_LOCALE_NUMERIC
1925             || IS_NUMERIC_RADIX(*s)
1926 #endif
1927             ) {
1928             s++;
1929             numtype |= IS_NUMBER_NOT_IV;
1930             while (isDIGIT(*s))  /* optional digits after the radix */
1931                 s++;
1932         }
1933     }
1934     else if (*s == '.'
1935 #ifdef USE_LOCALE_NUMERIC
1936             || IS_NUMERIC_RADIX(*s)
1937 #endif
1938             ) {
1939         s++;
1940         numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1941         /* no digits before the radix means we need digits after it */
1942         if (isDIGIT(*s)) {
1943             do {
1944                 s++;
1945             } while (isDIGIT(*s));
1946         }
1947         else
1948             return 0;
1949     }
1950     else
1951         return 0;
1952
1953     /* we can have an optional exponent part */
1954     if (*s == 'e' || *s == 'E') {
1955         numtype &= ~IS_NUMBER_NEG;
1956         numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1957         s++;
1958         if (*s == '+' || *s == '-')
1959             s++;
1960         if (isDIGIT(*s)) {
1961             do {
1962                 s++;
1963             } while (isDIGIT(*s));
1964         }
1965         else
1966             return 0;
1967     }
1968     while (isSPACE(*s))
1969         s++;
1970     if (s >= send)
1971         return numtype;
1972     if (len == 10 && memEQ(sbegin, "0 but true", 10))
1973         return IS_NUMBER_TO_INT_BY_ATOL;
1974     return 0;
1975 }
1976
1977 char *
1978 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1979 {
1980     STRLEN n_a;
1981     return sv_2pv(sv, &n_a);
1982 }
1983
1984 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1985 static char *
1986 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1987 {
1988     STRLEN len;
1989     char *ptr = buf + TYPE_CHARS(UV);
1990     char *ebuf = ptr;
1991     int sign;
1992     char *p;
1993
1994     if (is_uv)
1995         sign = 0;
1996     else if (iv >= 0) {
1997         uv = iv;
1998         sign = 0;
1999     } else {
2000         uv = -iv;
2001         sign = 1;
2002     }
2003     do {
2004         *--ptr = '0' + (uv % 10);
2005     } while (uv /= 10);
2006     if (sign)
2007         *--ptr = '-';
2008     *peob = ebuf;
2009     return ptr;
2010 }
2011
2012 char *
2013 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2014 {
2015     register char *s;
2016     int olderrno;
2017     SV *tsv;
2018     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2019     char *tmpbuf = tbuf;
2020
2021     if (!sv) {
2022         *lp = 0;
2023         return "";
2024     }
2025     if (SvGMAGICAL(sv)) {
2026         mg_get(sv);
2027         if (SvPOKp(sv)) {
2028             *lp = SvCUR(sv);
2029             return SvPVX(sv);
2030         }
2031         if (SvIOKp(sv)) {
2032             if (SvIsUV(sv))
2033                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2034             else
2035                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2036             tsv = Nullsv;
2037             goto tokensave;
2038         }
2039         if (SvNOKp(sv)) {
2040             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2041             tsv = Nullsv;
2042             goto tokensave;
2043         }
2044         if (!SvROK(sv)) {
2045             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2046                 dTHR;
2047                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2048                     report_uninit();
2049             }
2050             *lp = 0;
2051             return "";
2052         }
2053     }
2054     if (SvTHINKFIRST(sv)) {
2055         if (SvROK(sv)) {
2056             SV* tmpstr;
2057             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2058                 return SvPV(tmpstr,*lp);
2059             sv = (SV*)SvRV(sv);
2060             if (!sv)
2061                 s = "NULLREF";
2062             else {
2063                 MAGIC *mg;
2064
2065                 switch (SvTYPE(sv)) {
2066                 case SVt_PVMG:
2067                     if ( ((SvFLAGS(sv) &
2068                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2069                           == (SVs_OBJECT|SVs_RMG))
2070                          && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2071                          && (mg = mg_find(sv, 'r'))) {
2072                         dTHR;
2073                         regexp *re = (regexp *)mg->mg_obj;
2074
2075                         if (!mg->mg_ptr) {
2076                             char *fptr = "msix";
2077                             char reflags[6];
2078                             char ch;
2079                             int left = 0;
2080                             int right = 4;
2081                             U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2082
2083                             while(ch = *fptr++) {
2084                                 if(reganch & 1) {
2085                                     reflags[left++] = ch;
2086                                 }
2087                                 else {
2088                                     reflags[right--] = ch;
2089                                 }
2090                                 reganch >>= 1;
2091                             }
2092                             if(left != 4) {
2093                                 reflags[left] = '-';
2094                                 left = 5;
2095                             }
2096
2097                             mg->mg_len = re->prelen + 4 + left;
2098                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2099                             Copy("(?", mg->mg_ptr, 2, char);
2100                             Copy(reflags, mg->mg_ptr+2, left, char);
2101                             Copy(":", mg->mg_ptr+left+2, 1, char);
2102                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2103                             mg->mg_ptr[mg->mg_len - 1] = ')';
2104                             mg->mg_ptr[mg->mg_len] = 0;
2105                         }
2106                         PL_reginterp_cnt += re->program[0].next_off;
2107                         *lp = mg->mg_len;
2108                         return mg->mg_ptr;
2109                     }
2110                                         /* Fall through */
2111                 case SVt_NULL:
2112                 case SVt_IV:
2113                 case SVt_NV:
2114                 case SVt_RV:
2115                 case SVt_PV:
2116                 case SVt_PVIV:
2117                 case SVt_PVNV:
2118                 case SVt_PVBM:  s = "SCALAR";                   break;
2119                 case SVt_PVLV:  s = "LVALUE";                   break;
2120                 case SVt_PVAV:  s = "ARRAY";                    break;
2121                 case SVt_PVHV:  s = "HASH";                     break;
2122                 case SVt_PVCV:  s = "CODE";                     break;
2123                 case SVt_PVGV:  s = "GLOB";                     break;
2124                 case SVt_PVFM:  s = "FORMAT";                   break;
2125                 case SVt_PVIO:  s = "IO";                       break;
2126                 default:        s = "UNKNOWN";                  break;
2127                 }
2128                 tsv = NEWSV(0,0);
2129                 if (SvOBJECT(sv))
2130                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2131                 else
2132                     sv_setpv(tsv, s);
2133                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2134                 goto tokensaveref;
2135             }
2136             *lp = strlen(s);
2137             return s;
2138         }
2139         if (SvREADONLY(sv) && !SvOK(sv)) {
2140             dTHR;
2141             if (ckWARN(WARN_UNINITIALIZED))
2142                 report_uninit();
2143             *lp = 0;
2144             return "";
2145         }
2146     }
2147     if (SvNOKp(sv)) {                   /* See note in sv_2uv() */
2148         /* XXXX 64-bit?  IV may have better precision... */
2149         /* I tried changing this for to be 64-bit-aware and
2150          * the t/op/numconvert.t became very, very, angry.
2151          * --jhi Sep 1999 */
2152         if (SvTYPE(sv) < SVt_PVNV)
2153             sv_upgrade(sv, SVt_PVNV);
2154         SvGROW(sv, 28);
2155         s = SvPVX(sv);
2156         olderrno = errno;       /* some Xenix systems wipe out errno here */
2157 #ifdef apollo
2158         if (SvNVX(sv) == 0.0)
2159             (void)strcpy(s,"0");
2160         else
2161 #endif /*apollo*/
2162         {
2163             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2164         }
2165         errno = olderrno;
2166 #ifdef FIXNEGATIVEZERO
2167         if (*s == '-' && s[1] == '0' && !s[2])
2168             strcpy(s,"0");
2169 #endif
2170         while (*s) s++;
2171 #ifdef hcx
2172         if (s[-1] == '.')
2173             *--s = '\0';
2174 #endif
2175     }
2176     else if (SvIOKp(sv)) {
2177         U32 isIOK = SvIOK(sv);
2178         U32 isUIOK = SvIsUV(sv);
2179         char buf[TYPE_CHARS(UV)];
2180         char *ebuf, *ptr;
2181
2182         if (SvTYPE(sv) < SVt_PVIV)
2183             sv_upgrade(sv, SVt_PVIV);
2184         if (isUIOK)
2185             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2186         else
2187             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2188         SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
2189         Move(ptr,SvPVX(sv),ebuf - ptr,char);
2190         SvCUR_set(sv, ebuf - ptr);
2191         s = SvEND(sv);
2192         *s = '\0';
2193         if (isIOK)
2194             SvIOK_on(sv);
2195         else
2196             SvIOKp_on(sv);
2197         if (isUIOK)
2198             SvIsUV_on(sv);
2199         SvPOK_on(sv);
2200     }
2201     else {
2202         dTHR;
2203         if (ckWARN(WARN_UNINITIALIZED)
2204             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2205         {
2206             report_uninit();
2207         }
2208         *lp = 0;
2209         if (SvTYPE(sv) < SVt_PV)
2210             /* Typically the caller expects that sv_any is not NULL now.  */
2211             sv_upgrade(sv, SVt_PV);
2212         return "";
2213     }
2214     *lp = s - SvPVX(sv);
2215     SvCUR_set(sv, *lp);
2216     SvPOK_on(sv);
2217     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2218                           PTR2UV(sv),SvPVX(sv)));
2219     return SvPVX(sv);
2220
2221   tokensave:
2222     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
2223         /* Sneaky stuff here */
2224
2225       tokensaveref:
2226         if (!tsv)
2227             tsv = newSVpv(tmpbuf, 0);
2228         sv_2mortal(tsv);
2229         *lp = SvCUR(tsv);
2230         return SvPVX(tsv);
2231     }
2232     else {
2233         STRLEN len;
2234         char *t;
2235
2236         if (tsv) {
2237             sv_2mortal(tsv);
2238             t = SvPVX(tsv);
2239             len = SvCUR(tsv);
2240         }
2241         else {
2242             t = tmpbuf;
2243             len = strlen(tmpbuf);
2244         }
2245 #ifdef FIXNEGATIVEZERO
2246         if (len == 2 && t[0] == '-' && t[1] == '0') {
2247             t = "0";
2248             len = 1;
2249         }
2250 #endif
2251         (void)SvUPGRADE(sv, SVt_PV);
2252         *lp = len;
2253         s = SvGROW(sv, len + 1);
2254         SvCUR_set(sv, len);
2255         (void)strcpy(s, t);
2256         SvPOKp_on(sv);
2257         return s;
2258     }
2259 }
2260
2261 char *
2262 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2263 {
2264     return sv_2pv_nolen(sv);
2265 }
2266
2267 char *
2268 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2269 {
2270     return sv_2pv(sv,lp);
2271 }
2272
2273 char *
2274 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2275 {
2276     return sv_2pv_nolen(sv);
2277 }
2278
2279 char *
2280 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2281 {
2282     return sv_2pv(sv,lp);
2283 }
2284
2285 /* This function is only called on magical items */
2286 bool
2287 Perl_sv_2bool(pTHX_ register SV *sv)
2288 {
2289     if (SvGMAGICAL(sv))
2290         mg_get(sv);
2291
2292     if (!SvOK(sv))
2293         return 0;
2294     if (SvROK(sv)) {
2295         dTHR;
2296         SV* tmpsv;
2297         if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2298             return SvTRUE(tmpsv);
2299       return SvRV(sv) != 0;
2300     }
2301     if (SvPOKp(sv)) {
2302         register XPV* Xpvtmp;
2303         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2304                 (*Xpvtmp->xpv_pv > '0' ||
2305                 Xpvtmp->xpv_cur > 1 ||
2306                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2307             return 1;
2308         else
2309             return 0;
2310     }
2311     else {
2312         if (SvIOKp(sv))
2313             return SvIVX(sv) != 0;
2314         else {
2315             if (SvNOKp(sv))
2316                 return SvNVX(sv) != 0.0;
2317             else
2318                 return FALSE;
2319         }
2320     }
2321 }
2322
2323 /* Note: sv_setsv() should not be called with a source string that needs
2324  * to be reused, since it may destroy the source string if it is marked
2325  * as temporary.
2326  */
2327
2328 void
2329 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2330 {
2331     dTHR;
2332     register U32 sflags;
2333     register int dtype;
2334     register int stype;
2335
2336     if (sstr == dstr)
2337         return;
2338     SV_CHECK_THINKFIRST(dstr);
2339     if (!sstr)
2340         sstr = &PL_sv_undef;
2341     stype = SvTYPE(sstr);
2342     dtype = SvTYPE(dstr);
2343
2344     SvAMAGIC_off(dstr);
2345
2346     /* There's a lot of redundancy below but we're going for speed here */
2347
2348     switch (stype) {
2349     case SVt_NULL:
2350       undef_sstr:
2351         if (dtype != SVt_PVGV) {
2352             (void)SvOK_off(dstr);
2353             return;
2354         }
2355         break;
2356     case SVt_IV:
2357         if (SvIOK(sstr)) {
2358             switch (dtype) {
2359             case SVt_NULL:
2360                 sv_upgrade(dstr, SVt_IV);
2361                 break;
2362             case SVt_NV:
2363                 sv_upgrade(dstr, SVt_PVNV);
2364                 break;
2365             case SVt_RV:
2366             case SVt_PV:
2367                 sv_upgrade(dstr, SVt_PVIV);
2368                 break;
2369             }
2370             (void)SvIOK_only(dstr);
2371             SvIVX(dstr) = SvIVX(sstr);
2372             if (SvIsUV(sstr))
2373                 SvIsUV_on(dstr);
2374             SvTAINT(dstr);
2375             return;
2376         }
2377         goto undef_sstr;
2378
2379     case SVt_NV:
2380         if (SvNOK(sstr)) {
2381             switch (dtype) {
2382             case SVt_NULL:
2383             case SVt_IV:
2384                 sv_upgrade(dstr, SVt_NV);
2385                 break;
2386             case SVt_RV:
2387             case SVt_PV:
2388             case SVt_PVIV:
2389                 sv_upgrade(dstr, SVt_PVNV);
2390                 break;
2391             }
2392             SvNVX(dstr) = SvNVX(sstr);
2393             (void)SvNOK_only(dstr);
2394             SvTAINT(dstr);
2395             return;
2396         }
2397         goto undef_sstr;
2398
2399     case SVt_RV:
2400         if (dtype < SVt_RV)
2401             sv_upgrade(dstr, SVt_RV);
2402         else if (dtype == SVt_PVGV &&
2403                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2404             sstr = SvRV(sstr);
2405             if (sstr == dstr) {
2406                 if (GvIMPORTED(dstr) != GVf_IMPORTED
2407                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2408                 {
2409                     GvIMPORTED_on(dstr);
2410                 }
2411                 GvMULTI_on(dstr);
2412                 return;
2413             }
2414             goto glob_assign;
2415         }
2416         break;
2417     case SVt_PV:
2418     case SVt_PVFM:
2419         if (dtype < SVt_PV)
2420             sv_upgrade(dstr, SVt_PV);
2421         break;
2422     case SVt_PVIV:
2423         if (dtype < SVt_PVIV)
2424             sv_upgrade(dstr, SVt_PVIV);
2425         break;
2426     case SVt_PVNV:
2427         if (dtype < SVt_PVNV)
2428             sv_upgrade(dstr, SVt_PVNV);
2429         break;
2430     case SVt_PVAV:
2431     case SVt_PVHV:
2432     case SVt_PVCV:
2433     case SVt_PVIO:
2434         if (PL_op)
2435             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2436                 PL_op_name[PL_op->op_type]);
2437         else
2438             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2439         break;
2440
2441     case SVt_PVGV:
2442         if (dtype <= SVt_PVGV) {
2443   glob_assign:
2444             if (dtype != SVt_PVGV) {
2445                 char *name = GvNAME(sstr);
2446                 STRLEN len = GvNAMELEN(sstr);
2447                 sv_upgrade(dstr, SVt_PVGV);
2448                 sv_magic(dstr, dstr, '*', name, len);
2449                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2450                 GvNAME(dstr) = savepvn(name, len);
2451                 GvNAMELEN(dstr) = len;
2452                 SvFAKE_on(dstr);        /* can coerce to non-glob */
2453             }
2454             /* ahem, death to those who redefine active sort subs */
2455             else if (PL_curstackinfo->si_type == PERLSI_SORT
2456                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2457                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2458                       GvNAME(dstr));
2459             (void)SvOK_off(dstr);
2460             GvINTRO_off(dstr);          /* one-shot flag */
2461             gp_free((GV*)dstr);
2462             GvGP(dstr) = gp_ref(GvGP(sstr));
2463             SvTAINT(dstr);
2464             if (GvIMPORTED(dstr) != GVf_IMPORTED
2465                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2466             {
2467                 GvIMPORTED_on(dstr);
2468             }
2469             GvMULTI_on(dstr);
2470             return;
2471         }
2472         /* FALL THROUGH */
2473
2474     default:
2475         if (SvGMAGICAL(sstr)) {
2476             mg_get(sstr);
2477             if (SvTYPE(sstr) != stype) {
2478                 stype = SvTYPE(sstr);
2479                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2480                     goto glob_assign;
2481             }
2482         }
2483         if (stype == SVt_PVLV)
2484             (void)SvUPGRADE(dstr, SVt_PVNV);
2485         else
2486             (void)SvUPGRADE(dstr, stype);
2487     }
2488
2489     sflags = SvFLAGS(sstr);
2490
2491     if (sflags & SVf_ROK) {
2492         if (dtype >= SVt_PV) {
2493             if (dtype == SVt_PVGV) {
2494                 SV *sref = SvREFCNT_inc(SvRV(sstr));
2495                 SV *dref = 0;
2496                 int intro = GvINTRO(dstr);
2497
2498                 if (intro) {
2499                     GP *gp;
2500                     gp_free((GV*)dstr);
2501                     GvINTRO_off(dstr);  /* one-shot flag */
2502                     Newz(602,gp, 1, GP);
2503                     GvGP(dstr) = gp_ref(gp);
2504                     GvSV(dstr) = NEWSV(72,0);
2505                     GvLINE(dstr) = CopLINE(PL_curcop);
2506                     GvEGV(dstr) = (GV*)dstr;
2507                 }
2508                 GvMULTI_on(dstr);
2509                 switch (SvTYPE(sref)) {
2510                 case SVt_PVAV:
2511                     if (intro)
2512                         SAVESPTR(GvAV(dstr));
2513                     else
2514                         dref = (SV*)GvAV(dstr);
2515                     GvAV(dstr) = (AV*)sref;
2516                     if (GvIMPORTED_AV_off(dstr)
2517                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2518                     {
2519                         GvIMPORTED_AV_on(dstr);
2520                     }
2521                     break;
2522                 case SVt_PVHV:
2523                     if (intro)
2524                         SAVESPTR(GvHV(dstr));
2525                     else
2526                         dref = (SV*)GvHV(dstr);
2527                     GvHV(dstr) = (HV*)sref;
2528                     if (GvIMPORTED_HV_off(dstr)
2529                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2530                     {
2531                         GvIMPORTED_HV_on(dstr);
2532                     }
2533                     break;
2534                 case SVt_PVCV:
2535                     if (intro) {
2536                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2537                             SvREFCNT_dec(GvCV(dstr));
2538                             GvCV(dstr) = Nullcv;
2539                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2540                             PL_sub_generation++;
2541                         }
2542                         SAVESPTR(GvCV(dstr));
2543                     }
2544                     else
2545                         dref = (SV*)GvCV(dstr);
2546                     if (GvCV(dstr) != (CV*)sref) {
2547                         CV* cv = GvCV(dstr);
2548                         if (cv) {
2549                             if (!GvCVGEN((GV*)dstr) &&
2550                                 (CvROOT(cv) || CvXSUB(cv)))
2551                             {
2552                                 SV *const_sv = cv_const_sv(cv);
2553                                 bool const_changed = TRUE;
2554                                 if(const_sv)
2555                                     const_changed = sv_cmp(const_sv,
2556                                            op_const_sv(CvSTART((CV*)sref),
2557                                                        Nullcv));
2558                                 /* ahem, death to those who redefine
2559                                  * active sort subs */
2560                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2561                                       PL_sortcop == CvSTART(cv))
2562                                     Perl_croak(aTHX_
2563                                     "Can't redefine active sort subroutine %s",
2564                                           GvENAME((GV*)dstr));
2565                                 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2566                                     if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2567                                           && HvNAME(GvSTASH(CvGV(cv)))
2568                                           && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2569                                                    "autouse")))
2570                                         Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2571                                              "Constant subroutine %s redefined"
2572                                              : "Subroutine %s redefined",
2573                                              GvENAME((GV*)dstr));
2574                                 }
2575                             }
2576                             cv_ckproto(cv, (GV*)dstr,
2577                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
2578                         }
2579                         GvCV(dstr) = (CV*)sref;
2580                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2581                         GvASSUMECV_on(dstr);
2582                         PL_sub_generation++;
2583                     }
2584                     if (GvIMPORTED_CV_off(dstr)
2585                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2586                     {
2587                         GvIMPORTED_CV_on(dstr);
2588                     }
2589                     break;
2590                 case SVt_PVIO:
2591                     if (intro)
2592                         SAVESPTR(GvIOp(dstr));
2593                     else
2594                         dref = (SV*)GvIOp(dstr);
2595                     GvIOp(dstr) = (IO*)sref;
2596                     break;
2597                 default:
2598                     if (intro)
2599                         SAVESPTR(GvSV(dstr));
2600                     else
2601                         dref = (SV*)GvSV(dstr);
2602                     GvSV(dstr) = sref;
2603                     if (GvIMPORTED_SV_off(dstr)
2604                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2605                     {
2606                         GvIMPORTED_SV_on(dstr);
2607                     }
2608                     break;
2609                 }
2610                 if (dref)
2611                     SvREFCNT_dec(dref);
2612                 if (intro)
2613                     SAVEFREESV(sref);
2614                 SvTAINT(dstr);
2615                 return;
2616             }
2617             if (SvPVX(dstr)) {
2618                 (void)SvOOK_off(dstr);          /* backoff */
2619                 if (SvLEN(dstr))
2620                     Safefree(SvPVX(dstr));
2621                 SvLEN(dstr)=SvCUR(dstr)=0;
2622             }
2623         }
2624         (void)SvOK_off(dstr);
2625         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2626         SvROK_on(dstr);
2627         if (sflags & SVp_NOK) {
2628             SvNOK_on(dstr);
2629             SvNVX(dstr) = SvNVX(sstr);
2630         }
2631         if (sflags & SVp_IOK) {
2632             (void)SvIOK_on(dstr);
2633             SvIVX(dstr) = SvIVX(sstr);
2634             if (SvIsUV(sstr))
2635                 SvIsUV_on(dstr);
2636         }
2637         if (SvAMAGIC(sstr)) {
2638             SvAMAGIC_on(dstr);
2639         }
2640     }
2641     else if (sflags & SVp_POK) {
2642
2643         /*
2644          * Check to see if we can just swipe the string.  If so, it's a
2645          * possible small lose on short strings, but a big win on long ones.
2646          * It might even be a win on short strings if SvPVX(dstr)
2647          * has to be allocated and SvPVX(sstr) has to be freed.
2648          */
2649
2650         if (SvTEMP(sstr) &&             /* slated for free anyway? */
2651             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
2652             !(sflags & SVf_OOK))        /* and not involved in OOK hack? */
2653         {
2654             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
2655                 if (SvOOK(dstr)) {
2656                     SvFLAGS(dstr) &= ~SVf_OOK;
2657                     Safefree(SvPVX(dstr) - SvIVX(dstr));
2658                 }
2659                 else if (SvLEN(dstr))
2660                     Safefree(SvPVX(dstr));
2661             }
2662             (void)SvPOK_only(dstr);
2663             SvPV_set(dstr, SvPVX(sstr));
2664             SvLEN_set(dstr, SvLEN(sstr));
2665             SvCUR_set(dstr, SvCUR(sstr));
2666             SvTEMP_off(dstr);
2667             (void)SvOK_off(sstr);
2668             SvPV_set(sstr, Nullch);
2669             SvLEN_set(sstr, 0);
2670             SvCUR_set(sstr, 0);
2671             SvTEMP_off(sstr);
2672         }
2673         else {                                  /* have to copy actual string */
2674             STRLEN len = SvCUR(sstr);
2675
2676             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
2677             Move(SvPVX(sstr),SvPVX(dstr),len,char);
2678             SvCUR_set(dstr, len);
2679             *SvEND(dstr) = '\0';
2680             (void)SvPOK_only(dstr);
2681         }
2682         if (SvUTF8(sstr))
2683             SvUTF8_on(dstr);
2684         /*SUPPRESS 560*/
2685         if (sflags & SVp_NOK) {
2686             SvNOK_on(dstr);
2687             SvNVX(dstr) = SvNVX(sstr);
2688         }
2689         if (sflags & SVp_IOK) {
2690             (void)SvIOK_on(dstr);
2691             SvIVX(dstr) = SvIVX(sstr);
2692             if (SvIsUV(sstr))
2693                 SvIsUV_on(dstr);
2694         }
2695     }
2696     else if (sflags & SVp_NOK) {
2697         SvNVX(dstr) = SvNVX(sstr);
2698         (void)SvNOK_only(dstr);
2699         if (SvIOK(sstr)) {
2700             (void)SvIOK_on(dstr);
2701             SvIVX(dstr) = SvIVX(sstr);
2702             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
2703             if (SvIsUV(sstr))
2704                 SvIsUV_on(dstr);
2705         }
2706     }
2707     else if (sflags & SVp_IOK) {
2708         (void)SvIOK_only(dstr);
2709         SvIVX(dstr) = SvIVX(sstr);
2710         if (SvIsUV(sstr))
2711             SvIsUV_on(dstr);
2712     }
2713     else {
2714         if (dtype == SVt_PVGV) {
2715             if (ckWARN(WARN_UNSAFE))
2716                 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2717         }
2718         else
2719             (void)SvOK_off(dstr);
2720     }
2721     SvTAINT(dstr);
2722 }
2723
2724 void
2725 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2726 {
2727     sv_setsv(dstr,sstr);
2728     SvSETMAGIC(dstr);
2729 }
2730
2731 void
2732 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2733 {
2734     register char *dptr;
2735     assert(len >= 0);  /* STRLEN is probably unsigned, so this may
2736                           elicit a warning, but it won't hurt. */
2737     SV_CHECK_THINKFIRST(sv);
2738     if (!ptr) {
2739         (void)SvOK_off(sv);
2740         return;
2741     }
2742     (void)SvUPGRADE(sv, SVt_PV);
2743
2744     SvGROW(sv, len + 1);
2745     dptr = SvPVX(sv);
2746     Move(ptr,dptr,len,char);
2747     dptr[len] = '\0';
2748     SvCUR_set(sv, len);
2749     (void)SvPOK_only(sv);               /* validate pointer */
2750     SvTAINT(sv);
2751 }
2752
2753 void
2754 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2755 {
2756     sv_setpvn(sv,ptr,len);
2757     SvSETMAGIC(sv);
2758 }
2759
2760 void
2761 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2762 {
2763     register STRLEN len;
2764
2765     SV_CHECK_THINKFIRST(sv);
2766     if (!ptr) {
2767         (void)SvOK_off(sv);
2768         return;
2769     }
2770     len = strlen(ptr);
2771     (void)SvUPGRADE(sv, SVt_PV);
2772
2773     SvGROW(sv, len + 1);
2774     Move(ptr,SvPVX(sv),len+1,char);
2775     SvCUR_set(sv, len);
2776     (void)SvPOK_only(sv);               /* validate pointer */
2777     SvTAINT(sv);
2778 }
2779
2780 void
2781 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2782 {
2783     sv_setpv(sv,ptr);
2784     SvSETMAGIC(sv);
2785 }
2786
2787 void
2788 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2789 {
2790     SV_CHECK_THINKFIRST(sv);
2791     (void)SvUPGRADE(sv, SVt_PV);
2792     if (!ptr) {
2793         (void)SvOK_off(sv);
2794         return;
2795     }
2796     (void)SvOOK_off(sv);
2797     if (SvPVX(sv) && SvLEN(sv))
2798         Safefree(SvPVX(sv));
2799     Renew(ptr, len+1, char);
2800     SvPVX(sv) = ptr;
2801     SvCUR_set(sv, len);
2802     SvLEN_set(sv, len+1);
2803     *SvEND(sv) = '\0';
2804     (void)SvPOK_only(sv);               /* validate pointer */
2805     SvTAINT(sv);
2806 }
2807
2808 void
2809 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2810 {
2811     sv_usepvn(sv,ptr,len);
2812     SvSETMAGIC(sv);
2813 }
2814
2815 void
2816 Perl_sv_force_normal(pTHX_ register SV *sv)
2817 {
2818     if (SvREADONLY(sv)) {
2819         dTHR;
2820         if (PL_curcop != &PL_compiling)
2821             Perl_croak(aTHX_ PL_no_modify);
2822     }
2823     if (SvROK(sv))
2824         sv_unref(sv);
2825     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2826         sv_unglob(sv);
2827 }
2828
2829 void
2830 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2831
2832
2833 {
2834     register STRLEN delta;
2835
2836     if (!ptr || !SvPOKp(sv))
2837         return;
2838     SV_CHECK_THINKFIRST(sv);
2839     if (SvTYPE(sv) < SVt_PVIV)
2840         sv_upgrade(sv,SVt_PVIV);
2841
2842     if (!SvOOK(sv)) {
2843         if (!SvLEN(sv)) { /* make copy of shared string */
2844             char *pvx = SvPVX(sv);
2845             STRLEN len = SvCUR(sv);
2846             SvGROW(sv, len + 1);
2847             Move(pvx,SvPVX(sv),len,char);
2848             *SvEND(sv) = '\0';
2849         }
2850         SvIVX(sv) = 0;
2851         SvFLAGS(sv) |= SVf_OOK;
2852     }
2853     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2854     delta = ptr - SvPVX(sv);
2855     SvLEN(sv) -= delta;
2856     SvCUR(sv) -= delta;
2857     SvPVX(sv) += delta;
2858     SvIVX(sv) += delta;
2859 }
2860
2861 void
2862 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2863 {
2864     STRLEN tlen;
2865     char *junk;
2866
2867     junk = SvPV_force(sv, tlen);
2868     SvGROW(sv, tlen + len + 1);
2869     if (ptr == junk)
2870         ptr = SvPVX(sv);
2871     Move(ptr,SvPVX(sv)+tlen,len,char);
2872     SvCUR(sv) += len;
2873     *SvEND(sv) = '\0';
2874     (void)SvPOK_only(sv);               /* validate pointer */
2875     SvTAINT(sv);
2876 }
2877
2878 void
2879 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2880 {
2881     sv_catpvn(sv,ptr,len);
2882     SvSETMAGIC(sv);
2883 }
2884
2885 void
2886 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2887 {
2888     char *s;
2889     STRLEN len;
2890     if (!sstr)
2891         return;
2892     if (s = SvPV(sstr, len))
2893         sv_catpvn(dstr,s,len);
2894 }
2895
2896 void
2897 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2898 {
2899     sv_catsv(dstr,sstr);
2900     SvSETMAGIC(dstr);
2901 }
2902
2903 void
2904 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2905 {
2906     register STRLEN len;
2907     STRLEN tlen;
2908     char *junk;
2909
2910     if (!ptr)
2911         return;
2912     junk = SvPV_force(sv, tlen);
2913     len = strlen(ptr);
2914     SvGROW(sv, tlen + len + 1);
2915     if (ptr == junk)
2916         ptr = SvPVX(sv);
2917     Move(ptr,SvPVX(sv)+tlen,len+1,char);
2918     SvCUR(sv) += len;
2919     (void)SvPOK_only(sv);               /* validate pointer */
2920     SvTAINT(sv);
2921 }
2922
2923 void
2924 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2925 {
2926     sv_catpv(sv,ptr);
2927     SvSETMAGIC(sv);
2928 }
2929
2930 SV *
2931 Perl_newSV(pTHX_ STRLEN len)
2932 {
2933     register SV *sv;
2934
2935     new_SV(sv);
2936     if (len) {
2937         sv_upgrade(sv, SVt_PV);
2938         SvGROW(sv, len + 1);
2939     }
2940     return sv;
2941 }
2942
2943 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2944
2945 void
2946 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2947 {
2948     MAGIC* mg;
2949
2950     if (SvREADONLY(sv)) {
2951         dTHR;
2952         if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2953             Perl_croak(aTHX_ PL_no_modify);
2954     }
2955     if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2956         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2957             if (how == 't')
2958                 mg->mg_len |= 1;
2959             return;
2960         }
2961     }
2962     else {
2963         (void)SvUPGRADE(sv, SVt_PVMG);
2964     }
2965     Newz(702,mg, 1, MAGIC);
2966     mg->mg_moremagic = SvMAGIC(sv);
2967
2968     SvMAGIC(sv) = mg;
2969     if (!obj || obj == sv || how == '#' || how == 'r')
2970         mg->mg_obj = obj;
2971     else {
2972         dTHR;
2973         mg->mg_obj = SvREFCNT_inc(obj);
2974         mg->mg_flags |= MGf_REFCOUNTED;
2975     }
2976     mg->mg_type = how;
2977     mg->mg_len = namlen;
2978     if (name)
2979         if (namlen >= 0)
2980             mg->mg_ptr = savepvn(name, namlen);
2981         else if (namlen == HEf_SVKEY)
2982             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2983
2984     switch (how) {
2985     case 0:
2986         mg->mg_virtual = &PL_vtbl_sv;
2987         break;
2988     case 'A':
2989         mg->mg_virtual = &PL_vtbl_amagic;
2990         break;
2991     case 'a':
2992         mg->mg_virtual = &PL_vtbl_amagicelem;
2993         break;
2994     case 'c':
2995         mg->mg_virtual = 0;
2996         break;
2997     case 'B':
2998         mg->mg_virtual = &PL_vtbl_bm;
2999         break;
3000     case 'D':
3001         mg->mg_virtual = &PL_vtbl_regdata;
3002         break;
3003     case 'd':
3004         mg->mg_virtual = &PL_vtbl_regdatum;
3005         break;
3006     case 'E':
3007         mg->mg_virtual = &PL_vtbl_env;
3008         break;
3009     case 'f':
3010         mg->mg_virtual = &PL_vtbl_fm;
3011         break;
3012     case 'e':
3013         mg->mg_virtual = &PL_vtbl_envelem;
3014         break;
3015     case 'g':
3016         mg->mg_virtual = &PL_vtbl_mglob;
3017         break;
3018     case 'I':
3019         mg->mg_virtual = &PL_vtbl_isa;
3020         break;
3021     case 'i':
3022         mg->mg_virtual = &PL_vtbl_isaelem;
3023         break;
3024     case 'k':
3025         mg->mg_virtual = &PL_vtbl_nkeys;
3026         break;
3027     case 'L':
3028         SvRMAGICAL_on(sv);
3029         mg->mg_virtual = 0;
3030         break;
3031     case 'l':
3032         mg->mg_virtual = &PL_vtbl_dbline;
3033         break;
3034 #ifdef USE_THREADS
3035     case 'm':
3036         mg->mg_virtual = &PL_vtbl_mutex;
3037         break;
3038 #endif /* USE_THREADS */
3039 #ifdef USE_LOCALE_COLLATE
3040     case 'o':
3041         mg->mg_virtual = &PL_vtbl_collxfrm;
3042         break;
3043 #endif /* USE_LOCALE_COLLATE */
3044     case 'P':
3045         mg->mg_virtual = &PL_vtbl_pack;
3046         break;
3047     case 'p':
3048     case 'q':
3049         mg->mg_virtual = &PL_vtbl_packelem;
3050         break;
3051     case 'r':
3052         mg->mg_virtual = &PL_vtbl_regexp;
3053         break;
3054     case 'S':
3055         mg->mg_virtual = &PL_vtbl_sig;
3056         break;
3057     case 's':
3058         mg->mg_virtual = &PL_vtbl_sigelem;
3059         break;
3060     case 't':
3061         mg->mg_virtual = &PL_vtbl_taint;
3062         mg->mg_len = 1;
3063         break;
3064     case 'U':
3065         mg->mg_virtual = &PL_vtbl_uvar;
3066         break;
3067     case 'v':
3068         mg->mg_virtual = &PL_vtbl_vec;
3069         break;
3070     case 'x':
3071         mg->mg_virtual = &PL_vtbl_substr;
3072         break;
3073     case 'y':
3074         mg->mg_virtual = &PL_vtbl_defelem;
3075         break;
3076     case '*':
3077         mg->mg_virtual = &PL_vtbl_glob;
3078         break;
3079     case '#':
3080         mg->mg_virtual = &PL_vtbl_arylen;
3081         break;
3082     case '.':
3083         mg->mg_virtual = &PL_vtbl_pos;
3084         break;
3085     case '<':
3086         mg->mg_virtual = &PL_vtbl_backref;
3087         break;
3088     case '~':   /* Reserved for use by extensions not perl internals.   */
3089         /* Useful for attaching extension internal data to perl vars.   */
3090         /* Note that multiple extensions may clash if magical scalars   */
3091         /* etc holding private data from one are passed to another.     */
3092         SvRMAGICAL_on(sv);
3093         break;
3094     default:
3095         Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3096     }
3097     mg_magical(sv);
3098     if (SvGMAGICAL(sv))
3099         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3100 }
3101
3102 int
3103 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3104 {
3105     MAGIC* mg;
3106     MAGIC** mgp;
3107     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3108         return 0;
3109     mgp = &SvMAGIC(sv);
3110     for (mg = *mgp; mg; mg = *mgp) {
3111         if (mg->mg_type == type) {
3112             MGVTBL* vtbl = mg->mg_virtual;
3113             *mgp = mg->mg_moremagic;
3114             if (vtbl && vtbl->svt_free)
3115                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3116             if (mg->mg_ptr && mg->mg_type != 'g')
3117                 if (mg->mg_len >= 0)
3118                     Safefree(mg->mg_ptr);
3119                 else if (mg->mg_len == HEf_SVKEY)
3120                     SvREFCNT_dec((SV*)mg->mg_ptr);
3121             if (mg->mg_flags & MGf_REFCOUNTED)
3122                 SvREFCNT_dec(mg->mg_obj);
3123             Safefree(mg);
3124         }
3125         else
3126             mgp = &mg->mg_moremagic;
3127     }
3128     if (!SvMAGIC(sv)) {
3129         SvMAGICAL_off(sv);
3130         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3131     }
3132
3133     return 0;
3134 }
3135
3136 SV *
3137 Perl_sv_rvweaken(pTHX_ SV *sv)
3138 {
3139     SV *tsv;
3140     if (!SvOK(sv))  /* let undefs pass */
3141         return sv;
3142     if (!SvROK(sv))
3143         Perl_croak(aTHX_ "Can't weaken a nonreference");
3144     else if (SvWEAKREF(sv)) {
3145         dTHR;
3146         if (ckWARN(WARN_MISC))
3147             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3148         return sv;
3149     }
3150     tsv = SvRV(sv);
3151     sv_add_backref(tsv, sv);
3152     SvWEAKREF_on(sv);
3153     SvREFCNT_dec(tsv);
3154     return sv;
3155 }
3156
3157 STATIC void
3158 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3159 {
3160     AV *av;
3161     MAGIC *mg;
3162     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3163         av = (AV*)mg->mg_obj;
3164     else {
3165         av = newAV();
3166         sv_magic(tsv, (SV*)av, '<', NULL, 0);
3167         SvREFCNT_dec(av);           /* for sv_magic */
3168     }
3169     av_push(av,sv);
3170 }
3171
3172 STATIC void
3173 S_sv_del_backref(pTHX_ SV *sv)
3174 {
3175     AV *av;
3176     SV **svp;
3177     I32 i;
3178     SV *tsv = SvRV(sv);
3179     MAGIC *mg;
3180     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3181         Perl_croak(aTHX_ "panic: del_backref");
3182     av = (AV *)mg->mg_obj;
3183     svp = AvARRAY(av);
3184     i = AvFILLp(av);
3185     while (i >= 0) {
3186         if (svp[i] == sv) {
3187             svp[i] = &PL_sv_undef; /* XXX */
3188         }
3189         i--;
3190     }
3191 }
3192
3193 void
3194 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3195 {
3196     register char *big;
3197     register char *mid;
3198     register char *midend;
3199     register char *bigend;
3200     register I32 i;
3201     STRLEN curlen;
3202
3203
3204     if (!bigstr)
3205         Perl_croak(aTHX_ "Can't modify non-existent substring");
3206     SvPV_force(bigstr, curlen);
3207     if (offset + len > curlen) {
3208         SvGROW(bigstr, offset+len+1);
3209         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3210         SvCUR_set(bigstr, offset+len);
3211     }
3212
3213     SvTAINT(bigstr);
3214     i = littlelen - len;
3215     if (i > 0) {                        /* string might grow */
3216         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3217         mid = big + offset + len;
3218         midend = bigend = big + SvCUR(bigstr);
3219         bigend += i;
3220         *bigend = '\0';
3221         while (midend > mid)            /* shove everything down */
3222             *--bigend = *--midend;
3223         Move(little,big+offset,littlelen,char);
3224         SvCUR(bigstr) += i;
3225         SvSETMAGIC(bigstr);
3226         return;
3227     }
3228     else if (i == 0) {
3229         Move(little,SvPVX(bigstr)+offset,len,char);
3230         SvSETMAGIC(bigstr);
3231         return;
3232     }
3233
3234     big = SvPVX(bigstr);
3235     mid = big + offset;
3236     midend = mid + len;
3237     bigend = big + SvCUR(bigstr);
3238
3239     if (midend > bigend)
3240         Perl_croak(aTHX_ "panic: sv_insert");
3241
3242     if (mid - big > bigend - midend) {  /* faster to shorten from end */
3243         if (littlelen) {
3244             Move(little, mid, littlelen,char);
3245             mid += littlelen;
3246         }
3247         i = bigend - midend;
3248         if (i > 0) {
3249             Move(midend, mid, i,char);
3250             mid += i;
3251         }
3252         *mid = '\0';
3253         SvCUR_set(bigstr, mid - big);
3254     }
3255     /*SUPPRESS 560*/
3256     else if (i = mid - big) {   /* faster from front */
3257         midend -= littlelen;
3258         mid = midend;
3259         sv_chop(bigstr,midend-i);
3260         big += i;
3261         while (i--)
3262             *--midend = *--big;
3263         if (littlelen)
3264             Move(little, mid, littlelen,char);
3265     }
3266     else if (littlelen) {
3267         midend -= littlelen;
3268         sv_chop(bigstr,midend);
3269         Move(little,midend,littlelen,char);
3270     }
3271     else {
3272         sv_chop(bigstr,midend);
3273     }
3274     SvSETMAGIC(bigstr);
3275 }
3276
3277 /* make sv point to what nstr did */
3278
3279 void
3280 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3281 {
3282     dTHR;
3283     U32 refcnt = SvREFCNT(sv);
3284     SV_CHECK_THINKFIRST(sv);
3285     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3286         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3287     if (SvMAGICAL(sv)) {
3288         if (SvMAGICAL(nsv))
3289             mg_free(nsv);
3290         else
3291             sv_upgrade(nsv, SVt_PVMG);
3292         SvMAGIC(nsv) = SvMAGIC(sv);
3293         SvFLAGS(nsv) |= SvMAGICAL(sv);
3294         SvMAGICAL_off(sv);
3295         SvMAGIC(sv) = 0;
3296     }
3297     SvREFCNT(sv) = 0;
3298     sv_clear(sv);
3299     assert(!SvREFCNT(sv));
3300     StructCopy(nsv,sv,SV);
3301     SvREFCNT(sv) = refcnt;
3302     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
3303     del_SV(nsv);
3304 }
3305
3306 void
3307 Perl_sv_clear(pTHX_ register SV *sv)
3308 {
3309     HV* stash;
3310     assert(sv);
3311     assert(SvREFCNT(sv) == 0);
3312
3313     if (SvOBJECT(sv)) {
3314         dTHR;
3315         if (PL_defstash) {              /* Still have a symbol table? */
3316             djSP;
3317             GV* destructor;
3318             SV tmpref;
3319
3320             Zero(&tmpref, 1, SV);
3321             sv_upgrade(&tmpref, SVt_RV);
3322             SvROK_on(&tmpref);
3323             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
3324             SvREFCNT(&tmpref) = 1;
3325
3326             do {
3327                 stash = SvSTASH(sv);
3328                 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3329                 if (destructor) {
3330                     ENTER;
3331                     PUSHSTACKi(PERLSI_DESTROY);
3332                     SvRV(&tmpref) = SvREFCNT_inc(sv);
3333                     EXTEND(SP, 2);
3334                     PUSHMARK(SP);
3335                     PUSHs(&tmpref);
3336                     PUTBACK;
3337                     call_sv((SV*)GvCV(destructor),
3338                             G_DISCARD|G_EVAL|G_KEEPERR);
3339                     SvREFCNT(sv)--;
3340                     POPSTACK;
3341                     SPAGAIN;
3342                     LEAVE;
3343                 }
3344             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3345
3346             del_XRV(SvANY(&tmpref));
3347
3348             if (SvREFCNT(sv)) {
3349                 if (PL_in_clean_objs)
3350                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3351                           HvNAME(stash));
3352                 /* DESTROY gave object new lease on life */
3353                 return;
3354             }
3355         }
3356
3357         if (SvOBJECT(sv)) {
3358             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
3359             SvOBJECT_off(sv);   /* Curse the object. */
3360             if (SvTYPE(sv) != SVt_PVIO)
3361                 --PL_sv_objcount;       /* XXX Might want something more general */
3362         }
3363     }
3364     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3365         mg_free(sv);
3366     stash = NULL;
3367     switch (SvTYPE(sv)) {
3368     case SVt_PVIO:
3369         if (IoIFP(sv) &&
3370             IoIFP(sv) != PerlIO_stdin() &&
3371             IoIFP(sv) != PerlIO_stdout() &&
3372             IoIFP(sv) != PerlIO_stderr())
3373         {
3374             io_close((IO*)sv, FALSE);
3375         }
3376         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3377             PerlDir_close(IoDIRP(sv));
3378         IoDIRP(sv) = (DIR*)NULL;
3379         Safefree(IoTOP_NAME(sv));
3380         Safefree(IoFMT_NAME(sv));
3381         Safefree(IoBOTTOM_NAME(sv));
3382         /* FALL THROUGH */
3383     case SVt_PVBM:
3384         goto freescalar;
3385     case SVt_PVCV:
3386     case SVt_PVFM:
3387         cv_undef((CV*)sv);
3388         goto freescalar;
3389     case SVt_PVHV:
3390         hv_undef((HV*)sv);
3391         break;
3392     case SVt_PVAV:
3393         av_undef((AV*)sv);
3394         break;
3395     case SVt_PVLV:
3396         SvREFCNT_dec(LvTARG(sv));
3397         goto freescalar;
3398     case SVt_PVGV:
3399         gp_free((GV*)sv);
3400         Safefree(GvNAME(sv));
3401         /* cannot decrease stash refcount yet, as we might recursively delete
3402            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3403            of stash until current sv is completely gone.
3404            -- JohnPC, 27 Mar 1998 */
3405         stash = GvSTASH(sv);
3406         /* FALL THROUGH */
3407     case SVt_PVMG:
3408     case SVt_PVNV:
3409     case SVt_PVIV:
3410       freescalar:
3411         (void)SvOOK_off(sv);
3412         /* FALL THROUGH */
3413     case SVt_PV:
3414     case SVt_RV:
3415         if (SvROK(sv)) {
3416             if (SvWEAKREF(sv))
3417                 sv_del_backref(sv);
3418             else
3419                 SvREFCNT_dec(SvRV(sv));
3420         }
3421         else if (SvPVX(sv) && SvLEN(sv))
3422             Safefree(SvPVX(sv));
3423         break;
3424 /*
3425     case SVt_NV:
3426     case SVt_IV:
3427     case SVt_NULL:
3428         break;
3429 */
3430     }
3431
3432     switch (SvTYPE(sv)) {
3433     case SVt_NULL:
3434         break;
3435     case SVt_IV:
3436         del_XIV(SvANY(sv));
3437         break;
3438     case SVt_NV:
3439         del_XNV(SvANY(sv));
3440         break;
3441     case SVt_RV:
3442         del_XRV(SvANY(sv));
3443         break;
3444     case SVt_PV:
3445         del_XPV(SvANY(sv));
3446         break;
3447     case SVt_PVIV:
3448         del_XPVIV(SvANY(sv));
3449         break;
3450     case SVt_PVNV:
3451         del_XPVNV(SvANY(sv));
3452         break;
3453     case SVt_PVMG:
3454         del_XPVMG(SvANY(sv));
3455         break;
3456     case SVt_PVLV:
3457         del_XPVLV(SvANY(sv));
3458         break;
3459     case SVt_PVAV:
3460         del_XPVAV(SvANY(sv));
3461         break;
3462     case SVt_PVHV:
3463         del_XPVHV(SvANY(sv));
3464         break;
3465     case SVt_PVCV:
3466         del_XPVCV(SvANY(sv));
3467         break;
3468     case SVt_PVGV:
3469         del_XPVGV(SvANY(sv));
3470         /* code duplication for increased performance. */
3471         SvFLAGS(sv) &= SVf_BREAK;
3472         SvFLAGS(sv) |= SVTYPEMASK;
3473         /* decrease refcount of the stash that owns this GV, if any */
3474         if (stash)
3475             SvREFCNT_dec(stash);
3476         return; /* not break, SvFLAGS reset already happened */
3477     case SVt_PVBM:
3478         del_XPVBM(SvANY(sv));
3479         break;
3480     case SVt_PVFM:
3481         del_XPVFM(SvANY(sv));
3482         break;
3483     case SVt_PVIO:
3484         del_XPVIO(SvANY(sv));
3485         break;
3486     }
3487     SvFLAGS(sv) &= SVf_BREAK;
3488     SvFLAGS(sv) |= SVTYPEMASK;
3489 }
3490
3491 SV *
3492 Perl_sv_newref(pTHX_ SV *sv)
3493 {
3494     if (sv)
3495         ATOMIC_INC(SvREFCNT(sv));
3496     return sv;
3497 }
3498
3499 void
3500 Perl_sv_free(pTHX_ SV *sv)
3501 {
3502     dTHR;
3503     int refcount_is_zero;
3504
3505     if (!sv)
3506         return;
3507     if (SvREFCNT(sv) == 0) {
3508         if (SvFLAGS(sv) & SVf_BREAK)
3509             return;
3510         if (PL_in_clean_all) /* All is fair */
3511             return;
3512         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3513             /* make sure SvREFCNT(sv)==0 happens very seldom */
3514             SvREFCNT(sv) = (~(U32)0)/2;
3515             return;
3516         }
3517         if (ckWARN_d(WARN_INTERNAL))
3518             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3519         return;
3520     }
3521     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3522     if (!refcount_is_zero)
3523         return;
3524 #ifdef DEBUGGING
3525     if (SvTEMP(sv)) {
3526         if (ckWARN_d(WARN_DEBUGGING))
3527             Perl_warner(aTHX_ WARN_DEBUGGING,
3528                         "Attempt to free temp prematurely: SV 0x%"UVxf,
3529                         PTR2UV(sv));
3530         return;
3531     }
3532 #endif
3533     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3534         /* make sure SvREFCNT(sv)==0 happens very seldom */
3535         SvREFCNT(sv) = (~(U32)0)/2;
3536         return;
3537     }
3538     sv_clear(sv);
3539     if (! SvREFCNT(sv))
3540         del_SV(sv);
3541 }
3542
3543 STRLEN
3544 Perl_sv_len(pTHX_ register SV *sv)
3545 {
3546     char *junk;
3547     STRLEN len;
3548
3549     if (!sv)
3550         return 0;
3551
3552     if (SvGMAGICAL(sv))
3553         len = mg_length(sv);
3554     else
3555         junk = SvPV(sv, len);
3556     return len;
3557 }
3558
3559 STRLEN
3560 Perl_sv_len_utf8(pTHX_ register SV *sv)
3561 {
3562     U8 *s;
3563     U8 *send;
3564     STRLEN len;
3565
3566     if (!sv)
3567         return 0;
3568
3569 #ifdef NOTYET
3570     if (SvGMAGICAL(sv))
3571         len = mg_length(sv);
3572     else
3573 #endif
3574         s = (U8*)SvPV(sv, len);
3575     send = s + len;
3576     len = 0;
3577     while (s < send) {
3578         s += UTF8SKIP(s);
3579         len++;
3580     }
3581     return len;
3582 }
3583
3584 void
3585 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3586 {
3587     U8 *start;
3588     U8 *s;
3589     U8 *send;
3590     I32 uoffset = *offsetp;
3591     STRLEN len;
3592
3593     if (!sv)
3594         return;
3595
3596     start = s = (U8*)SvPV(sv, len);
3597     send = s + len;
3598     while (s < send && uoffset--)
3599         s += UTF8SKIP(s);
3600     if (s >= send)
3601         s = send;
3602     *offsetp = s - start;
3603     if (lenp) {
3604         I32 ulen = *lenp;
3605         start = s;
3606         while (s < send && ulen--)
3607             s += UTF8SKIP(s);
3608         if (s >= send)
3609             s = send;
3610         *lenp = s - start;
3611     }
3612     return;
3613 }
3614
3615 void
3616 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3617 {
3618     U8 *s;
3619     U8 *send;
3620     STRLEN len;
3621
3622     if (!sv)
3623         return;
3624
3625     s = (U8*)SvPV(sv, len);
3626     if (len < *offsetp)
3627         Perl_croak(aTHX_ "panic: bad byte offset");
3628     send = s + *offsetp;
3629     len = 0;
3630     while (s < send) {
3631         s += UTF8SKIP(s);
3632         ++len;
3633     }
3634     if (s != send) {
3635         dTHR;
3636         if (ckWARN_d(WARN_UTF8))
3637             Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3638         --len;
3639     }
3640     *offsetp = len;
3641     return;
3642 }
3643
3644 I32
3645 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3646 {
3647     char *pv1;
3648     STRLEN cur1;
3649     char *pv2;
3650     STRLEN cur2;
3651
3652     if (!str1) {
3653         pv1 = "";
3654         cur1 = 0;
3655     }
3656     else
3657         pv1 = SvPV(str1, cur1);
3658
3659     if (!str2)
3660         return !cur1;
3661     else
3662         pv2 = SvPV(str2, cur2);
3663
3664     if (cur1 != cur2)
3665         return 0;
3666
3667     return memEQ(pv1, pv2, cur1);
3668 }
3669
3670 I32
3671 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3672 {
3673     STRLEN cur1 = 0;
3674     char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3675     STRLEN cur2 = 0;
3676     char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3677     I32 retval;
3678
3679     if (!cur1)
3680         return cur2 ? -1 : 0;
3681
3682     if (!cur2)
3683         return 1;
3684
3685     retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3686
3687     if (retval)
3688         return retval < 0 ? -1 : 1;
3689
3690     if (cur1 == cur2)
3691         return 0;
3692     else
3693         return cur1 < cur2 ? -1 : 1;
3694 }
3695
3696 I32
3697 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3698 {
3699 #ifdef USE_LOCALE_COLLATE
3700
3701     char *pv1, *pv2;
3702     STRLEN len1, len2;
3703     I32 retval;
3704
3705     if (PL_collation_standard)
3706         goto raw_compare;
3707
3708     len1 = 0;
3709     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3710     len2 = 0;
3711     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3712
3713     if (!pv1 || !len1) {
3714         if (pv2 && len2)
3715             return -1;
3716         else
3717             goto raw_compare;
3718     }
3719     else {
3720         if (!pv2 || !len2)
3721             return 1;
3722     }
3723
3724     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3725
3726     if (retval)
3727         return retval < 0 ? -1 : 1;
3728
3729     /*
3730      * When the result of collation is equality, that doesn't mean
3731      * that there are no differences -- some locales exclude some
3732      * characters from consideration.  So to avoid false equalities,
3733      * we use the raw string as a tiebreaker.
3734      */
3735
3736   raw_compare:
3737     /* FALL THROUGH */
3738
3739 #endif /* USE_LOCALE_COLLATE */
3740
3741     return sv_cmp(sv1, sv2);
3742 }
3743
3744 #ifdef USE_LOCALE_COLLATE
3745 /*
3746  * Any scalar variable may carry an 'o' magic that contains the
3747  * scalar data of the variable transformed to such a format that
3748  * a normal memory comparison can be used to compare the data
3749  * according to the locale settings.
3750  */
3751 char *
3752 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3753 {
3754     MAGIC *mg;
3755
3756     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3757     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3758         char *s, *xf;
3759         STRLEN len, xlen;
3760
3761         if (mg)
3762             Safefree(mg->mg_ptr);
3763         s = SvPV(sv, len);
3764         if ((xf = mem_collxfrm(s, len, &xlen))) {
3765             if (SvREADONLY(sv)) {
3766                 SAVEFREEPV(xf);
3767                 *nxp = xlen;
3768                 return xf + sizeof(PL_collation_ix);
3769             }
3770             if (! mg) {
3771                 sv_magic(sv, 0, 'o', 0, 0);
3772                 mg = mg_find(sv, 'o');
3773                 assert(mg);
3774             }
3775             mg->mg_ptr = xf;
3776             mg->mg_len = xlen;
3777         }
3778         else {
3779             if (mg) {
3780                 mg->mg_ptr = NULL;
3781                 mg->mg_len = -1;
3782             }
3783         }
3784     }
3785     if (mg && mg->mg_ptr) {
3786         *nxp = mg->mg_len;
3787         return mg->mg_ptr + sizeof(PL_collation_ix);
3788     }
3789     else {
3790         *nxp = 0;
3791         return NULL;
3792     }
3793 }
3794
3795 #endif /* USE_LOCALE_COLLATE */
3796
3797 char *
3798 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3799 {
3800     dTHR;
3801     char *rsptr;
3802     STRLEN rslen;
3803     register STDCHAR rslast;
3804     register STDCHAR *bp;
3805     register I32 cnt;
3806     I32 i;
3807
3808     SV_CHECK_THINKFIRST(sv);
3809     (void)SvUPGRADE(sv, SVt_PV);
3810
3811     SvSCREAM_off(sv);
3812
3813     if (RsSNARF(PL_rs)) {
3814         rsptr = NULL;
3815         rslen = 0;
3816     }
3817     else if (RsRECORD(PL_rs)) {
3818       I32 recsize, bytesread;
3819       char *buffer;
3820
3821       /* Grab the size of the record we're getting */
3822       recsize = SvIV(SvRV(PL_rs));
3823       (void)SvPOK_only(sv);    /* Validate pointer */
3824       buffer = SvGROW(sv, recsize + 1);
3825       /* Go yank in */
3826 #ifdef VMS
3827       /* VMS wants read instead of fread, because fread doesn't respect */
3828       /* RMS record boundaries. This is not necessarily a good thing to be */
3829       /* doing, but we've got no other real choice */
3830       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3831 #else
3832       bytesread = PerlIO_read(fp, buffer, recsize);
3833 #endif
3834       SvCUR_set(sv, bytesread);
3835       buffer[bytesread] = '\0';
3836       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3837     }
3838     else if (RsPARA(PL_rs)) {
3839         rsptr = "\n\n";
3840         rslen = 2;
3841     }
3842     else
3843         rsptr = SvPV(PL_rs, rslen);
3844     rslast = rslen ? rsptr[rslen - 1] : '\0';
3845
3846     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
3847         do {                    /* to make sure file boundaries work right */
3848             if (PerlIO_eof(fp))
3849                 return 0;
3850             i = PerlIO_getc(fp);
3851             if (i != '\n') {
3852                 if (i == -1)
3853                     return 0;
3854                 PerlIO_ungetc(fp,i);
3855                 break;
3856             }
3857         } while (i != EOF);
3858     }
3859
3860     /* See if we know enough about I/O mechanism to cheat it ! */
3861
3862     /* This used to be #ifdef test - it is made run-time test for ease
3863        of abstracting out stdio interface. One call should be cheap
3864        enough here - and may even be a macro allowing compile
3865        time optimization.
3866      */
3867
3868     if (PerlIO_fast_gets(fp)) {
3869
3870     /*
3871      * We're going to steal some values from the stdio struct
3872      * and put EVERYTHING in the innermost loop into registers.
3873      */
3874     register STDCHAR *ptr;
3875     STRLEN bpx;
3876     I32 shortbuffered;
3877
3878 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3879     /* An ungetc()d char is handled separately from the regular
3880      * buffer, so we getc() it back out and stuff it in the buffer.
3881      */
3882     i = PerlIO_getc(fp);
3883     if (i == EOF) return 0;
3884     *(--((*fp)->_ptr)) = (unsigned char) i;
3885     (*fp)->_cnt++;
3886 #endif
3887
3888     /* Here is some breathtakingly efficient cheating */
3889
3890     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
3891     (void)SvPOK_only(sv);               /* validate pointer */
3892     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3893         if (cnt > 80 && SvLEN(sv) > append) {
3894             shortbuffered = cnt - SvLEN(sv) + append + 1;
3895             cnt -= shortbuffered;
3896         }
3897         else {
3898             shortbuffered = 0;
3899             /* remember that cnt can be negative */
3900             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3901         }
3902     }
3903     else
3904         shortbuffered = 0;
3905     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
3906     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3907     DEBUG_P(PerlIO_printf(Perl_debug_log,
3908         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3909     DEBUG_P(PerlIO_printf(Perl_debug_log,
3910         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3911                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3912                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3913     for (;;) {
3914       screamer:
3915         if (cnt > 0) {
3916             if (rslen) {
3917                 while (cnt > 0) {                    /* this     |  eat */
3918                     cnt--;
3919                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
3920                         goto thats_all_folks;        /* screams  |  sed :-) */
3921                 }
3922             }
3923             else {
3924                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
3925                 bp += cnt;                           /* screams  |  dust */
3926                 ptr += cnt;                          /* louder   |  sed :-) */
3927                 cnt = 0;
3928             }
3929         }
3930
3931         if (shortbuffered) {            /* oh well, must extend */
3932             cnt = shortbuffered;
3933             shortbuffered = 0;
3934             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3935             SvCUR_set(sv, bpx);
3936             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3937             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3938             continue;
3939         }
3940
3941         DEBUG_P(PerlIO_printf(Perl_debug_log,
3942                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3943                               PTR2UV(ptr),(long)cnt));
3944         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3945         DEBUG_P(PerlIO_printf(Perl_debug_log,
3946             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3947             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3948             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3949         /* This used to call 'filbuf' in stdio form, but as that behaves like
3950            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3951            another abstraction.  */
3952         i   = PerlIO_getc(fp);          /* get more characters */
3953         DEBUG_P(PerlIO_printf(Perl_debug_log,
3954             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3955             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3956             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3957         cnt = PerlIO_get_cnt(fp);
3958         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
3959         DEBUG_P(PerlIO_printf(Perl_debug_log,
3960             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3961
3962         if (i == EOF)                   /* all done for ever? */
3963             goto thats_really_all_folks;
3964
3965         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3966         SvCUR_set(sv, bpx);
3967         SvGROW(sv, bpx + cnt + 2);
3968         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3969
3970         *bp++ = i;                      /* store character from PerlIO_getc */
3971
3972         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
3973             goto thats_all_folks;
3974     }
3975
3976 thats_all_folks:
3977     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3978           memNE((char*)bp - rslen, rsptr, rslen))
3979         goto screamer;                          /* go back to the fray */
3980 thats_really_all_folks:
3981     if (shortbuffered)
3982         cnt += shortbuffered;
3983         DEBUG_P(PerlIO_printf(Perl_debug_log,
3984             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3985     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
3986     DEBUG_P(PerlIO_printf(Perl_debug_log,
3987         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3988         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3989         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3990     *bp = '\0';
3991     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
3992     DEBUG_P(PerlIO_printf(Perl_debug_log,
3993         "Screamer: done, len=%ld, string=|%.*s|\n",
3994         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3995     }
3996    else
3997     {
3998 #ifndef EPOC
3999        /*The big, slow, and stupid way */
4000         STDCHAR buf[8192];
4001 #else
4002         /* Need to work around EPOC SDK features          */
4003         /* On WINS: MS VC5 generates calls to _chkstk,    */
4004         /* if a `large' stack frame is allocated          */
4005         /* gcc on MARM does not generate calls like these */
4006         STDCHAR buf[1024];
4007 #endif
4008
4009 screamer2:
4010         if (rslen) {
4011             register STDCHAR *bpe = buf + sizeof(buf);
4012             bp = buf;
4013             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4014                 ; /* keep reading */
4015             cnt = bp - buf;
4016         }
4017         else {
4018             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4019             /* Accomodate broken VAXC compiler, which applies U8 cast to
4020              * both args of ?: operator, causing EOF to change into 255
4021              */
4022             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4023         }
4024
4025         if (append)
4026             sv_catpvn(sv, (char *) buf, cnt);
4027         else
4028             sv_setpvn(sv, (char *) buf, cnt);
4029
4030         if (i != EOF &&                 /* joy */
4031             (!rslen ||
4032              SvCUR(sv) < rslen ||
4033              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4034         {
4035             append = -1;
4036             /*
4037              * If we're reading from a TTY and we get a short read,
4038              * indicating that the user hit his EOF character, we need
4039              * to notice it now, because if we try to read from the TTY
4040              * again, the EOF condition will disappear.
4041              *
4042              * The comparison of cnt to sizeof(buf) is an optimization
4043              * that prevents unnecessary calls to feof().
4044              *
4045              * - jik 9/25/96
4046              */
4047             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4048                 goto screamer2;
4049         }
4050     }
4051
4052     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4053         while (i != EOF) {      /* to make sure file boundaries work right */
4054             i = PerlIO_getc(fp);
4055             if (i != '\n') {
4056                 PerlIO_ungetc(fp,i);
4057                 break;
4058             }
4059         }
4060     }
4061
4062     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4063 }
4064
4065
4066 void
4067 Perl_sv_inc(pTHX_ register SV *sv)
4068 {
4069     register char *d;
4070     int flags;
4071
4072     if (!sv)
4073         return;
4074     if (SvGMAGICAL(sv))
4075         mg_get(sv);
4076     if (SvTHINKFIRST(sv)) {
4077         if (SvREADONLY(sv)) {
4078             dTHR;
4079             if (PL_curcop != &PL_compiling)
4080                 Perl_croak(aTHX_ PL_no_modify);
4081         }
4082         if (SvROK(sv)) {
4083             IV i;
4084             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4085                 return;
4086             i = PTR2IV(SvRV(sv));
4087             sv_unref(sv);
4088             sv_setiv(sv, i);
4089         }
4090     }
4091     flags = SvFLAGS(sv);
4092     if (flags & SVp_NOK) {
4093         (void)SvNOK_only(sv);
4094         SvNVX(sv) += 1.0;
4095         return;
4096     }
4097     if (flags & SVp_IOK) {
4098         if (SvIsUV(sv)) {
4099             if (SvUVX(sv) == UV_MAX)
4100                 sv_setnv(sv, (NV)UV_MAX + 1.0);
4101             else
4102                 (void)SvIOK_only_UV(sv);
4103                 ++SvUVX(sv);
4104         } else {
4105             if (SvIVX(sv) == IV_MAX)
4106                 sv_setnv(sv, (NV)IV_MAX + 1.0);
4107             else {
4108                 (void)SvIOK_only(sv);
4109                 ++SvIVX(sv);
4110             }
4111         }
4112         return;
4113     }
4114     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4115         if ((flags & SVTYPEMASK) < SVt_PVNV)
4116             sv_upgrade(sv, SVt_NV);
4117         SvNVX(sv) = 1.0;
4118         (void)SvNOK_only(sv);
4119         return;
4120     }
4121     d = SvPVX(sv);
4122     while (isALPHA(*d)) d++;
4123     while (isDIGIT(*d)) d++;
4124     if (*d) {
4125         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
4126         return;
4127     }
4128     d--;
4129     while (d >= SvPVX(sv)) {
4130         if (isDIGIT(*d)) {
4131             if (++*d <= '9')
4132                 return;
4133             *(d--) = '0';
4134         }
4135         else {
4136 #ifdef EBCDIC
4137             /* MKS: The original code here died if letters weren't consecutive.
4138              * at least it didn't have to worry about non-C locales.  The
4139              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4140              * arranged in order (although not consecutively) and that only
4141              * [A-Za-z] are accepted by isALPHA in the C locale.
4142              */
4143             if (*d != 'z' && *d != 'Z') {
4144                 do { ++*d; } while (!isALPHA(*d));
4145                 return;
4146             }
4147             *(d--) -= 'z' - 'a';
4148 #else
4149             ++*d;
4150             if (isALPHA(*d))
4151                 return;
4152             *(d--) -= 'z' - 'a' + 1;
4153 #endif
4154         }
4155     }
4156     /* oh,oh, the number grew */
4157     SvGROW(sv, SvCUR(sv) + 2);
4158     SvCUR(sv)++;
4159     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4160         *d = d[-1];
4161     if (isDIGIT(d[1]))
4162         *d = '1';
4163     else
4164         *d = d[1];
4165 }
4166
4167 void
4168 Perl_sv_dec(pTHX_ register SV *sv)
4169 {
4170     int flags;
4171
4172     if (!sv)
4173         return;
4174     if (SvGMAGICAL(sv))
4175         mg_get(sv);
4176     if (SvTHINKFIRST(sv)) {
4177         if (SvREADONLY(sv)) {
4178             dTHR;
4179             if (PL_curcop != &PL_compiling)
4180                 Perl_croak(aTHX_ PL_no_modify);
4181         }
4182         if (SvROK(sv)) {
4183             IV i;
4184             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4185                 return;
4186             i = PTR2IV(SvRV(sv));
4187             sv_unref(sv);
4188             sv_setiv(sv, i);
4189         }
4190     }
4191     flags = SvFLAGS(sv);
4192     if (flags & SVp_NOK) {
4193         SvNVX(sv) -= 1.0;
4194         (void)SvNOK_only(sv);
4195         return;
4196     }
4197     if (flags & SVp_IOK) {
4198         if (SvIsUV(sv)) {
4199             if (SvUVX(sv) == 0) {
4200                 (void)SvIOK_only(sv);
4201                 SvIVX(sv) = -1;
4202             }
4203             else {
4204                 (void)SvIOK_only_UV(sv);
4205                 --SvUVX(sv);
4206             }
4207         } else {
4208             if (SvIVX(sv) == IV_MIN)
4209                 sv_setnv(sv, (NV)IV_MIN - 1.0);
4210             else {
4211                 (void)SvIOK_only(sv);
4212                 --SvIVX(sv);
4213             }
4214         }
4215         return;
4216     }
4217     if (!(flags & SVp_POK)) {
4218         if ((flags & SVTYPEMASK) < SVt_PVNV)
4219             sv_upgrade(sv, SVt_NV);
4220         SvNVX(sv) = -1.0;
4221         (void)SvNOK_only(sv);
4222         return;
4223     }
4224     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4225 }
4226
4227 /* Make a string that will exist for the duration of the expression
4228  * evaluation.  Actually, it may have to last longer than that, but
4229  * hopefully we won't free it until it has been assigned to a
4230  * permanent location. */
4231
4232 SV *
4233 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4234 {
4235     dTHR;
4236     register SV *sv;
4237
4238     new_SV(sv);
4239     sv_setsv(sv,oldstr);
4240     EXTEND_MORTAL(1);
4241     PL_tmps_stack[++PL_tmps_ix] = sv;
4242     SvTEMP_on(sv);
4243     return sv;
4244 }
4245
4246 SV *
4247 Perl_sv_newmortal(pTHX)
4248 {
4249     dTHR;
4250     register SV *sv;
4251
4252     new_SV(sv);
4253     SvFLAGS(sv) = SVs_TEMP;
4254     EXTEND_MORTAL(1);
4255     PL_tmps_stack[++PL_tmps_ix] = sv;
4256     return sv;
4257 }
4258
4259 /* same thing without the copying */
4260
4261 SV *
4262 Perl_sv_2mortal(pTHX_ register SV *sv)
4263 {
4264     dTHR;
4265     if (!sv)
4266         return sv;
4267     if (SvREADONLY(sv) && SvIMMORTAL(sv))
4268         return sv;
4269     EXTEND_MORTAL(1);
4270     PL_tmps_stack[++PL_tmps_ix] = sv;
4271     SvTEMP_on(sv);
4272     return sv;
4273 }
4274
4275 SV *
4276 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4277 {
4278     register SV *sv;
4279
4280     new_SV(sv);
4281     if (!len)
4282         len = strlen(s);
4283     sv_setpvn(sv,s,len);
4284     return sv;
4285 }
4286
4287 SV *
4288 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4289 {
4290     register SV *sv;
4291
4292     new_SV(sv);
4293     sv_setpvn(sv,s,len);
4294     return sv;
4295 }
4296
4297 #if defined(PERL_IMPLICIT_CONTEXT)
4298 SV *
4299 Perl_newSVpvf_nocontext(const char* pat, ...)
4300 {
4301     dTHX;
4302     register SV *sv;
4303     va_list args;
4304     va_start(args, pat);
4305     sv = vnewSVpvf(pat, &args);
4306     va_end(args);
4307     return sv;
4308 }
4309 #endif
4310
4311 SV *
4312 Perl_newSVpvf(pTHX_ const char* pat, ...)
4313 {
4314     register SV *sv;
4315     va_list args;
4316     va_start(args, pat);
4317     sv = vnewSVpvf(pat, &args);
4318     va_end(args);
4319     return sv;
4320 }
4321
4322 SV *
4323 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4324 {
4325     register SV *sv;
4326     new_SV(sv);
4327     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4328     return sv;
4329 }
4330
4331 SV *
4332 Perl_newSVnv(pTHX_ NV n)
4333 {
4334     register SV *sv;
4335
4336     new_SV(sv);
4337     sv_setnv(sv,n);
4338     return sv;
4339 }
4340
4341 SV *
4342 Perl_newSViv(pTHX_ IV i)
4343 {
4344     register SV *sv;
4345
4346     new_SV(sv);
4347     sv_setiv(sv,i);
4348     return sv;
4349 }
4350
4351 SV *
4352 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4353 {
4354     dTHR;
4355     register SV *sv;
4356
4357     new_SV(sv);
4358     sv_upgrade(sv, SVt_RV);
4359     SvTEMP_off(tmpRef);
4360     SvRV(sv) = tmpRef;
4361     SvROK_on(sv);
4362     return sv;
4363 }
4364
4365 SV *
4366 Perl_newRV(pTHX_ SV *tmpRef)
4367 {
4368     return newRV_noinc(SvREFCNT_inc(tmpRef));
4369 }
4370
4371 /* make an exact duplicate of old */
4372
4373 SV *
4374 Perl_newSVsv(pTHX_ register SV *old)
4375 {
4376     dTHR;
4377     register SV *sv;
4378
4379     if (!old)
4380         return Nullsv;
4381     if (SvTYPE(old) == SVTYPEMASK) {
4382         if (ckWARN_d(WARN_INTERNAL))
4383             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4384         return Nullsv;
4385     }
4386     new_SV(sv);
4387     if (SvTEMP(old)) {
4388         SvTEMP_off(old);
4389         sv_setsv(sv,old);
4390         SvTEMP_on(old);
4391     }
4392     else
4393         sv_setsv(sv,old);
4394     return sv;
4395 }
4396
4397 void
4398 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4399 {
4400     register HE *entry;
4401     register GV *gv;
4402     register SV *sv;
4403     register I32 i;
4404     register PMOP *pm;
4405     register I32 max;
4406     char todo[PERL_UCHAR_MAX+1];
4407
4408     if (!stash)
4409         return;
4410
4411     if (!*s) {          /* reset ?? searches */
4412         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4413             pm->op_pmdynflags &= ~PMdf_USED;
4414         }
4415         return;
4416     }
4417
4418     /* reset variables */
4419
4420     if (!HvARRAY(stash))
4421         return;
4422
4423     Zero(todo, 256, char);
4424     while (*s) {
4425         i = (unsigned char)*s;
4426         if (s[1] == '-') {
4427             s += 2;
4428         }
4429         max = (unsigned char)*s++;
4430         for ( ; i <= max; i++) {
4431             todo[i] = 1;
4432         }
4433         for (i = 0; i <= (I32) HvMAX(stash); i++) {
4434             for (entry = HvARRAY(stash)[i];
4435                  entry;
4436                  entry = HeNEXT(entry))
4437             {
4438                 if (!todo[(U8)*HeKEY(entry)])
4439                     continue;
4440                 gv = (GV*)HeVAL(entry);
4441                 sv = GvSV(gv);
4442                 if (SvTHINKFIRST(sv)) {
4443                     if (!SvREADONLY(sv) && SvROK(sv))
4444                         sv_unref(sv);
4445                     continue;
4446                 }
4447                 (void)SvOK_off(sv);
4448                 if (SvTYPE(sv) >= SVt_PV) {
4449                     SvCUR_set(sv, 0);
4450                     if (SvPVX(sv) != Nullch)
4451                         *SvPVX(sv) = '\0';
4452                     SvTAINT(sv);
4453                 }
4454                 if (GvAV(gv)) {
4455                     av_clear(GvAV(gv));
4456                 }
4457                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4458                     hv_clear(GvHV(gv));
4459 #ifndef VMS  /* VMS has no environ array */
4460                     if (gv == PL_envgv)
4461                         environ[0] = Nullch;
4462 #endif
4463                 }
4464             }
4465         }
4466     }
4467 }
4468
4469 IO*
4470 Perl_sv_2io(pTHX_ SV *sv)
4471 {
4472     IO* io;
4473     GV* gv;
4474     STRLEN n_a;
4475
4476     switch (SvTYPE(sv)) {
4477     case SVt_PVIO:
4478         io = (IO*)sv;
4479         break;
4480     case SVt_PVGV:
4481         gv = (GV*)sv;
4482         io = GvIO(gv);
4483         if (!io)
4484             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4485         break;
4486     default:
4487         if (!SvOK(sv))
4488             Perl_croak(aTHX_ PL_no_usym, "filehandle");
4489         if (SvROK(sv))
4490             return sv_2io(SvRV(sv));
4491         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4492         if (gv)
4493             io = GvIO(gv);
4494         else
4495             io = 0;
4496         if (!io)
4497             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4498         break;
4499     }
4500     return io;
4501 }
4502
4503 CV *
4504 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4505 {
4506     GV *gv;
4507     CV *cv;
4508     STRLEN n_a;
4509
4510     if (!sv)
4511         return *gvp = Nullgv, Nullcv;
4512     switch (SvTYPE(sv)) {
4513     case SVt_PVCV:
4514         *st = CvSTASH(sv);
4515         *gvp = Nullgv;
4516         return (CV*)sv;
4517     case SVt_PVHV:
4518     case SVt_PVAV:
4519         *gvp = Nullgv;
4520         return Nullcv;
4521     case SVt_PVGV:
4522         gv = (GV*)sv;
4523         *gvp = gv;
4524         *st = GvESTASH(gv);
4525         goto fix_gv;
4526
4527     default:
4528         if (SvGMAGICAL(sv))
4529             mg_get(sv);
4530         if (SvROK(sv)) {
4531             dTHR;
4532             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
4533             tryAMAGICunDEREF(to_cv);
4534
4535             sv = SvRV(sv);
4536             if (SvTYPE(sv) == SVt_PVCV) {
4537                 cv = (CV*)sv;
4538                 *gvp = Nullgv;
4539                 *st = CvSTASH(cv);
4540                 return cv;
4541             }
4542             else if(isGV(sv))
4543                 gv = (GV*)sv;
4544             else
4545                 Perl_croak(aTHX_ "Not a subroutine reference");
4546         }
4547         else if (isGV(sv))
4548             gv = (GV*)sv;
4549         else
4550             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4551         *gvp = gv;
4552         if (!gv)
4553             return Nullcv;
4554         *st = GvESTASH(gv);
4555     fix_gv:
4556         if (lref && !GvCVu(gv)) {
4557             SV *tmpsv;
4558             ENTER;
4559             tmpsv = NEWSV(704,0);
4560             gv_efullname3(tmpsv, gv, Nullch);
4561             /* XXX this is probably not what they think they're getting.
4562              * It has the same effect as "sub name;", i.e. just a forward
4563              * declaration! */
4564             newSUB(start_subparse(FALSE, 0),
4565                    newSVOP(OP_CONST, 0, tmpsv),
4566                    Nullop,
4567                    Nullop);
4568             LEAVE;
4569             if (!GvCVu(gv))
4570                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4571         }
4572         return GvCVu(gv);
4573     }
4574 }
4575
4576 I32
4577 Perl_sv_true(pTHX_ register SV *sv)
4578 {
4579     dTHR;
4580     if (!sv)
4581         return 0;
4582     if (SvPOK(sv)) {
4583         register XPV* tXpv;
4584         if ((tXpv = (XPV*)SvANY(sv)) &&
4585                 (*tXpv->xpv_pv > '0' ||
4586                 tXpv->xpv_cur > 1 ||
4587                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4588             return 1;
4589         else
4590             return 0;
4591     }
4592     else {
4593         if (SvIOK(sv))
4594             return SvIVX(sv) != 0;
4595         else {
4596             if (SvNOK(sv))
4597                 return SvNVX(sv) != 0.0;
4598             else
4599                 return sv_2bool(sv);
4600         }
4601     }
4602 }
4603
4604 IV
4605 Perl_sv_iv(pTHX_ register SV *sv)
4606 {
4607     if (SvIOK(sv)) {
4608         if (SvIsUV(sv))
4609             return (IV)SvUVX(sv);
4610         return SvIVX(sv);
4611     }
4612     return sv_2iv(sv);
4613 }
4614
4615 UV
4616 Perl_sv_uv(pTHX_ register SV *sv)
4617 {
4618     if (SvIOK(sv)) {
4619         if (SvIsUV(sv))
4620             return SvUVX(sv);
4621         return (UV)SvIVX(sv);
4622     }
4623     return sv_2uv(sv);
4624 }
4625
4626 NV
4627 Perl_sv_nv(pTHX_ register SV *sv)
4628 {
4629     if (SvNOK(sv))
4630         return SvNVX(sv);
4631     return sv_2nv(sv);
4632 }
4633
4634 char *
4635 Perl_sv_pv(pTHX_ SV *sv)
4636 {
4637     STRLEN n_a;
4638
4639     if (SvPOK(sv))
4640         return SvPVX(sv);
4641
4642     return sv_2pv(sv, &n_a);
4643 }
4644
4645 char *
4646 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4647 {
4648     if (SvPOK(sv)) {
4649         *lp = SvCUR(sv);
4650         return SvPVX(sv);
4651     }
4652     return sv_2pv(sv, lp);
4653 }
4654
4655 char *
4656 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4657 {
4658     char *s;
4659
4660     if (SvTHINKFIRST(sv) && !SvROK(sv))
4661         sv_force_normal(sv);
4662
4663     if (SvPOK(sv)) {
4664         *lp = SvCUR(sv);
4665     }
4666     else {
4667         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4668             dTHR;
4669             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4670                 PL_op_name[PL_op->op_type]);
4671         }
4672         else
4673             s = sv_2pv(sv, lp);
4674         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
4675             STRLEN len = *lp;
4676
4677             if (SvROK(sv))
4678                 sv_unref(sv);
4679             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
4680             SvGROW(sv, len + 1);
4681             Move(s,SvPVX(sv),len,char);
4682             SvCUR_set(sv, len);
4683             *SvEND(sv) = '\0';
4684         }
4685         if (!SvPOK(sv)) {
4686             SvPOK_on(sv);               /* validate pointer */
4687             SvTAINT(sv);
4688             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4689                                   PTR2UV(sv),SvPVX(sv)));
4690         }
4691     }
4692     return SvPVX(sv);
4693 }
4694
4695 char *
4696 Perl_sv_pvbyte(pTHX_ SV *sv)
4697 {
4698     return sv_pv(sv);
4699 }
4700
4701 char *
4702 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
4703 {
4704     return sv_pvn(sv,lp);
4705 }
4706
4707 char *
4708 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
4709 {
4710     return sv_pvn_force(sv,lp);
4711 }
4712
4713 char *
4714 Perl_sv_pvutf8(pTHX_ SV *sv)
4715 {
4716     return sv_pv(sv);
4717 }
4718
4719 char *
4720 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
4721 {
4722     return sv_pvn(sv,lp);
4723 }
4724
4725 char *
4726 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
4727 {
4728     return sv_pvn_force(sv,lp);
4729 }
4730
4731 char *
4732 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4733 {
4734     if (ob && SvOBJECT(sv))
4735         return HvNAME(SvSTASH(sv));
4736     else {
4737         switch (SvTYPE(sv)) {
4738         case SVt_NULL:
4739         case SVt_IV:
4740         case SVt_NV:
4741         case SVt_RV:
4742         case SVt_PV:
4743         case SVt_PVIV:
4744         case SVt_PVNV:
4745         case SVt_PVMG:
4746         case SVt_PVBM:
4747                                 if (SvROK(sv))
4748                                     return "REF";
4749                                 else
4750                                     return "SCALAR";
4751         case SVt_PVLV:          return "LVALUE";
4752         case SVt_PVAV:          return "ARRAY";
4753         case SVt_PVHV:          return "HASH";
4754         case SVt_PVCV:          return "CODE";
4755         case SVt_PVGV:          return "GLOB";
4756         case SVt_PVFM:          return "FORMAT";
4757         default:                return "UNKNOWN";
4758         }
4759     }
4760 }
4761
4762 int
4763 Perl_sv_isobject(pTHX_ SV *sv)
4764 {
4765     if (!sv)
4766         return 0;
4767     if (SvGMAGICAL(sv))
4768         mg_get(sv);
4769     if (!SvROK(sv))
4770         return 0;
4771     sv = (SV*)SvRV(sv);
4772     if (!SvOBJECT(sv))
4773         return 0;
4774     return 1;
4775 }
4776
4777 int
4778 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4779 {
4780     if (!sv)
4781         return 0;
4782     if (SvGMAGICAL(sv))
4783         mg_get(sv);
4784     if (!SvROK(sv))
4785         return 0;
4786     sv = (SV*)SvRV(sv);
4787     if (!SvOBJECT(sv))
4788         return 0;
4789
4790     return strEQ(HvNAME(SvSTASH(sv)), name);
4791 }
4792
4793 SV*
4794 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4795 {
4796     dTHR;
4797     SV *sv;
4798
4799     new_SV(sv);
4800
4801     SV_CHECK_THINKFIRST(rv);
4802     SvAMAGIC_off(rv);
4803
4804     if (SvTYPE(rv) < SVt_RV)
4805       sv_upgrade(rv, SVt_RV);
4806
4807     (void)SvOK_off(rv);
4808     SvRV(rv) = sv;
4809     SvROK_on(rv);
4810
4811     if (classname) {
4812         HV* stash = gv_stashpv(classname, TRUE);
4813         (void)sv_bless(rv, stash);
4814     }
4815     return sv;
4816 }
4817
4818 SV*
4819 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4820 {
4821     if (!pv) {
4822         sv_setsv(rv, &PL_sv_undef);
4823         SvSETMAGIC(rv);
4824     }
4825     else
4826         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4827     return rv;
4828 }
4829
4830 SV*
4831 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4832 {
4833     sv_setiv(newSVrv(rv,classname), iv);
4834     return rv;
4835 }
4836
4837 SV*
4838 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4839 {
4840     sv_setnv(newSVrv(rv,classname), nv);
4841     return rv;
4842 }
4843
4844 SV*
4845 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4846 {
4847     sv_setpvn(newSVrv(rv,classname), pv, n);
4848     return rv;
4849 }
4850
4851 SV*
4852 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4853 {
4854     dTHR;
4855     SV *tmpRef;
4856     if (!SvROK(sv))
4857         Perl_croak(aTHX_ "Can't bless non-reference value");
4858     tmpRef = SvRV(sv);
4859     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4860         if (SvREADONLY(tmpRef))
4861             Perl_croak(aTHX_ PL_no_modify);
4862         if (SvOBJECT(tmpRef)) {
4863             if (SvTYPE(tmpRef) != SVt_PVIO)
4864                 --PL_sv_objcount;
4865             SvREFCNT_dec(SvSTASH(tmpRef));
4866         }
4867     }
4868     SvOBJECT_on(tmpRef);
4869     if (SvTYPE(tmpRef) != SVt_PVIO)
4870         ++PL_sv_objcount;
4871     (void)SvUPGRADE(tmpRef, SVt_PVMG);
4872     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4873
4874     if (Gv_AMG(stash))
4875         SvAMAGIC_on(sv);
4876     else
4877         SvAMAGIC_off(sv);
4878
4879     return sv;
4880 }
4881
4882 STATIC void
4883 S_sv_unglob(pTHX_ SV *sv)
4884 {
4885     assert(SvTYPE(sv) == SVt_PVGV);
4886     SvFAKE_off(sv);
4887     if (GvGP(sv))
4888         gp_free((GV*)sv);
4889     if (GvSTASH(sv)) {
4890         SvREFCNT_dec(GvSTASH(sv));
4891         GvSTASH(sv) = Nullhv;
4892     }
4893     sv_unmagic(sv, '*');
4894     Safefree(GvNAME(sv));
4895     GvMULTI_off(sv);
4896     SvFLAGS(sv) &= ~SVTYPEMASK;
4897     SvFLAGS(sv) |= SVt_PVMG;
4898 }
4899
4900 void
4901 Perl_sv_unref(pTHX_ SV *sv)
4902 {
4903     SV* rv = SvRV(sv);
4904
4905     if (SvWEAKREF(sv)) {
4906         sv_del_backref(sv);
4907         SvWEAKREF_off(sv);
4908         SvRV(sv) = 0;
4909         return;
4910     }
4911     SvRV(sv) = 0;
4912     SvROK_off(sv);
4913     if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4914         SvREFCNT_dec(rv);
4915     else
4916         sv_2mortal(rv);         /* Schedule for freeing later */
4917 }
4918
4919 void
4920 Perl_sv_taint(pTHX_ SV *sv)
4921 {
4922     sv_magic((sv), Nullsv, 't', Nullch, 0);
4923 }
4924
4925 void
4926 Perl_sv_untaint(pTHX_ SV *sv)
4927 {
4928     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4929         MAGIC *mg = mg_find(sv, 't');
4930         if (mg)
4931             mg->mg_len &= ~1;
4932     }
4933 }
4934
4935 bool
4936 Perl_sv_tainted(pTHX_ SV *sv)
4937 {
4938     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4939         MAGIC *mg = mg_find(sv, 't');
4940         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4941             return TRUE;
4942     }
4943     return FALSE;
4944 }
4945
4946 void
4947 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4948 {
4949     char buf[TYPE_CHARS(UV)];
4950     char *ebuf;
4951     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4952
4953     sv_setpvn(sv, ptr, ebuf - ptr);
4954 }
4955
4956
4957 void
4958 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4959 {
4960     char buf[TYPE_CHARS(UV)];
4961     char *ebuf;
4962     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4963
4964     sv_setpvn(sv, ptr, ebuf - ptr);
4965     SvSETMAGIC(sv);
4966 }
4967
4968 #if defined(PERL_IMPLICIT_CONTEXT)
4969 void
4970 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4971 {
4972     dTHX;
4973     va_list args;
4974     va_start(args, pat);
4975     sv_vsetpvf(sv, pat, &args);
4976     va_end(args);
4977 }
4978
4979
4980 void
4981 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4982 {
4983     dTHX;
4984     va_list args;
4985     va_start(args, pat);
4986     sv_vsetpvf_mg(sv, pat, &args);
4987     va_end(args);
4988 }
4989 #endif
4990
4991 void
4992 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4993 {
4994     va_list args;
4995     va_start(args, pat);
4996     sv_vsetpvf(sv, pat, &args);
4997     va_end(args);
4998 }
4999
5000 void
5001 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5002 {
5003     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5004 }
5005
5006 void
5007 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5008 {
5009     va_list args;
5010     va_start(args, pat);
5011     sv_vsetpvf_mg(sv, pat, &args);
5012     va_end(args);
5013 }
5014
5015 void
5016 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5017 {
5018     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5019     SvSETMAGIC(sv);
5020 }
5021
5022 #if defined(PERL_IMPLICIT_CONTEXT)
5023 void
5024 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5025 {
5026     dTHX;
5027     va_list args;
5028     va_start(args, pat);
5029     sv_vcatpvf(sv, pat, &args);
5030     va_end(args);
5031 }
5032
5033 void
5034 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5035 {
5036     dTHX;
5037     va_list args;
5038     va_start(args, pat);
5039     sv_vcatpvf_mg(sv, pat, &args);
5040     va_end(args);
5041 }
5042 #endif
5043
5044 void
5045 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5046 {
5047     va_list args;
5048     va_start(args, pat);
5049     sv_vcatpvf(sv, pat, &args);
5050     va_end(args);
5051 }
5052
5053 void
5054 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5055 {
5056     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5057 }
5058
5059 void
5060 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5061 {
5062     va_list args;
5063     va_start(args, pat);
5064     sv_vcatpvf_mg(sv, pat, &args);
5065     va_end(args);
5066 }
5067
5068 void
5069 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5070 {
5071     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5072     SvSETMAGIC(sv);
5073 }
5074
5075 void
5076 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5077 {
5078     sv_setpvn(sv, "", 0);
5079     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5080 }
5081
5082 void
5083 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5084 {
5085     dTHR;
5086     char *p;
5087     char *q;
5088     char *patend;
5089     STRLEN origlen;
5090     I32 svix = 0;
5091     static char nullstr[] = "(null)";
5092
5093     /* no matter what, this is a string now */
5094     (void)SvPV_force(sv, origlen);
5095
5096     /* special-case "", "%s", and "%_" */
5097     if (patlen == 0)
5098         return;
5099     if (patlen == 2 && pat[0] == '%') {
5100         switch (pat[1]) {
5101         case 's':
5102             if (args) {
5103                 char *s = va_arg(*args, char*);
5104                 sv_catpv(sv, s ? s : nullstr);
5105             }
5106             else if (svix < svmax)
5107                 sv_catsv(sv, *svargs);
5108             return;
5109         case '_':
5110             if (args) {
5111                 sv_catsv(sv, va_arg(*args, SV*));
5112                 return;
5113             }
5114             /* See comment on '_' below */
5115             break;
5116         }
5117     }
5118
5119     patend = (char*)pat + patlen;
5120     for (p = (char*)pat; p < patend; p = q) {
5121         bool alt = FALSE;
5122         bool left = FALSE;
5123         char fill = ' ';
5124         char plus = 0;
5125         char intsize = 0;
5126         STRLEN width = 0;
5127         STRLEN zeros = 0;
5128         bool has_precis = FALSE;
5129         STRLEN precis = 0;
5130
5131         char esignbuf[4];
5132         U8 utf8buf[10];
5133         STRLEN esignlen = 0;
5134
5135         char *eptr = Nullch;
5136         STRLEN elen = 0;
5137         /* Times 4: a decimal digit takes more than 3 binary digits.
5138          * NV_DIG: mantissa takes than many decimal digits.
5139          * Plus 32: Playing safe. */
5140         char ebuf[IV_DIG * 4 + NV_DIG + 32];
5141         /* large enough for "%#.#f" --chip */
5142         /* what about long double NVs? --jhi */
5143         char c;
5144         int i;
5145         unsigned base;
5146         IV iv;
5147         UV uv;
5148         NV nv;
5149         STRLEN have;
5150         STRLEN need;
5151         STRLEN gap;
5152
5153         for (q = p; q < patend && *q != '%'; ++q) ;
5154         if (q > p) {
5155             sv_catpvn(sv, p, q - p);
5156             p = q;
5157         }
5158         if (q++ >= patend)
5159             break;
5160
5161         /* FLAGS */
5162
5163         while (*q) {
5164             switch (*q) {
5165             case ' ':
5166             case '+':
5167                 plus = *q++;
5168                 continue;
5169
5170             case '-':
5171                 left = TRUE;
5172                 q++;
5173                 continue;
5174
5175             case '0':
5176                 fill = *q++;
5177                 continue;
5178
5179             case '#':
5180                 alt = TRUE;
5181                 q++;
5182                 continue;
5183
5184             default:
5185                 break;
5186             }
5187             break;
5188         }
5189
5190         /* WIDTH */
5191
5192         switch (*q) {
5193         case '1': case '2': case '3':
5194         case '4': case '5': case '6':
5195         case '7': case '8': case '9':
5196             width = 0;
5197             while (isDIGIT(*q))
5198                 width = width * 10 + (*q++ - '0');
5199             break;
5200
5201         case '*':
5202             if (args)
5203                 i = va_arg(*args, int);
5204             else
5205                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5206             left |= (i < 0);
5207             width = (i < 0) ? -i : i;
5208             q++;
5209             break;
5210         }
5211
5212         /* PRECISION */
5213
5214         if (*q == '.') {
5215             q++;
5216             if (*q == '*') {
5217                 if (args)
5218                     i = va_arg(*args, int);
5219                 else
5220                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5221                 precis = (i < 0) ? 0 : i;
5222                 q++;
5223             }
5224             else {
5225                 precis = 0;
5226                 while (isDIGIT(*q))
5227                     precis = precis * 10 + (*q++ - '0');
5228             }
5229             has_precis = TRUE;
5230         }
5231
5232         /* SIZE */
5233
5234         switch (*q) {
5235 #ifdef HAS_QUAD
5236         case 'L':                       /* Ld */
5237         case 'q':                       /* qd */
5238             intsize = 'q';
5239             q++;
5240             break;
5241 #endif
5242         case 'l':
5243 #ifdef HAS_QUAD
5244              if (*(q + 1) == 'l') {     /* lld */
5245                 intsize = 'q';
5246                 q += 2;
5247                 break;
5248              }
5249 #endif
5250             /* FALL THROUGH */
5251         case 'h':
5252             /* FALL THROUGH */
5253         case 'V':
5254             intsize = *q++;
5255             break;
5256         }
5257
5258         /* CONVERSION */
5259
5260         switch (c = *q++) {
5261
5262             /* STRINGS */
5263
5264         case '%':
5265             eptr = q - 1;
5266             elen = 1;
5267             goto string;
5268
5269         case 'c':
5270             if (IN_UTF8) {
5271                 if (args)
5272                     uv = va_arg(*args, int);
5273                 else
5274                     uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5275
5276                 eptr = (char*)utf8buf;
5277                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5278                 goto string;
5279             }
5280             if (args)
5281                 c = va_arg(*args, int);
5282             else
5283                 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5284             eptr = &c;
5285             elen = 1;
5286             goto string;
5287
5288         case 's':
5289             if (args) {
5290                 eptr = va_arg(*args, char*);
5291                 if (eptr)
5292 #ifdef MACOS_TRADITIONAL
5293                   /* On MacOS, %#s format is used for Pascal strings */
5294                   if (alt)
5295                     elen = *eptr++;
5296                   else
5297 #endif
5298                     elen = strlen(eptr);
5299                 else {
5300                     eptr = nullstr;
5301                     elen = sizeof nullstr - 1;
5302                 }
5303             }
5304             else if (svix < svmax) {
5305                 eptr = SvPVx(svargs[svix++], elen);
5306                 if (IN_UTF8) {
5307                     if (has_precis && precis < elen) {
5308                         I32 p = precis;
5309                         sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5310                         precis = p;
5311                     }
5312                     if (width) { /* fudge width (can't fudge elen) */
5313                         width += elen - sv_len_utf8(svargs[svix - 1]);
5314                     }
5315                 }
5316             }
5317             goto string;
5318
5319         case '_':
5320             /*
5321              * The "%_" hack might have to be changed someday,
5322              * if ISO or ANSI decide to use '_' for something.
5323              * So we keep it hidden from users' code.
5324              */
5325             if (!args)
5326                 goto unknown;
5327             eptr = SvPVx(va_arg(*args, SV*), elen);
5328
5329         string:
5330             if (has_precis && elen > precis)
5331                 elen = precis;
5332             break;
5333
5334             /* INTEGERS */
5335
5336         case 'p':
5337             if (args)
5338                 uv = PTR2UV(va_arg(*args, void*));
5339             else
5340                 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5341             base = 16;
5342             goto integer;
5343
5344         case 'D':
5345 #ifdef IV_IS_QUAD
5346             intsize = 'q';
5347 #else
5348             intsize = 'l';
5349 #endif
5350             /* FALL THROUGH */
5351         case 'd':
5352         case 'i':
5353             if (args) {
5354                 switch (intsize) {
5355                 case 'h':       iv = (short)va_arg(*args, int); break;
5356                 default:        iv = va_arg(*args, int); break;
5357                 case 'l':       iv = va_arg(*args, long); break;
5358                 case 'V':       iv = va_arg(*args, IV); break;
5359 #ifdef HAS_QUAD
5360                 case 'q':       iv = va_arg(*args, Quad_t); break;
5361 #endif
5362                 }
5363             }
5364             else {
5365                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5366                 switch (intsize) {
5367                 case 'h':       iv = (short)iv; break;
5368                 default:        iv = (int)iv; break;
5369                 case 'l':       iv = (long)iv; break;
5370                 case 'V':       break;
5371 #ifdef HAS_QUAD
5372                 case 'q':       iv = (Quad_t)iv; break;
5373 #endif
5374                 }
5375             }
5376             if (iv >= 0) {
5377                 uv = iv;
5378                 if (plus)
5379                     esignbuf[esignlen++] = plus;
5380             }
5381             else {
5382                 uv = -iv;
5383                 esignbuf[esignlen++] = '-';
5384             }
5385             base = 10;
5386             goto integer;
5387
5388         case 'U':
5389 #ifdef IV_IS_QUAD
5390             intsize = 'q';
5391 #else
5392             intsize = 'l';
5393 #endif
5394             /* FALL THROUGH */
5395         case 'u':
5396             base = 10;
5397             goto uns_integer;
5398
5399         case 'b':
5400             base = 2;
5401             goto uns_integer;
5402
5403         case 'O':
5404 #ifdef IV_IS_QUAD
5405             intsize = 'q';
5406 #else
5407             intsize = 'l';
5408 #endif
5409             /* FALL THROUGH */
5410         case 'o':
5411             base = 8;
5412             goto uns_integer;
5413
5414         case 'X':
5415         case 'x':
5416             base = 16;
5417
5418         uns_integer:
5419             if (args) {
5420                 switch (intsize) {
5421                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
5422                 default:   uv = va_arg(*args, unsigned); break;
5423                 case 'l':  uv = va_arg(*args, unsigned long); break;
5424                 case 'V':  uv = va_arg(*args, UV); break;
5425 #ifdef HAS_QUAD
5426                 case 'q':  uv = va_arg(*args, Quad_t); break;
5427 #endif
5428                 }
5429             }
5430             else {
5431                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5432                 switch (intsize) {
5433                 case 'h':       uv = (unsigned short)uv; break;
5434                 default:        uv = (unsigned)uv; break;
5435                 case 'l':       uv = (unsigned long)uv; break;
5436                 case 'V':       break;
5437 #ifdef HAS_QUAD
5438                 case 'q':       uv = (Quad_t)uv; break;
5439 #endif
5440                 }
5441             }
5442
5443         integer:
5444             eptr = ebuf + sizeof ebuf;
5445             switch (base) {
5446                 unsigned dig;
5447             case 16:
5448                 if (!uv)
5449                     alt = FALSE;
5450                 p = (char*)((c == 'X')
5451                             ? "0123456789ABCDEF" : "0123456789abcdef");
5452                 do {
5453                     dig = uv & 15;
5454                     *--eptr = p[dig];
5455                 } while (uv >>= 4);
5456                 if (alt) {
5457                     esignbuf[esignlen++] = '0';
5458                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
5459                 }
5460                 break;
5461             case 8:
5462                 do {
5463                     dig = uv & 7;
5464                     *--eptr = '0' + dig;
5465                 } while (uv >>= 3);
5466                 if (alt && *eptr != '0')
5467                     *--eptr = '0';
5468                 break;
5469             case 2:
5470                 do {
5471                     dig = uv & 1;
5472                     *--eptr = '0' + dig;
5473                 } while (uv >>= 1);
5474                 if (alt) {
5475                     esignbuf[esignlen++] = '0';
5476                     esignbuf[esignlen++] = 'b';
5477                 }
5478                 break;
5479             default:            /* it had better be ten or less */
5480 #if defined(PERL_Y2KWARN)
5481                 if (ckWARN(WARN_MISC)) {
5482                     STRLEN n;
5483                     char *s = SvPV(sv,n);
5484                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5485                         && (n == 2 || !isDIGIT(s[n-3])))
5486                     {
5487                         Perl_warner(aTHX_ WARN_MISC,
5488                                     "Possible Y2K bug: %%%c %s",
5489                                     c, "format string following '19'");
5490                     }
5491                 }
5492 #endif
5493                 do {
5494                     dig = uv % base;
5495                     *--eptr = '0' + dig;
5496                 } while (uv /= base);
5497                 break;
5498             }
5499             elen = (ebuf + sizeof ebuf) - eptr;
5500             if (has_precis) {
5501                 if (precis > elen)
5502                     zeros = precis - elen;
5503                 else if (precis == 0 && elen == 1 && *eptr == '0')
5504                     elen = 0;
5505             }
5506             break;
5507
5508             /* FLOATING POINT */
5509
5510         case 'F':
5511             c = 'f';            /* maybe %F isn't supported here */
5512             /* FALL THROUGH */
5513         case 'e': case 'E':
5514         case 'f':
5515         case 'g': case 'G':
5516
5517             /* This is evil, but floating point is even more evil */
5518
5519             if (args)
5520                 nv = va_arg(*args, NV);
5521             else
5522                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5523
5524             need = 0;
5525             if (c != 'e' && c != 'E') {
5526                 i = PERL_INT_MIN;
5527                 (void)frexp(nv, &i);
5528                 if (i == PERL_INT_MIN)
5529                     Perl_die(aTHX_ "panic: frexp");
5530                 if (i > 0)
5531                     need = BIT_DIGITS(i);
5532             }
5533             need += has_precis ? precis : 6; /* known default */
5534             if (need < width)
5535                 need = width;
5536
5537             need += 20; /* fudge factor */
5538             if (PL_efloatsize < need) {
5539                 Safefree(PL_efloatbuf);
5540                 PL_efloatsize = need + 20; /* more fudge */
5541                 New(906, PL_efloatbuf, PL_efloatsize, char);
5542                 PL_efloatbuf[0] = '\0';
5543             }
5544
5545             eptr = ebuf + sizeof ebuf;
5546             *--eptr = '\0';
5547             *--eptr = c;
5548 #ifdef USE_LONG_DOUBLE
5549             {
5550                 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5551                 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5552             }
5553 #endif
5554             if (has_precis) {
5555                 base = precis;
5556                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5557                 *--eptr = '.';
5558             }
5559             if (width) {
5560                 base = width;
5561                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5562             }
5563             if (fill == '0')
5564                 *--eptr = fill;
5565             if (left)
5566                 *--eptr = '-';
5567             if (plus)
5568                 *--eptr = plus;
5569             if (alt)
5570                 *--eptr = '#';
5571             *--eptr = '%';
5572
5573             {
5574                 RESTORE_NUMERIC_STANDARD();
5575                 (void)sprintf(PL_efloatbuf, eptr, nv);
5576                 RESTORE_NUMERIC_LOCAL();
5577             }
5578
5579             eptr = PL_efloatbuf;
5580             elen = strlen(PL_efloatbuf);
5581             break;
5582
5583             /* SPECIAL */
5584
5585         case 'n':
5586             i = SvCUR(sv) - origlen;
5587             if (args) {
5588                 switch (intsize) {
5589                 case 'h':       *(va_arg(*args, short*)) = i; break;
5590                 default:        *(va_arg(*args, int*)) = i; break;
5591                 case 'l':       *(va_arg(*args, long*)) = i; break;
5592                 case 'V':       *(va_arg(*args, IV*)) = i; break;
5593 #ifdef HAS_QUAD
5594                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
5595 #endif
5596                 }
5597             }
5598             else if (svix < svmax)
5599                 sv_setuv(svargs[svix++], (UV)i);
5600             continue;   /* not "break" */
5601
5602             /* UNKNOWN */
5603
5604         default:
5605       unknown:
5606             if (!args && ckWARN(WARN_PRINTF) &&
5607                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5608                 SV *msg = sv_newmortal();
5609                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5610                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5611                 if (c) {
5612                     if (isPRINT(c))
5613                         Perl_sv_catpvf(aTHX_ msg,
5614                                        "\"%%%c\"", c & 0xFF);
5615                     else
5616                         Perl_sv_catpvf(aTHX_ msg,
5617                                        "\"%%\\%03"UVof"\"",
5618                                        (UV)c & 0xFF);
5619                 } else
5620                     sv_catpv(msg, "end of string");
5621                 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5622             }
5623
5624             /* output mangled stuff ... */
5625             if (c == '\0')
5626                 --q;
5627             eptr = p;
5628             elen = q - p;
5629
5630             /* ... right here, because formatting flags should not apply */
5631             SvGROW(sv, SvCUR(sv) + elen + 1);
5632             p = SvEND(sv);
5633             memcpy(p, eptr, elen);
5634             p += elen;
5635             *p = '\0';
5636             SvCUR(sv) = p - SvPVX(sv);
5637             continue;   /* not "break" */
5638         }
5639
5640         have = esignlen + zeros + elen;
5641         need = (have > width ? have : width);
5642         gap = need - have;
5643
5644         SvGROW(sv, SvCUR(sv) + need + 1);
5645         p = SvEND(sv);
5646         if (esignlen && fill == '0') {
5647             for (i = 0; i < esignlen; i++)
5648                 *p++ = esignbuf[i];
5649         }
5650         if (gap && !left) {
5651             memset(p, fill, gap);
5652             p += gap;
5653         }
5654         if (esignlen && fill != '0') {
5655             for (i = 0; i < esignlen; i++)
5656                 *p++ = esignbuf[i];
5657         }
5658         if (zeros) {
5659             for (i = zeros; i; i--)
5660                 *p++ = '0';
5661         }
5662         if (elen) {
5663             memcpy(p, eptr, elen);
5664             p += elen;
5665         }
5666         if (gap && left) {
5667             memset(p, ' ', gap);
5668             p += gap;
5669         }
5670         *p = '\0';
5671         SvCUR(sv) = p - SvPVX(sv);
5672     }
5673 }
5674
5675 #if defined(USE_ITHREADS)
5676
5677 #if defined(USE_THREADS)
5678 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
5679 #endif
5680
5681 #ifndef OpREFCNT_inc
5682 #  define OpREFCNT_inc(o)       ((o) ? (++(o)->op_targ, (o)) : Nullop)
5683 #endif
5684
5685 #ifndef GpREFCNT_inc
5686 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
5687 #endif
5688
5689
5690 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
5691 #define av_dup(s)       (AV*)sv_dup((SV*)s)
5692 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5693 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
5694 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5695 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
5696 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5697 #define io_dup(s)       (IO*)sv_dup((SV*)s)
5698 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5699 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
5700 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5701 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
5702 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
5703
5704 REGEXP *
5705 Perl_re_dup(pTHX_ REGEXP *r)
5706 {
5707     /* XXX fix when pmop->op_pmregexp becomes shared */
5708     return ReREFCNT_inc(r);
5709 }
5710
5711 PerlIO *
5712 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5713 {
5714     PerlIO *ret;
5715     if (!fp)
5716         return (PerlIO*)NULL;
5717
5718     /* look for it in the table first */
5719     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
5720     if (ret)
5721         return ret;
5722
5723     /* create anew and remember what it is */
5724     ret = PerlIO_fdupopen(fp);
5725     ptr_table_store(PL_ptr_table, fp, ret);
5726     return ret;
5727 }
5728
5729 DIR *
5730 Perl_dirp_dup(pTHX_ DIR *dp)
5731 {
5732     if (!dp)
5733         return (DIR*)NULL;
5734     /* XXX TODO */
5735     return dp;
5736 }
5737
5738 GP *
5739 Perl_gp_dup(pTHX_ GP *gp)
5740 {
5741     GP *ret;
5742     if (!gp)
5743         return (GP*)NULL;
5744     /* look for it in the table first */
5745     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
5746     if (ret)
5747         return ret;
5748
5749     /* create anew and remember what it is */
5750     Newz(0, ret, 1, GP);
5751     ptr_table_store(PL_ptr_table, gp, ret);
5752
5753     /* clone */
5754     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
5755     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
5756     ret->gp_io          = io_dup_inc(gp->gp_io);
5757     ret->gp_form        = cv_dup_inc(gp->gp_form);
5758     ret->gp_av          = av_dup_inc(gp->gp_av);
5759     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
5760     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
5761     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
5762     ret->gp_cvgen       = gp->gp_cvgen;
5763     ret->gp_flags       = gp->gp_flags;
5764     ret->gp_line        = gp->gp_line;
5765     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
5766     return ret;
5767 }
5768
5769 MAGIC *
5770 Perl_mg_dup(pTHX_ MAGIC *mg)
5771 {
5772     MAGIC *mgret = (MAGIC*)NULL;
5773     MAGIC *mgprev;
5774     if (!mg)
5775         return (MAGIC*)NULL;
5776     /* look for it in the table first */
5777     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
5778     if (mgret)
5779         return mgret;
5780
5781     for (; mg; mg = mg->mg_moremagic) {
5782         MAGIC *nmg;
5783         Newz(0, nmg, 1, MAGIC);
5784         if (!mgret)
5785             mgret = nmg;
5786         else
5787             mgprev->mg_moremagic = nmg;
5788         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
5789         nmg->mg_private = mg->mg_private;
5790         nmg->mg_type    = mg->mg_type;
5791         nmg->mg_flags   = mg->mg_flags;
5792         if (mg->mg_type == 'r') {
5793             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5794         }
5795         else {
5796             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5797                               ? sv_dup_inc(mg->mg_obj)
5798                               : sv_dup(mg->mg_obj);
5799         }
5800         nmg->mg_len     = mg->mg_len;
5801         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
5802         if (mg->mg_ptr && mg->mg_type != 'g') {
5803             if (mg->mg_len >= 0) {
5804                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
5805                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
5806                     AMT *amtp = (AMT*)mg->mg_ptr;
5807                     AMT *namtp = (AMT*)nmg->mg_ptr;
5808                     I32 i;
5809                     for (i = 1; i < NofAMmeth; i++) {
5810                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
5811                     }
5812                 }
5813             }
5814             else if (mg->mg_len == HEf_SVKEY)
5815                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5816         }
5817         mgprev = nmg;
5818     }
5819     return mgret;
5820 }
5821
5822 PTR_TBL_t *
5823 Perl_ptr_table_new(pTHX)
5824 {
5825     PTR_TBL_t *tbl;
5826     Newz(0, tbl, 1, PTR_TBL_t);
5827     tbl->tbl_max        = 511;
5828     tbl->tbl_items      = 0;
5829     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
5830     return tbl;
5831 }
5832
5833 void *
5834 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
5835 {
5836     PTR_TBL_ENT_t *tblent;
5837     UV hash = (UV)sv;
5838     assert(tbl);
5839     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5840     for (; tblent; tblent = tblent->next) {
5841         if (tblent->oldval == sv)
5842             return tblent->newval;
5843     }
5844     return (void*)NULL;
5845 }
5846
5847 void
5848 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
5849 {
5850     PTR_TBL_ENT_t *tblent, **otblent;
5851     /* XXX this may be pessimal on platforms where pointers aren't good
5852      * hash values e.g. if they grow faster in the most significant
5853      * bits */
5854     UV hash = (UV)oldv;
5855     bool i = 1;
5856
5857     assert(tbl);
5858     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5859     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5860         if (tblent->oldval == oldv) {
5861             tblent->newval = newv;
5862             tbl->tbl_items++;
5863             return;
5864         }
5865     }
5866     Newz(0, tblent, 1, PTR_TBL_ENT_t);
5867     tblent->oldval = oldv;
5868     tblent->newval = newv;
5869     tblent->next = *otblent;
5870     *otblent = tblent;
5871     tbl->tbl_items++;
5872     if (i && tbl->tbl_items > tbl->tbl_max)
5873         ptr_table_split(tbl);
5874 }
5875
5876 void
5877 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
5878 {
5879     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
5880     UV oldsize = tbl->tbl_max + 1;
5881     UV newsize = oldsize * 2;
5882     UV i;
5883
5884     Renew(ary, newsize, PTR_TBL_ENT_t*);
5885     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
5886     tbl->tbl_max = --newsize;
5887     tbl->tbl_ary = ary;
5888     for (i=0; i < oldsize; i++, ary++) {
5889         PTR_TBL_ENT_t **curentp, **entp, *ent;
5890         if (!*ary)
5891             continue;
5892         curentp = ary + oldsize;
5893         for (entp = ary, ent = *ary; ent; ent = *entp) {
5894             if ((newsize & (UV)ent->oldval) != i) {
5895                 *entp = ent->next;
5896                 ent->next = *curentp;
5897                 *curentp = ent;
5898                 continue;
5899             }
5900             else
5901                 entp = &ent->next;
5902         }
5903     }
5904 }
5905
5906 #ifdef DEBUGGING
5907 char *PL_watch_pvx;
5908 #endif
5909
5910 SV *
5911 Perl_sv_dup(pTHX_ SV *sstr)
5912 {
5913     U32 sflags;
5914     int dtype;
5915     int stype;
5916     SV *dstr;
5917
5918     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
5919         return Nullsv;
5920     /* look for it in the table first */
5921     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
5922     if (dstr)
5923         return dstr;
5924
5925     /* create anew and remember what it is */
5926     new_SV(dstr);
5927     ptr_table_store(PL_ptr_table, sstr, dstr);
5928
5929     /* clone */
5930     SvFLAGS(dstr)       = SvFLAGS(sstr);
5931     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
5932     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
5933
5934 #ifdef DEBUGGING
5935     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
5936         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
5937                       PL_watch_pvx, SvPVX(sstr));
5938 #endif
5939
5940     switch (SvTYPE(sstr)) {
5941     case SVt_NULL:
5942         SvANY(dstr)     = NULL;
5943         break;
5944     case SVt_IV:
5945         SvANY(dstr)     = new_XIV();
5946         SvIVX(dstr)     = SvIVX(sstr);
5947         break;
5948     case SVt_NV:
5949         SvANY(dstr)     = new_XNV();
5950         SvNVX(dstr)     = SvNVX(sstr);
5951         break;
5952     case SVt_RV:
5953         SvANY(dstr)     = new_XRV();
5954         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
5955         break;
5956     case SVt_PV:
5957         SvANY(dstr)     = new_XPV();
5958         SvCUR(dstr)     = SvCUR(sstr);
5959         SvLEN(dstr)     = SvLEN(sstr);
5960         if (SvROK(sstr))
5961             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5962         else if (SvPVX(sstr) && SvLEN(sstr))
5963             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5964         else
5965             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5966         break;
5967     case SVt_PVIV:
5968         SvANY(dstr)     = new_XPVIV();
5969         SvCUR(dstr)     = SvCUR(sstr);
5970         SvLEN(dstr)     = SvLEN(sstr);
5971         SvIVX(dstr)     = SvIVX(sstr);
5972         if (SvROK(sstr))
5973             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5974         else if (SvPVX(sstr) && SvLEN(sstr))
5975             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5976         else
5977             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5978         break;
5979     case SVt_PVNV:
5980         SvANY(dstr)     = new_XPVNV();
5981         SvCUR(dstr)     = SvCUR(sstr);
5982         SvLEN(dstr)     = SvLEN(sstr);
5983         SvIVX(dstr)     = SvIVX(sstr);
5984         SvNVX(dstr)     = SvNVX(sstr);
5985         if (SvROK(sstr))
5986             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5987         else if (SvPVX(sstr) && SvLEN(sstr))
5988             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5989         else
5990             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5991         break;
5992     case SVt_PVMG:
5993         SvANY(dstr)     = new_XPVMG();
5994         SvCUR(dstr)     = SvCUR(sstr);
5995         SvLEN(dstr)     = SvLEN(sstr);
5996         SvIVX(dstr)     = SvIVX(sstr);
5997         SvNVX(dstr)     = SvNVX(sstr);
5998         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5999         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6000         if (SvROK(sstr))
6001             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6002         else if (SvPVX(sstr) && SvLEN(sstr))
6003             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6004         else
6005             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6006         break;
6007     case SVt_PVBM:
6008         SvANY(dstr)     = new_XPVBM();
6009         SvCUR(dstr)     = SvCUR(sstr);
6010         SvLEN(dstr)     = SvLEN(sstr);
6011         SvIVX(dstr)     = SvIVX(sstr);
6012         SvNVX(dstr)     = SvNVX(sstr);
6013         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6014         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6015         if (SvROK(sstr))
6016             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6017         else if (SvPVX(sstr) && SvLEN(sstr))
6018             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6019         else
6020             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6021         BmRARE(dstr)    = BmRARE(sstr);
6022         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
6023         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6024         break;
6025     case SVt_PVLV:
6026         SvANY(dstr)     = new_XPVLV();
6027         SvCUR(dstr)     = SvCUR(sstr);
6028         SvLEN(dstr)     = SvLEN(sstr);
6029         SvIVX(dstr)     = SvIVX(sstr);
6030         SvNVX(dstr)     = SvNVX(sstr);
6031         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6032         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6033         if (SvROK(sstr))
6034             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6035         else if (SvPVX(sstr) && SvLEN(sstr))
6036             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6037         else
6038             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6039         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
6040         LvTARGLEN(dstr) = LvTARGLEN(sstr);
6041         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
6042         LvTYPE(dstr)    = LvTYPE(sstr);
6043         break;
6044     case SVt_PVGV:
6045         SvANY(dstr)     = new_XPVGV();
6046         SvCUR(dstr)     = SvCUR(sstr);
6047         SvLEN(dstr)     = SvLEN(sstr);
6048         SvIVX(dstr)     = SvIVX(sstr);
6049         SvNVX(dstr)     = SvNVX(sstr);
6050         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6051         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6052         if (SvROK(sstr))
6053             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6054         else if (SvPVX(sstr) && SvLEN(sstr))
6055             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6056         else
6057             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6058         GvNAMELEN(dstr) = GvNAMELEN(sstr);
6059         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6060         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
6061         GvFLAGS(dstr)   = GvFLAGS(sstr);
6062         GvGP(dstr)      = gp_dup(GvGP(sstr));
6063         (void)GpREFCNT_inc(GvGP(dstr));
6064         break;
6065     case SVt_PVIO:
6066         SvANY(dstr)     = new_XPVIO();
6067         SvCUR(dstr)     = SvCUR(sstr);
6068         SvLEN(dstr)     = SvLEN(sstr);
6069         SvIVX(dstr)     = SvIVX(sstr);
6070         SvNVX(dstr)     = SvNVX(sstr);
6071         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6072         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6073         if (SvROK(sstr))
6074             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6075         else if (SvPVX(sstr) && SvLEN(sstr))
6076             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6077         else
6078             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6079         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6080         if (IoOFP(sstr) == IoIFP(sstr))
6081             IoOFP(dstr) = IoIFP(dstr);
6082         else
6083             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6084         /* PL_rsfp_filters entries have fake IoDIRP() */
6085         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6086             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
6087         else
6088             IoDIRP(dstr)        = IoDIRP(sstr);
6089         IoLINES(dstr)           = IoLINES(sstr);
6090         IoPAGE(dstr)            = IoPAGE(sstr);
6091         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
6092         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
6093         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
6094         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
6095         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
6096         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
6097         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
6098         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
6099         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
6100         IoTYPE(dstr)            = IoTYPE(sstr);
6101         IoFLAGS(dstr)           = IoFLAGS(sstr);
6102         break;
6103     case SVt_PVAV:
6104         SvANY(dstr)     = new_XPVAV();
6105         SvCUR(dstr)     = SvCUR(sstr);
6106         SvLEN(dstr)     = SvLEN(sstr);
6107         SvIVX(dstr)     = SvIVX(sstr);
6108         SvNVX(dstr)     = SvNVX(sstr);
6109         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6110         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6111         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6112         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6113         if (AvARRAY((AV*)sstr)) {
6114             SV **dst_ary, **src_ary;
6115             SSize_t items = AvFILLp((AV*)sstr) + 1;
6116
6117             src_ary = AvARRAY((AV*)sstr);
6118             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6119             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6120             SvPVX(dstr) = (char*)dst_ary;
6121             AvALLOC((AV*)dstr) = dst_ary;
6122             if (AvREAL((AV*)sstr)) {
6123                 while (items-- > 0)
6124                     *dst_ary++ = sv_dup_inc(*src_ary++);
6125             }
6126             else {
6127                 while (items-- > 0)
6128                     *dst_ary++ = sv_dup(*src_ary++);
6129             }
6130             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6131             while (items-- > 0) {
6132                 *dst_ary++ = &PL_sv_undef;
6133             }
6134         }
6135         else {
6136             SvPVX(dstr)         = Nullch;
6137             AvALLOC((AV*)dstr)  = (SV**)NULL;
6138         }
6139         break;
6140     case SVt_PVHV:
6141         SvANY(dstr)     = new_XPVHV();
6142         SvCUR(dstr)     = SvCUR(sstr);
6143         SvLEN(dstr)     = SvLEN(sstr);
6144         SvIVX(dstr)     = SvIVX(sstr);
6145         SvNVX(dstr)     = SvNVX(sstr);
6146         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6147         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6148         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
6149         if (HvARRAY((HV*)sstr)) {
6150             HE *entry;
6151             STRLEN i = 0;
6152             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6153             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6154             Newz(0, dxhv->xhv_array,
6155                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6156             while (i <= sxhv->xhv_max) {
6157                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6158                                                     !!HvSHAREKEYS(sstr));
6159                 ++i;
6160             }
6161             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6162         }
6163         else {
6164             SvPVX(dstr)         = Nullch;
6165             HvEITER((HV*)dstr)  = (HE*)NULL;
6166         }
6167         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
6168         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
6169         break;
6170     case SVt_PVFM:
6171         SvANY(dstr)     = new_XPVFM();
6172         FmLINES(dstr)   = FmLINES(sstr);
6173         goto dup_pvcv;
6174         /* NOTREACHED */
6175     case SVt_PVCV:
6176         SvANY(dstr)     = new_XPVCV();
6177 dup_pvcv:
6178         SvCUR(dstr)     = SvCUR(sstr);
6179         SvLEN(dstr)     = SvLEN(sstr);
6180         SvIVX(dstr)     = SvIVX(sstr);
6181         SvNVX(dstr)     = SvNVX(sstr);
6182         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6183         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6184         if (SvPVX(sstr) && SvLEN(sstr))
6185             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6186         else
6187             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6188         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6189         CvSTART(dstr)   = CvSTART(sstr);
6190         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
6191         CvXSUB(dstr)    = CvXSUB(sstr);
6192         CvXSUBANY(dstr) = CvXSUBANY(sstr);
6193         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
6194         CvDEPTH(dstr)   = CvDEPTH(sstr);
6195         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6196             /* XXX padlists are real, but pretend to be not */
6197             AvREAL_on(CvPADLIST(sstr));
6198             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6199             AvREAL_off(CvPADLIST(sstr));
6200             AvREAL_off(CvPADLIST(dstr));
6201         }
6202         else
6203             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6204         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6205         CvFLAGS(dstr)   = CvFLAGS(sstr);
6206         break;
6207     default:
6208         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6209         break;
6210     }
6211
6212     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6213         ++PL_sv_objcount;
6214
6215     return dstr;
6216 }
6217
6218 PERL_CONTEXT *
6219 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6220 {
6221     PERL_CONTEXT *ncxs;
6222
6223     if (!cxs)
6224         return (PERL_CONTEXT*)NULL;
6225
6226     /* look for it in the table first */
6227     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6228     if (ncxs)
6229         return ncxs;
6230
6231     /* create anew and remember what it is */
6232     Newz(56, ncxs, max + 1, PERL_CONTEXT);
6233     ptr_table_store(PL_ptr_table, cxs, ncxs);
6234
6235     while (ix >= 0) {
6236         PERL_CONTEXT *cx = &cxs[ix];
6237         PERL_CONTEXT *ncx = &ncxs[ix];
6238         ncx->cx_type    = cx->cx_type;
6239         if (CxTYPE(cx) == CXt_SUBST) {
6240             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6241         }
6242         else {
6243             ncx->blk_oldsp      = cx->blk_oldsp;
6244             ncx->blk_oldcop     = cx->blk_oldcop;
6245             ncx->blk_oldretsp   = cx->blk_oldretsp;
6246             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
6247             ncx->blk_oldscopesp = cx->blk_oldscopesp;
6248             ncx->blk_oldpm      = cx->blk_oldpm;
6249             ncx->blk_gimme      = cx->blk_gimme;
6250             switch (CxTYPE(cx)) {
6251             case CXt_SUB:
6252                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
6253                                            ? cv_dup_inc(cx->blk_sub.cv)
6254                                            : cv_dup(cx->blk_sub.cv));
6255                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
6256                                            ? av_dup_inc(cx->blk_sub.argarray)
6257                                            : Nullav);
6258                 ncx->blk_sub.savearray  = av_dup(cx->blk_sub.savearray);
6259                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
6260                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6261                 ncx->blk_sub.lval       = cx->blk_sub.lval;
6262                 break;
6263             case CXt_EVAL:
6264                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6265                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6266                 ncx->blk_eval.old_name  = SAVEPV(cx->blk_eval.old_name);
6267                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6268                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
6269                 break;
6270             case CXt_LOOP:
6271                 ncx->blk_loop.label     = cx->blk_loop.label;
6272                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
6273                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
6274                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
6275                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
6276                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
6277                                            ? cx->blk_loop.iterdata
6278                                            : gv_dup((GV*)cx->blk_loop.iterdata));
6279                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
6280                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
6281                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
6282                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
6283                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
6284                 break;
6285             case CXt_FORMAT:
6286                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
6287                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
6288                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
6289                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6290                 break;
6291             case CXt_BLOCK:
6292             case CXt_NULL:
6293                 break;
6294             }
6295         }
6296         --ix;
6297     }
6298     return ncxs;
6299 }
6300
6301 PERL_SI *
6302 Perl_si_dup(pTHX_ PERL_SI *si)
6303 {
6304     PERL_SI *nsi;
6305
6306     if (!si)
6307         return (PERL_SI*)NULL;
6308
6309     /* look for it in the table first */
6310     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6311     if (nsi)
6312         return nsi;
6313
6314     /* create anew and remember what it is */
6315     Newz(56, nsi, 1, PERL_SI);
6316     ptr_table_store(PL_ptr_table, si, nsi);
6317
6318     nsi->si_stack       = av_dup_inc(si->si_stack);
6319     nsi->si_cxix        = si->si_cxix;
6320     nsi->si_cxmax       = si->si_cxmax;
6321     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6322     nsi->si_type        = si->si_type;
6323     nsi->si_prev        = si_dup(si->si_prev);
6324     nsi->si_next        = si_dup(si->si_next);
6325     nsi->si_markoff     = si->si_markoff;
6326
6327     return nsi;
6328 }
6329
6330 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
6331 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
6332 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
6333 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
6334 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
6335 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
6336 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
6337 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
6338 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
6339 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
6340 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
6341 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
6342
6343 /* XXXXX todo */
6344 #define pv_dup_inc(p)   SAVEPV(p)
6345 #define pv_dup(p)       SAVEPV(p)
6346 #define svp_dup_inc(p,pp)       any_dup(p,pp)
6347
6348 void *
6349 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
6350 {
6351     void *ret;
6352
6353     if (!v)
6354         return (void*)NULL;
6355
6356     /* look for it in the table first */
6357     ret = ptr_table_fetch(PL_ptr_table, v);
6358     if (ret)
6359         return ret;
6360
6361     /* see if it is part of the interpreter structure */
6362     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
6363         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
6364     else
6365         ret = v;
6366
6367     return ret;
6368 }
6369
6370 ANY *
6371 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
6372 {
6373     ANY *ss     = proto_perl->Tsavestack;
6374     I32 ix      = proto_perl->Tsavestack_ix;
6375     I32 max     = proto_perl->Tsavestack_max;
6376     ANY *nss;
6377     SV *sv;
6378     GV *gv;
6379     AV *av;
6380     HV *hv;
6381     void* ptr;
6382     int intval;
6383     long longval;
6384     GP *gp;
6385     IV iv;
6386     I32 i;
6387     char *c;
6388     void (*dptr) (void*);
6389     void (*dxptr) (pTHXo_ void*);
6390
6391     Newz(54, nss, max, ANY);
6392
6393     while (ix > 0) {
6394         i = POPINT(ss,ix);
6395         TOPINT(nss,ix) = i;
6396         switch (i) {
6397         case SAVEt_ITEM:                        /* normal string */
6398             sv = (SV*)POPPTR(ss,ix);
6399             TOPPTR(nss,ix) = sv_dup_inc(sv);
6400             sv = (SV*)POPPTR(ss,ix);
6401             TOPPTR(nss,ix) = sv_dup_inc(sv);
6402             break;
6403         case SAVEt_SV:                          /* scalar reference */
6404             sv = (SV*)POPPTR(ss,ix);
6405             TOPPTR(nss,ix) = sv_dup_inc(sv);
6406             gv = (GV*)POPPTR(ss,ix);
6407             TOPPTR(nss,ix) = gv_dup_inc(gv);
6408             break;
6409         case SAVEt_GENERIC_SVREF:               /* generic sv */
6410         case SAVEt_SVREF:                       /* scalar reference */
6411             sv = (SV*)POPPTR(ss,ix);
6412             TOPPTR(nss,ix) = sv_dup_inc(sv);
6413             ptr = POPPTR(ss,ix);
6414             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
6415             break;
6416         case SAVEt_AV:                          /* array reference */
6417             av = (AV*)POPPTR(ss,ix);
6418             TOPPTR(nss,ix) = av_dup_inc(av);
6419             gv = (GV*)POPPTR(ss,ix);
6420             TOPPTR(nss,ix) = gv_dup(gv);
6421             break;
6422         case SAVEt_HV:                          /* hash reference */
6423             hv = (HV*)POPPTR(ss,ix);
6424             TOPPTR(nss,ix) = hv_dup_inc(hv);
6425             gv = (GV*)POPPTR(ss,ix);
6426             TOPPTR(nss,ix) = gv_dup(gv);
6427             break;
6428         case SAVEt_INT:                         /* int reference */
6429             ptr = POPPTR(ss,ix);
6430             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6431             intval = (int)POPINT(ss,ix);
6432             TOPINT(nss,ix) = intval;
6433             break;
6434         case SAVEt_LONG:                        /* long reference */
6435             ptr = POPPTR(ss,ix);
6436             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6437             longval = (long)POPLONG(ss,ix);
6438             TOPLONG(nss,ix) = longval;
6439             break;
6440         case SAVEt_I32:                         /* I32 reference */
6441         case SAVEt_I16:                         /* I16 reference */
6442         case SAVEt_I8:                          /* I8 reference */
6443             ptr = POPPTR(ss,ix);
6444             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6445             i = POPINT(ss,ix);
6446             TOPINT(nss,ix) = i;
6447             break;
6448         case SAVEt_IV:                          /* IV reference */
6449             ptr = POPPTR(ss,ix);
6450             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6451             iv = POPIV(ss,ix);
6452             TOPIV(nss,ix) = iv;
6453             break;
6454         case SAVEt_SPTR:                        /* SV* reference */
6455             ptr = POPPTR(ss,ix);
6456             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6457             sv = (SV*)POPPTR(ss,ix);
6458             TOPPTR(nss,ix) = sv_dup(sv);
6459             break;
6460         case SAVEt_VPTR:                        /* random* reference */
6461             ptr = POPPTR(ss,ix);
6462             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6463             ptr = POPPTR(ss,ix);
6464             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6465             break;
6466         case SAVEt_PPTR:                        /* char* reference */
6467             ptr = POPPTR(ss,ix);
6468             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6469             c = (char*)POPPTR(ss,ix);
6470             TOPPTR(nss,ix) = pv_dup(c);
6471             break;
6472         case SAVEt_HPTR:                        /* HV* reference */
6473             ptr = POPPTR(ss,ix);
6474             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6475             hv = (HV*)POPPTR(ss,ix);
6476             TOPPTR(nss,ix) = hv_dup(hv);
6477             break;
6478         case SAVEt_APTR:                        /* AV* reference */
6479             ptr = POPPTR(ss,ix);
6480             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6481             av = (AV*)POPPTR(ss,ix);
6482             TOPPTR(nss,ix) = av_dup(av);
6483             break;
6484         case SAVEt_NSTAB:
6485             gv = (GV*)POPPTR(ss,ix);
6486             TOPPTR(nss,ix) = gv_dup(gv);
6487             break;
6488         case SAVEt_GP:                          /* scalar reference */
6489             gp = (GP*)POPPTR(ss,ix);
6490             TOPPTR(nss,ix) = gp = gp_dup(gp);
6491             (void)GpREFCNT_inc(gp);
6492             gv = (GV*)POPPTR(ss,ix);
6493             TOPPTR(nss,ix) = gv_dup_inc(c);
6494             c = (char*)POPPTR(ss,ix);
6495             TOPPTR(nss,ix) = pv_dup(c);
6496             iv = POPIV(ss,ix);
6497             TOPIV(nss,ix) = iv;
6498             iv = POPIV(ss,ix);
6499             TOPIV(nss,ix) = iv;
6500             break;
6501         case SAVEt_FREESV:
6502             sv = (SV*)POPPTR(ss,ix);
6503             TOPPTR(nss,ix) = sv_dup_inc(sv);
6504             break;
6505         case SAVEt_FREEOP:
6506             ptr = POPPTR(ss,ix);
6507             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
6508                 /* these are assumed to be refcounted properly */
6509                 switch (((OP*)ptr)->op_type) {
6510                 case OP_LEAVESUB:
6511                 case OP_LEAVESUBLV:
6512                 case OP_LEAVEEVAL:
6513                 case OP_LEAVE:
6514                 case OP_SCOPE:
6515                 case OP_LEAVEWRITE:
6516                     TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6517                     break;
6518                 default:
6519                     TOPPTR(nss,ix) = Nullop;
6520                     break;
6521                 }
6522             }
6523             else
6524                 TOPPTR(nss,ix) = Nullop;
6525             break;
6526         case SAVEt_FREEPV:
6527             c = (char*)POPPTR(ss,ix);
6528             TOPPTR(nss,ix) = pv_dup_inc(c);
6529             break;
6530         case SAVEt_CLEARSV:
6531             longval = POPLONG(ss,ix);
6532             TOPLONG(nss,ix) = longval;
6533             break;
6534         case SAVEt_DELETE:
6535             hv = (HV*)POPPTR(ss,ix);
6536             TOPPTR(nss,ix) = hv_dup_inc(hv);
6537             c = (char*)POPPTR(ss,ix);
6538             TOPPTR(nss,ix) = pv_dup_inc(c);
6539             i = POPINT(ss,ix);
6540             TOPINT(nss,ix) = i;
6541             break;
6542         case SAVEt_DESTRUCTOR:
6543             ptr = POPPTR(ss,ix);
6544             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
6545             dptr = POPDPTR(ss,ix);
6546             TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
6547             break;
6548         case SAVEt_DESTRUCTOR_X:
6549             ptr = POPPTR(ss,ix);
6550             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
6551             dxptr = POPDXPTR(ss,ix);
6552             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
6553             break;
6554         case SAVEt_REGCONTEXT:
6555         case SAVEt_ALLOC:
6556             i = POPINT(ss,ix);
6557             TOPINT(nss,ix) = i;
6558             ix -= i;
6559             break;
6560         case SAVEt_STACK_POS:           /* Position on Perl stack */
6561             i = POPINT(ss,ix);
6562             TOPINT(nss,ix) = i;
6563             break;
6564         case SAVEt_AELEM:               /* array element */
6565             sv = (SV*)POPPTR(ss,ix);
6566             TOPPTR(nss,ix) = sv_dup_inc(sv);
6567             i = POPINT(ss,ix);
6568             TOPINT(nss,ix) = i;
6569             av = (AV*)POPPTR(ss,ix);
6570             TOPPTR(nss,ix) = av_dup_inc(av);
6571             break;
6572         case SAVEt_HELEM:               /* hash element */
6573             sv = (SV*)POPPTR(ss,ix);
6574             TOPPTR(nss,ix) = sv_dup_inc(sv);
6575             sv = (SV*)POPPTR(ss,ix);
6576             TOPPTR(nss,ix) = sv_dup_inc(sv);
6577             hv = (HV*)POPPTR(ss,ix);
6578             TOPPTR(nss,ix) = hv_dup_inc(hv);
6579             break;
6580         case SAVEt_OP:
6581             ptr = POPPTR(ss,ix);
6582             TOPPTR(nss,ix) = ptr;
6583             break;
6584         case SAVEt_HINTS:
6585             i = POPINT(ss,ix);
6586             TOPINT(nss,ix) = i;
6587             break;
6588         default:
6589             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
6590         }
6591     }
6592
6593     return nss;
6594 }
6595
6596 #ifdef PERL_OBJECT
6597 #include "XSUB.h"
6598 #endif
6599
6600 PerlInterpreter *
6601 perl_clone(PerlInterpreter *proto_perl, UV flags)
6602 {
6603 #ifdef PERL_OBJECT
6604     CPerlObj *pPerl = (CPerlObj*)proto_perl;
6605 #endif
6606
6607 #ifdef PERL_IMPLICIT_SYS
6608     return perl_clone_using(proto_perl, flags,
6609                             proto_perl->IMem,
6610                             proto_perl->IMemShared,
6611                             proto_perl->IMemParse,
6612                             proto_perl->IEnv,
6613                             proto_perl->IStdIO,
6614                             proto_perl->ILIO,
6615                             proto_perl->IDir,
6616                             proto_perl->ISock,
6617                             proto_perl->IProc);
6618 }
6619
6620 PerlInterpreter *
6621 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
6622                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
6623                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
6624                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6625                  struct IPerlDir* ipD, struct IPerlSock* ipS,
6626                  struct IPerlProc* ipP)
6627 {
6628     /* XXX many of the string copies here can be optimized if they're
6629      * constants; they need to be allocated as common memory and just
6630      * their pointers copied. */
6631
6632     IV i;
6633     SV *sv;
6634     SV **svp;
6635 #  ifdef PERL_OBJECT
6636     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
6637                                         ipD, ipS, ipP);
6638     PERL_SET_INTERP(pPerl);
6639 #  else         /* !PERL_OBJECT */
6640     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6641     PERL_SET_INTERP(my_perl);
6642
6643 #    ifdef DEBUGGING
6644     memset(my_perl, 0xab, sizeof(PerlInterpreter));
6645     PL_markstack = 0;
6646     PL_scopestack = 0;
6647     PL_savestack = 0;
6648     PL_retstack = 0;
6649 #    else       /* !DEBUGGING */
6650     Zero(my_perl, 1, PerlInterpreter);
6651 #    endif      /* DEBUGGING */
6652
6653     /* host pointers */
6654     PL_Mem              = ipM;
6655     PL_MemShared        = ipMS;
6656     PL_MemParse         = ipMP;
6657     PL_Env              = ipE;
6658     PL_StdIO            = ipStd;
6659     PL_LIO              = ipLIO;
6660     PL_Dir              = ipD;
6661     PL_Sock             = ipS;
6662     PL_Proc             = ipP;
6663 #  endif        /* PERL_OBJECT */
6664 #else           /* !PERL_IMPLICIT_SYS */
6665     IV i;
6666     SV *sv;
6667     SV **svp;
6668     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
6669     PERL_SET_INTERP(my_perl);
6670
6671 #    ifdef DEBUGGING
6672     memset(my_perl, 0xab, sizeof(PerlInterpreter));
6673     PL_markstack = 0;
6674     PL_scopestack = 0;
6675     PL_savestack = 0;
6676     PL_retstack = 0;
6677 #    else       /* !DEBUGGING */
6678     Zero(my_perl, 1, PerlInterpreter);
6679 #    endif      /* DEBUGGING */
6680 #endif          /* PERL_IMPLICIT_SYS */
6681
6682     /* arena roots */
6683     PL_xiv_arenaroot    = NULL;
6684     PL_xiv_root         = NULL;
6685     PL_xnv_root         = NULL;
6686     PL_xrv_root         = NULL;
6687     PL_xpv_root         = NULL;
6688     PL_xpviv_root       = NULL;
6689     PL_xpvnv_root       = NULL;
6690     PL_xpvcv_root       = NULL;
6691     PL_xpvav_root       = NULL;
6692     PL_xpvhv_root       = NULL;
6693     PL_xpvmg_root       = NULL;
6694     PL_xpvlv_root       = NULL;
6695     PL_xpvbm_root       = NULL;
6696     PL_he_root          = NULL;
6697     PL_nice_chunk       = NULL;
6698     PL_nice_chunk_size  = 0;
6699     PL_sv_count         = 0;
6700     PL_sv_objcount      = 0;
6701     PL_sv_root          = Nullsv;
6702     PL_sv_arenaroot     = Nullsv;
6703
6704     PL_debug            = proto_perl->Idebug;
6705
6706     /* create SV map for pointer relocation */
6707     PL_ptr_table = ptr_table_new();
6708
6709     /* initialize these special pointers as early as possible */
6710     SvANY(&PL_sv_undef)         = NULL;
6711     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
6712     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
6713     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
6714
6715 #ifdef PERL_OBJECT
6716     SvUPGRADE(&PL_sv_no, SVt_PVNV);
6717 #else
6718     SvANY(&PL_sv_no)            = new_XPVNV();
6719 #endif
6720     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
6721     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6722     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
6723     SvCUR(&PL_sv_no)            = 0;
6724     SvLEN(&PL_sv_no)            = 1;
6725     SvNVX(&PL_sv_no)            = 0;
6726     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
6727
6728 #ifdef PERL_OBJECT
6729     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
6730 #else
6731     SvANY(&PL_sv_yes)           = new_XPVNV();
6732 #endif
6733     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
6734     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6735     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
6736     SvCUR(&PL_sv_yes)           = 1;
6737     SvLEN(&PL_sv_yes)           = 2;
6738     SvNVX(&PL_sv_yes)           = 1;
6739     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
6740
6741     /* create shared string table */
6742     PL_strtab           = newHV();
6743     HvSHAREKEYS_off(PL_strtab);
6744     hv_ksplit(PL_strtab, 512);
6745     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
6746
6747     PL_compiling                = proto_perl->Icompiling;
6748     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
6749     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
6750     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
6751     if (!specialWARN(PL_compiling.cop_warnings))
6752         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6753     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
6754
6755     /* pseudo environmental stuff */
6756     PL_origargc         = proto_perl->Iorigargc;
6757     i = PL_origargc;
6758     New(0, PL_origargv, i+1, char*);
6759     PL_origargv[i] = '\0';
6760     while (i-- > 0) {
6761         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
6762     }
6763     PL_envgv            = gv_dup(proto_perl->Ienvgv);
6764     PL_incgv            = gv_dup(proto_perl->Iincgv);
6765     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
6766     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
6767     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
6768     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
6769
6770     /* switches */
6771     PL_minus_c          = proto_perl->Iminus_c;
6772     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
6773     PL_localpatches     = proto_perl->Ilocalpatches;
6774     PL_splitstr         = proto_perl->Isplitstr;
6775     PL_preprocess       = proto_perl->Ipreprocess;
6776     PL_minus_n          = proto_perl->Iminus_n;
6777     PL_minus_p          = proto_perl->Iminus_p;
6778     PL_minus_l          = proto_perl->Iminus_l;
6779     PL_minus_a          = proto_perl->Iminus_a;
6780     PL_minus_F          = proto_perl->Iminus_F;
6781     PL_doswitches       = proto_perl->Idoswitches;
6782     PL_dowarn           = proto_perl->Idowarn;
6783     PL_doextract        = proto_perl->Idoextract;
6784     PL_sawampersand     = proto_perl->Isawampersand;
6785     PL_unsafe           = proto_perl->Iunsafe;
6786     PL_inplace          = SAVEPV(proto_perl->Iinplace);
6787     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
6788     PL_perldb           = proto_perl->Iperldb;
6789     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6790
6791     /* magical thingies */
6792     /* XXX time(&PL_basetime) when asked for? */
6793     PL_basetime         = proto_perl->Ibasetime;
6794     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
6795
6796     PL_maxsysfd         = proto_perl->Imaxsysfd;
6797     PL_multiline        = proto_perl->Imultiline;
6798     PL_statusvalue      = proto_perl->Istatusvalue;
6799 #ifdef VMS
6800     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
6801 #endif
6802
6803     /* shortcuts to various I/O objects */
6804     PL_stdingv          = gv_dup(proto_perl->Istdingv);
6805     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
6806     PL_defgv            = gv_dup(proto_perl->Idefgv);
6807     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
6808     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
6809     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
6810
6811     /* shortcuts to regexp stuff */
6812     PL_replgv           = gv_dup(proto_perl->Ireplgv);
6813
6814     /* shortcuts to misc objects */
6815     PL_errgv            = gv_dup(proto_perl->Ierrgv);
6816
6817     /* shortcuts to debugging objects */
6818     PL_DBgv             = gv_dup(proto_perl->IDBgv);
6819     PL_DBline           = gv_dup(proto_perl->IDBline);
6820     PL_DBsub            = gv_dup(proto_perl->IDBsub);
6821     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
6822     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
6823     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
6824     PL_lineary          = av_dup(proto_perl->Ilineary);
6825     PL_dbargs           = av_dup(proto_perl->Idbargs);
6826
6827     /* symbol tables */
6828     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
6829     PL_curstash         = hv_dup(proto_perl->Tcurstash);
6830     PL_debstash         = hv_dup(proto_perl->Idebstash);
6831     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
6832     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
6833
6834     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
6835     PL_endav            = av_dup_inc(proto_perl->Iendav);
6836     PL_stopav           = av_dup_inc(proto_perl->Istopav);
6837     PL_initav           = av_dup_inc(proto_perl->Iinitav);
6838
6839     PL_sub_generation   = proto_perl->Isub_generation;
6840
6841     /* funky return mechanisms */
6842     PL_forkprocess      = proto_perl->Iforkprocess;
6843
6844     /* subprocess state */
6845     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
6846
6847     /* internal state */
6848     PL_tainting         = proto_perl->Itainting;
6849     PL_maxo             = proto_perl->Imaxo;
6850     if (proto_perl->Iop_mask)
6851         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6852     else
6853         PL_op_mask      = Nullch;
6854
6855     /* current interpreter roots */
6856     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
6857     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
6858     PL_main_start       = proto_perl->Imain_start;
6859     PL_eval_root        = OpREFCNT_inc(proto_perl->Ieval_root);
6860     PL_eval_start       = proto_perl->Ieval_start;
6861
6862     /* runtime control stuff */
6863     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
6864     PL_copline          = proto_perl->Icopline;
6865
6866     PL_filemode         = proto_perl->Ifilemode;
6867     PL_lastfd           = proto_perl->Ilastfd;
6868     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
6869     PL_Argv             = NULL;
6870     PL_Cmd              = Nullch;
6871     PL_gensym           = proto_perl->Igensym;
6872     PL_preambled        = proto_perl->Ipreambled;
6873     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
6874     PL_laststatval      = proto_perl->Ilaststatval;
6875     PL_laststype        = proto_perl->Ilaststype;
6876     PL_mess_sv          = Nullsv;
6877
6878     PL_orslen           = proto_perl->Iorslen;
6879     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
6880     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
6881
6882     /* interpreter atexit processing */
6883     PL_exitlistlen      = proto_perl->Iexitlistlen;
6884     if (PL_exitlistlen) {
6885         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6886         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6887     }
6888     else
6889         PL_exitlist     = (PerlExitListEntry*)NULL;
6890     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
6891
6892     PL_profiledata      = NULL;
6893     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
6894     /* PL_rsfp_filters entries have fake IoDIRP() */
6895     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
6896
6897     PL_compcv                   = cv_dup(proto_perl->Icompcv);
6898     PL_comppad                  = av_dup(proto_perl->Icomppad);
6899     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
6900     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
6901     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
6902     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
6903                                                         proto_perl->Tcurpad);
6904
6905 #ifdef HAVE_INTERP_INTERN
6906     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6907 #endif
6908
6909     /* more statics moved here */
6910     PL_generation       = proto_perl->Igeneration;
6911     PL_DBcv             = cv_dup(proto_perl->IDBcv);
6912
6913     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
6914     PL_in_clean_all     = proto_perl->Iin_clean_all;
6915
6916     PL_uid              = proto_perl->Iuid;
6917     PL_euid             = proto_perl->Ieuid;
6918     PL_gid              = proto_perl->Igid;
6919     PL_egid             = proto_perl->Iegid;
6920     PL_nomemok          = proto_perl->Inomemok;
6921     PL_an               = proto_perl->Ian;
6922     PL_cop_seqmax       = proto_perl->Icop_seqmax;
6923     PL_op_seqmax        = proto_perl->Iop_seqmax;
6924     PL_evalseq          = proto_perl->Ievalseq;
6925     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
6926     PL_origalen         = proto_perl->Iorigalen;
6927     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
6928     PL_osname           = SAVEPV(proto_perl->Iosname);
6929     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
6930     PL_sighandlerp      = proto_perl->Isighandlerp;
6931
6932
6933     PL_runops           = proto_perl->Irunops;
6934
6935     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
6936
6937 #ifdef CSH
6938     PL_cshlen           = proto_perl->Icshlen;
6939     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6940 #endif
6941
6942     PL_lex_state        = proto_perl->Ilex_state;
6943     PL_lex_defer        = proto_perl->Ilex_defer;
6944     PL_lex_expect       = proto_perl->Ilex_expect;
6945     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
6946     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
6947     PL_lex_starts       = proto_perl->Ilex_starts;
6948     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
6949     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
6950     PL_lex_op           = proto_perl->Ilex_op;
6951     PL_lex_inpat        = proto_perl->Ilex_inpat;
6952     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
6953     PL_lex_brackets     = proto_perl->Ilex_brackets;
6954     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6955     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
6956     PL_lex_casemods     = proto_perl->Ilex_casemods;
6957     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6958     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
6959
6960     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6961     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6962     PL_nexttoke         = proto_perl->Inexttoke;
6963
6964     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
6965     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6966     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6967     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6968     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6969     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6970     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6971     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6972     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6973     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6974     PL_pending_ident    = proto_perl->Ipending_ident;
6975     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
6976
6977     PL_expect           = proto_perl->Iexpect;
6978
6979     PL_multi_start      = proto_perl->Imulti_start;
6980     PL_multi_end        = proto_perl->Imulti_end;
6981     PL_multi_open       = proto_perl->Imulti_open;
6982     PL_multi_close      = proto_perl->Imulti_close;
6983
6984     PL_error_count      = proto_perl->Ierror_count;
6985     PL_subline          = proto_perl->Isubline;
6986     PL_subname          = sv_dup_inc(proto_perl->Isubname);
6987
6988     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
6989     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
6990     PL_padix                    = proto_perl->Ipadix;
6991     PL_padix_floor              = proto_perl->Ipadix_floor;
6992     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
6993
6994     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6995     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6996     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6997     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6998     PL_last_lop_op      = proto_perl->Ilast_lop_op;
6999     PL_in_my            = proto_perl->Iin_my;
7000     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
7001 #ifdef FCRYPT
7002     PL_cryptseen        = proto_perl->Icryptseen;
7003 #endif
7004
7005     PL_hints            = proto_perl->Ihints;
7006
7007     PL_amagic_generation        = proto_perl->Iamagic_generation;
7008
7009 #ifdef USE_LOCALE_COLLATE
7010     PL_collation_ix     = proto_perl->Icollation_ix;
7011     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
7012     PL_collation_standard       = proto_perl->Icollation_standard;
7013     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
7014     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
7015 #endif /* USE_LOCALE_COLLATE */
7016
7017 #ifdef USE_LOCALE_NUMERIC
7018     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
7019     PL_numeric_standard = proto_perl->Inumeric_standard;
7020     PL_numeric_local    = proto_perl->Inumeric_local;
7021     PL_numeric_radix    = proto_perl->Inumeric_radix;
7022 #endif /* !USE_LOCALE_NUMERIC */
7023
7024     /* utf8 character classes */
7025     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
7026     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
7027     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
7028     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
7029     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
7030     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
7031     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
7032     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
7033     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
7034     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
7035     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
7036     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
7037     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
7038     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
7039     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
7040     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
7041     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
7042
7043     /* swatch cache */
7044     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
7045     PL_last_swash_klen  = 0;
7046     PL_last_swash_key[0]= '\0';
7047     PL_last_swash_tmps  = (U8*)NULL;
7048     PL_last_swash_slen  = 0;
7049
7050     /* perly.c globals */
7051     PL_yydebug          = proto_perl->Iyydebug;
7052     PL_yynerrs          = proto_perl->Iyynerrs;
7053     PL_yyerrflag        = proto_perl->Iyyerrflag;
7054     PL_yychar           = proto_perl->Iyychar;
7055     PL_yyval            = proto_perl->Iyyval;
7056     PL_yylval           = proto_perl->Iyylval;
7057
7058     PL_glob_index       = proto_perl->Iglob_index;
7059     PL_srand_called     = proto_perl->Isrand_called;
7060     PL_uudmap['M']      = 0;            /* reinits on demand */
7061     PL_bitcount         = Nullch;       /* reinits on demand */
7062
7063     if (proto_perl->Ipsig_ptr) {
7064         int sig_num[] = { SIG_NUM };
7065         Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7066         Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7067         for (i = 1; PL_sig_name[i]; i++) {
7068             PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7069             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7070         }
7071     }
7072     else {
7073         PL_psig_ptr     = (SV**)NULL;
7074         PL_psig_name    = (SV**)NULL;
7075     }
7076
7077     /* thrdvar.h stuff */
7078
7079     if (flags & 1) {
7080         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7081         PL_tmps_ix              = proto_perl->Ttmps_ix;
7082         PL_tmps_max             = proto_perl->Ttmps_max;
7083         PL_tmps_floor           = proto_perl->Ttmps_floor;
7084         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7085         i = 0;
7086         while (i <= PL_tmps_ix) {
7087             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7088             ++i;
7089         }
7090
7091         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7092         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7093         Newz(54, PL_markstack, i, I32);
7094         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
7095                                                   - proto_perl->Tmarkstack);
7096         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
7097                                                   - proto_perl->Tmarkstack);
7098         Copy(proto_perl->Tmarkstack, PL_markstack,
7099              PL_markstack_ptr - PL_markstack + 1, I32);
7100
7101         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7102          * NOTE: unlike the others! */
7103         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
7104         PL_scopestack_max       = proto_perl->Tscopestack_max;
7105         Newz(54, PL_scopestack, PL_scopestack_max, I32);
7106         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7107
7108         /* next push_return() sets PL_retstack[PL_retstack_ix]
7109          * NOTE: unlike the others! */
7110         PL_retstack_ix          = proto_perl->Tretstack_ix;
7111         PL_retstack_max         = proto_perl->Tretstack_max;
7112         Newz(54, PL_retstack, PL_retstack_max, OP*);
7113         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7114
7115         /* NOTE: si_dup() looks at PL_markstack */
7116         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
7117
7118         /* PL_curstack          = PL_curstackinfo->si_stack; */
7119         PL_curstack             = av_dup(proto_perl->Tcurstack);
7120         PL_mainstack            = av_dup(proto_perl->Tmainstack);
7121
7122         /* next PUSHs() etc. set *(PL_stack_sp+1) */
7123         PL_stack_base           = AvARRAY(PL_curstack);
7124         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
7125                                                    - proto_perl->Tstack_base);
7126         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
7127
7128         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7129          * NOTE: unlike the others! */
7130         PL_savestack_ix         = proto_perl->Tsavestack_ix;
7131         PL_savestack_max        = proto_perl->Tsavestack_max;
7132         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7133         PL_savestack            = ss_dup(proto_perl);
7134     }
7135     else {
7136         init_stacks();
7137     }
7138
7139     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
7140     PL_top_env          = &PL_start_env;
7141
7142     PL_op               = proto_perl->Top;
7143
7144     PL_Sv               = Nullsv;
7145     PL_Xpv              = (XPV*)NULL;
7146     PL_na               = proto_perl->Tna;
7147
7148     PL_statbuf          = proto_perl->Tstatbuf;
7149     PL_statcache        = proto_perl->Tstatcache;
7150     PL_statgv           = gv_dup(proto_perl->Tstatgv);
7151     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
7152 #ifdef HAS_TIMES
7153     PL_timesbuf         = proto_perl->Ttimesbuf;
7154 #endif
7155
7156     PL_tainted          = proto_perl->Ttainted;
7157     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
7158     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
7159     PL_rs               = sv_dup_inc(proto_perl->Trs);
7160     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
7161     PL_ofslen           = proto_perl->Tofslen;
7162     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7163     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
7164     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
7165     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
7166     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
7167     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
7168
7169     PL_restartop        = proto_perl->Trestartop;
7170     PL_in_eval          = proto_perl->Tin_eval;
7171     PL_delaymagic       = proto_perl->Tdelaymagic;
7172     PL_dirty            = proto_perl->Tdirty;
7173     PL_localizing       = proto_perl->Tlocalizing;
7174
7175     PL_protect          = proto_perl->Tprotect;
7176     PL_errors           = sv_dup_inc(proto_perl->Terrors);
7177     PL_av_fetch_sv      = Nullsv;
7178     PL_hv_fetch_sv      = Nullsv;
7179     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
7180     PL_modcount         = proto_perl->Tmodcount;
7181     PL_lastgotoprobe    = Nullop;
7182     PL_dumpindent       = proto_perl->Tdumpindent;
7183
7184     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7185     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
7186     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
7187     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
7188     PL_sortcxix         = proto_perl->Tsortcxix;
7189     PL_efloatbuf        = Nullch;               /* reinits on demand */
7190     PL_efloatsize       = 0;                    /* reinits on demand */
7191
7192     /* regex stuff */
7193
7194     PL_screamfirst      = NULL;
7195     PL_screamnext       = NULL;
7196     PL_maxscream        = -1;                   /* reinits on demand */
7197     PL_lastscream       = Nullsv;
7198
7199     PL_watchaddr        = NULL;
7200     PL_watchok          = Nullch;
7201
7202     PL_regdummy         = proto_perl->Tregdummy;
7203     PL_regcomp_parse    = Nullch;
7204     PL_regxend          = Nullch;
7205     PL_regcode          = (regnode*)NULL;
7206     PL_regnaughty       = 0;
7207     PL_regsawback       = 0;
7208     PL_regprecomp       = Nullch;
7209     PL_regnpar          = 0;
7210     PL_regsize          = 0;
7211     PL_regflags         = 0;
7212     PL_regseen          = 0;
7213     PL_seen_zerolen     = 0;
7214     PL_seen_evals       = 0;
7215     PL_regcomp_rx       = (regexp*)NULL;
7216     PL_extralen         = 0;
7217     PL_colorset         = 0;            /* reinits PL_colors[] */
7218     /*PL_colors[6]      = {0,0,0,0,0,0};*/
7219     PL_reg_whilem_seen  = 0;
7220     PL_reginput         = Nullch;
7221     PL_regbol           = Nullch;
7222     PL_regeol           = Nullch;
7223     PL_regstartp        = (I32*)NULL;
7224     PL_regendp          = (I32*)NULL;
7225     PL_reglastparen     = (U32*)NULL;
7226     PL_regtill          = Nullch;
7227     PL_regprev          = '\n';
7228     PL_reg_start_tmp    = (char**)NULL;
7229     PL_reg_start_tmpl   = 0;
7230     PL_regdata          = (struct reg_data*)NULL;
7231     PL_bostr            = Nullch;
7232     PL_reg_flags        = 0;
7233     PL_reg_eval_set     = 0;
7234     PL_regnarrate       = 0;
7235     PL_regprogram       = (regnode*)NULL;
7236     PL_regindent        = 0;
7237     PL_regcc            = (CURCUR*)NULL;
7238     PL_reg_call_cc      = (struct re_cc_state*)NULL;
7239     PL_reg_re           = (regexp*)NULL;
7240     PL_reg_ganch        = Nullch;
7241     PL_reg_sv           = Nullsv;
7242     PL_reg_magic        = (MAGIC*)NULL;
7243     PL_reg_oldpos       = 0;
7244     PL_reg_oldcurpm     = (PMOP*)NULL;
7245     PL_reg_curpm        = (PMOP*)NULL;
7246     PL_reg_oldsaved     = Nullch;
7247     PL_reg_oldsavedlen  = 0;
7248     PL_reg_maxiter      = 0;
7249     PL_reg_leftiter     = 0;
7250     PL_reg_poscache     = Nullch;
7251     PL_reg_poscache_size= 0;
7252
7253     /* RE engine - function pointers */
7254     PL_regcompp         = proto_perl->Tregcompp;
7255     PL_regexecp         = proto_perl->Tregexecp;
7256     PL_regint_start     = proto_perl->Tregint_start;
7257     PL_regint_string    = proto_perl->Tregint_string;
7258     PL_regfree          = proto_perl->Tregfree;
7259
7260     PL_reginterp_cnt    = 0;
7261     PL_reg_starttry     = 0;
7262
7263 #ifdef PERL_OBJECT
7264     return (PerlInterpreter*)pPerl;
7265 #else
7266     return my_perl;
7267 #endif
7268 }
7269
7270 #else   /* !USE_ITHREADS */
7271
7272 #ifdef PERL_OBJECT
7273 #include "XSUB.h"
7274 #endif
7275
7276 #endif /* USE_ITHREADS */
7277
7278 static void
7279 do_report_used(pTHXo_ SV *sv)
7280 {
7281     if (SvTYPE(sv) != SVTYPEMASK) {
7282         PerlIO_printf(Perl_debug_log, "****\n");
7283         sv_dump(sv);
7284     }
7285 }
7286
7287 static void
7288 do_clean_objs(pTHXo_ SV *sv)
7289 {
7290     SV* rv;
7291
7292     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7293         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7294         SvROK_off(sv);
7295         SvRV(sv) = 0;
7296         SvREFCNT_dec(rv);
7297     }
7298
7299     /* XXX Might want to check arrays, etc. */
7300 }
7301
7302 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7303 static void
7304 do_clean_named_objs(pTHXo_ SV *sv)
7305 {
7306     if (SvTYPE(sv) == SVt_PVGV) {
7307         if ( SvOBJECT(GvSV(sv)) ||
7308              GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7309              GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7310              GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7311              GvCV(sv) && SvOBJECT(GvCV(sv)) )
7312         {
7313             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7314             SvREFCNT_dec(sv);
7315         }
7316     }
7317 }
7318 #endif
7319
7320 static void
7321 do_clean_all(pTHXo_ SV *sv)
7322 {
7323     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
7324     SvFLAGS(sv) |= SVf_BREAK;
7325     SvREFCNT_dec(sv);
7326 }
7327