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     i = littlelen - len;
3214     if (i > 0) {                        /* string might grow */
3215         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3216         mid = big + offset + len;
3217         midend = bigend = big + SvCUR(bigstr);
3218         bigend += i;
3219         *bigend = '\0';
3220         while (midend > mid)            /* shove everything down */
3221             *--bigend = *--midend;
3222         Move(little,big+offset,littlelen,char);
3223         SvCUR(bigstr) += i;
3224         SvSETMAGIC(bigstr);
3225         return;
3226     }
3227     else if (i == 0) {
3228         Move(little,SvPVX(bigstr)+offset,len,char);
3229         SvSETMAGIC(bigstr);
3230         return;
3231     }
3232
3233     big = SvPVX(bigstr);
3234     mid = big + offset;
3235     midend = mid + len;
3236     bigend = big + SvCUR(bigstr);
3237
3238     if (midend > bigend)
3239         Perl_croak(aTHX_ "panic: sv_insert");
3240
3241     if (mid - big > bigend - midend) {  /* faster to shorten from end */
3242         if (littlelen) {
3243             Move(little, mid, littlelen,char);
3244             mid += littlelen;
3245         }
3246         i = bigend - midend;
3247         if (i > 0) {
3248             Move(midend, mid, i,char);
3249             mid += i;
3250         }
3251         *mid = '\0';
3252         SvCUR_set(bigstr, mid - big);
3253     }
3254     /*SUPPRESS 560*/
3255     else if (i = mid - big) {   /* faster from front */
3256         midend -= littlelen;
3257         mid = midend;
3258         sv_chop(bigstr,midend-i);
3259         big += i;
3260         while (i--)
3261             *--midend = *--big;
3262         if (littlelen)
3263             Move(little, mid, littlelen,char);
3264     }
3265     else if (littlelen) {
3266         midend -= littlelen;
3267         sv_chop(bigstr,midend);
3268         Move(little,midend,littlelen,char);
3269     }
3270     else {
3271         sv_chop(bigstr,midend);
3272     }
3273     SvSETMAGIC(bigstr);
3274 }
3275
3276 /* make sv point to what nstr did */
3277
3278 void
3279 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3280 {
3281     dTHR;
3282     U32 refcnt = SvREFCNT(sv);
3283     SV_CHECK_THINKFIRST(sv);
3284     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3285         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3286     if (SvMAGICAL(sv)) {
3287         if (SvMAGICAL(nsv))
3288             mg_free(nsv);
3289         else
3290             sv_upgrade(nsv, SVt_PVMG);
3291         SvMAGIC(nsv) = SvMAGIC(sv);
3292         SvFLAGS(nsv) |= SvMAGICAL(sv);
3293         SvMAGICAL_off(sv);
3294         SvMAGIC(sv) = 0;
3295     }
3296     SvREFCNT(sv) = 0;
3297     sv_clear(sv);
3298     assert(!SvREFCNT(sv));
3299     StructCopy(nsv,sv,SV);
3300     SvREFCNT(sv) = refcnt;
3301     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
3302     del_SV(nsv);
3303 }
3304
3305 void
3306 Perl_sv_clear(pTHX_ register SV *sv)
3307 {
3308     HV* stash;
3309     assert(sv);
3310     assert(SvREFCNT(sv) == 0);
3311
3312     if (SvOBJECT(sv)) {
3313         dTHR;
3314         if (PL_defstash) {              /* Still have a symbol table? */
3315             djSP;
3316             GV* destructor;
3317             SV tmpref;
3318
3319             Zero(&tmpref, 1, SV);
3320             sv_upgrade(&tmpref, SVt_RV);
3321             SvROK_on(&tmpref);
3322             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
3323             SvREFCNT(&tmpref) = 1;
3324
3325             do {
3326                 stash = SvSTASH(sv);
3327                 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3328                 if (destructor) {
3329                     ENTER;
3330                     PUSHSTACKi(PERLSI_DESTROY);
3331                     SvRV(&tmpref) = SvREFCNT_inc(sv);
3332                     EXTEND(SP, 2);
3333                     PUSHMARK(SP);
3334                     PUSHs(&tmpref);
3335                     PUTBACK;
3336                     call_sv((SV*)GvCV(destructor),
3337                             G_DISCARD|G_EVAL|G_KEEPERR);
3338                     SvREFCNT(sv)--;
3339                     POPSTACK;
3340                     SPAGAIN;
3341                     LEAVE;
3342                 }
3343             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3344
3345             del_XRV(SvANY(&tmpref));
3346
3347             if (SvREFCNT(sv)) {
3348                 if (PL_in_clean_objs)
3349                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3350                           HvNAME(stash));
3351                 /* DESTROY gave object new lease on life */
3352                 return;
3353             }
3354         }
3355
3356         if (SvOBJECT(sv)) {
3357             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
3358             SvOBJECT_off(sv);   /* Curse the object. */
3359             if (SvTYPE(sv) != SVt_PVIO)
3360                 --PL_sv_objcount;       /* XXX Might want something more general */
3361         }
3362     }
3363     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3364         mg_free(sv);
3365     stash = NULL;
3366     switch (SvTYPE(sv)) {
3367     case SVt_PVIO:
3368         if (IoIFP(sv) &&
3369             IoIFP(sv) != PerlIO_stdin() &&
3370             IoIFP(sv) != PerlIO_stdout() &&
3371             IoIFP(sv) != PerlIO_stderr())
3372         {
3373             io_close((IO*)sv, FALSE);
3374         }
3375         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3376             PerlDir_close(IoDIRP(sv));
3377         IoDIRP(sv) = (DIR*)NULL;
3378         Safefree(IoTOP_NAME(sv));
3379         Safefree(IoFMT_NAME(sv));
3380         Safefree(IoBOTTOM_NAME(sv));
3381         /* FALL THROUGH */
3382     case SVt_PVBM:
3383         goto freescalar;
3384     case SVt_PVCV:
3385     case SVt_PVFM:
3386         cv_undef((CV*)sv);
3387         goto freescalar;
3388     case SVt_PVHV:
3389         hv_undef((HV*)sv);
3390         break;
3391     case SVt_PVAV:
3392         av_undef((AV*)sv);
3393         break;
3394     case SVt_PVLV:
3395         SvREFCNT_dec(LvTARG(sv));
3396         goto freescalar;
3397     case SVt_PVGV:
3398         gp_free((GV*)sv);
3399         Safefree(GvNAME(sv));
3400         /* cannot decrease stash refcount yet, as we might recursively delete
3401            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3402            of stash until current sv is completely gone.
3403            -- JohnPC, 27 Mar 1998 */
3404         stash = GvSTASH(sv);
3405         /* FALL THROUGH */
3406     case SVt_PVMG:
3407     case SVt_PVNV:
3408     case SVt_PVIV:
3409       freescalar:
3410         (void)SvOOK_off(sv);
3411         /* FALL THROUGH */
3412     case SVt_PV:
3413     case SVt_RV:
3414         if (SvROK(sv)) {
3415             if (SvWEAKREF(sv))
3416                 sv_del_backref(sv);
3417             else
3418                 SvREFCNT_dec(SvRV(sv));
3419         }
3420         else if (SvPVX(sv) && SvLEN(sv))
3421             Safefree(SvPVX(sv));
3422         break;
3423 /*
3424     case SVt_NV:
3425     case SVt_IV:
3426     case SVt_NULL:
3427         break;
3428 */
3429     }
3430
3431     switch (SvTYPE(sv)) {
3432     case SVt_NULL:
3433         break;
3434     case SVt_IV:
3435         del_XIV(SvANY(sv));
3436         break;
3437     case SVt_NV:
3438         del_XNV(SvANY(sv));
3439         break;
3440     case SVt_RV:
3441         del_XRV(SvANY(sv));
3442         break;
3443     case SVt_PV:
3444         del_XPV(SvANY(sv));
3445         break;
3446     case SVt_PVIV:
3447         del_XPVIV(SvANY(sv));
3448         break;
3449     case SVt_PVNV:
3450         del_XPVNV(SvANY(sv));
3451         break;
3452     case SVt_PVMG:
3453         del_XPVMG(SvANY(sv));
3454         break;
3455     case SVt_PVLV:
3456         del_XPVLV(SvANY(sv));
3457         break;
3458     case SVt_PVAV:
3459         del_XPVAV(SvANY(sv));
3460         break;
3461     case SVt_PVHV:
3462         del_XPVHV(SvANY(sv));
3463         break;
3464     case SVt_PVCV:
3465         del_XPVCV(SvANY(sv));
3466         break;
3467     case SVt_PVGV:
3468         del_XPVGV(SvANY(sv));
3469         /* code duplication for increased performance. */
3470         SvFLAGS(sv) &= SVf_BREAK;
3471         SvFLAGS(sv) |= SVTYPEMASK;
3472         /* decrease refcount of the stash that owns this GV, if any */
3473         if (stash)
3474             SvREFCNT_dec(stash);
3475         return; /* not break, SvFLAGS reset already happened */
3476     case SVt_PVBM:
3477         del_XPVBM(SvANY(sv));
3478         break;
3479     case SVt_PVFM:
3480         del_XPVFM(SvANY(sv));
3481         break;
3482     case SVt_PVIO:
3483         del_XPVIO(SvANY(sv));
3484         break;
3485     }
3486     SvFLAGS(sv) &= SVf_BREAK;
3487     SvFLAGS(sv) |= SVTYPEMASK;
3488 }
3489
3490 SV *
3491 Perl_sv_newref(pTHX_ SV *sv)
3492 {
3493     if (sv)
3494         ATOMIC_INC(SvREFCNT(sv));
3495     return sv;
3496 }
3497
3498 void
3499 Perl_sv_free(pTHX_ SV *sv)
3500 {
3501     dTHR;
3502     int refcount_is_zero;
3503
3504     if (!sv)
3505         return;
3506     if (SvREFCNT(sv) == 0) {
3507         if (SvFLAGS(sv) & SVf_BREAK)
3508             return;
3509         if (PL_in_clean_all) /* All is fair */
3510             return;
3511         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3512             /* make sure SvREFCNT(sv)==0 happens very seldom */
3513             SvREFCNT(sv) = (~(U32)0)/2;
3514             return;
3515         }
3516         if (ckWARN_d(WARN_INTERNAL))
3517             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3518         return;
3519     }
3520     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3521     if (!refcount_is_zero)
3522         return;
3523 #ifdef DEBUGGING
3524     if (SvTEMP(sv)) {
3525         if (ckWARN_d(WARN_DEBUGGING))
3526             Perl_warner(aTHX_ WARN_DEBUGGING,
3527                         "Attempt to free temp prematurely: SV 0x%"UVxf,
3528                         PTR2UV(sv));
3529         return;
3530     }
3531 #endif
3532     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3533         /* make sure SvREFCNT(sv)==0 happens very seldom */
3534         SvREFCNT(sv) = (~(U32)0)/2;
3535         return;
3536     }
3537     sv_clear(sv);
3538     if (! SvREFCNT(sv))
3539         del_SV(sv);
3540 }
3541
3542 STRLEN
3543 Perl_sv_len(pTHX_ register SV *sv)
3544 {
3545     char *junk;
3546     STRLEN len;
3547
3548     if (!sv)
3549         return 0;
3550
3551     if (SvGMAGICAL(sv))
3552         len = mg_length(sv);
3553     else
3554         junk = SvPV(sv, len);
3555     return len;
3556 }
3557
3558 STRLEN
3559 Perl_sv_len_utf8(pTHX_ register SV *sv)
3560 {
3561     U8 *s;
3562     U8 *send;
3563     STRLEN len;
3564
3565     if (!sv)
3566         return 0;
3567
3568 #ifdef NOTYET
3569     if (SvGMAGICAL(sv))
3570         len = mg_length(sv);
3571     else
3572 #endif
3573         s = (U8*)SvPV(sv, len);
3574     send = s + len;
3575     len = 0;
3576     while (s < send) {
3577         s += UTF8SKIP(s);
3578         len++;
3579     }
3580     return len;
3581 }
3582
3583 void
3584 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3585 {
3586     U8 *start;
3587     U8 *s;
3588     U8 *send;
3589     I32 uoffset = *offsetp;
3590     STRLEN len;
3591
3592     if (!sv)
3593         return;
3594
3595     start = s = (U8*)SvPV(sv, len);
3596     send = s + len;
3597     while (s < send && uoffset--)
3598         s += UTF8SKIP(s);
3599     if (s >= send)
3600         s = send;
3601     *offsetp = s - start;
3602     if (lenp) {
3603         I32 ulen = *lenp;
3604         start = s;
3605         while (s < send && ulen--)
3606             s += UTF8SKIP(s);
3607         if (s >= send)
3608             s = send;
3609         *lenp = s - start;
3610     }
3611     return;
3612 }
3613
3614 void
3615 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3616 {
3617     U8 *s;
3618     U8 *send;
3619     STRLEN len;
3620
3621     if (!sv)
3622         return;
3623
3624     s = (U8*)SvPV(sv, len);
3625     if (len < *offsetp)
3626         Perl_croak(aTHX_ "panic: bad byte offset");
3627     send = s + *offsetp;
3628     len = 0;
3629     while (s < send) {
3630         s += UTF8SKIP(s);
3631         ++len;
3632     }
3633     if (s != send) {
3634         dTHR;
3635         if (ckWARN_d(WARN_UTF8))
3636             Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3637         --len;
3638     }
3639     *offsetp = len;
3640     return;
3641 }
3642
3643 I32
3644 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3645 {
3646     char *pv1;
3647     STRLEN cur1;
3648     char *pv2;
3649     STRLEN cur2;
3650
3651     if (!str1) {
3652         pv1 = "";
3653         cur1 = 0;
3654     }
3655     else
3656         pv1 = SvPV(str1, cur1);
3657
3658     if (!str2)
3659         return !cur1;
3660     else
3661         pv2 = SvPV(str2, cur2);
3662
3663     if (cur1 != cur2)
3664         return 0;
3665
3666     return memEQ(pv1, pv2, cur1);
3667 }
3668
3669 I32
3670 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3671 {
3672     STRLEN cur1 = 0;
3673     char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3674     STRLEN cur2 = 0;
3675     char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3676     I32 retval;
3677
3678     if (!cur1)
3679         return cur2 ? -1 : 0;
3680
3681     if (!cur2)
3682         return 1;
3683
3684     retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3685
3686     if (retval)
3687         return retval < 0 ? -1 : 1;
3688
3689     if (cur1 == cur2)
3690         return 0;
3691     else
3692         return cur1 < cur2 ? -1 : 1;
3693 }
3694
3695 I32
3696 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3697 {
3698 #ifdef USE_LOCALE_COLLATE
3699
3700     char *pv1, *pv2;
3701     STRLEN len1, len2;
3702     I32 retval;
3703
3704     if (PL_collation_standard)
3705         goto raw_compare;
3706
3707     len1 = 0;
3708     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3709     len2 = 0;
3710     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3711
3712     if (!pv1 || !len1) {
3713         if (pv2 && len2)
3714             return -1;
3715         else
3716             goto raw_compare;
3717     }
3718     else {
3719         if (!pv2 || !len2)
3720             return 1;
3721     }
3722
3723     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3724
3725     if (retval)
3726         return retval < 0 ? -1 : 1;
3727
3728     /*
3729      * When the result of collation is equality, that doesn't mean
3730      * that there are no differences -- some locales exclude some
3731      * characters from consideration.  So to avoid false equalities,
3732      * we use the raw string as a tiebreaker.
3733      */
3734
3735   raw_compare:
3736     /* FALL THROUGH */
3737
3738 #endif /* USE_LOCALE_COLLATE */
3739
3740     return sv_cmp(sv1, sv2);
3741 }
3742
3743 #ifdef USE_LOCALE_COLLATE
3744 /*
3745  * Any scalar variable may carry an 'o' magic that contains the
3746  * scalar data of the variable transformed to such a format that
3747  * a normal memory comparison can be used to compare the data
3748  * according to the locale settings.
3749  */
3750 char *
3751 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3752 {
3753     MAGIC *mg;
3754
3755     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3756     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3757         char *s, *xf;
3758         STRLEN len, xlen;
3759
3760         if (mg)
3761             Safefree(mg->mg_ptr);
3762         s = SvPV(sv, len);
3763         if ((xf = mem_collxfrm(s, len, &xlen))) {
3764             if (SvREADONLY(sv)) {
3765                 SAVEFREEPV(xf);
3766                 *nxp = xlen;
3767                 return xf + sizeof(PL_collation_ix);
3768             }
3769             if (! mg) {
3770                 sv_magic(sv, 0, 'o', 0, 0);
3771                 mg = mg_find(sv, 'o');
3772                 assert(mg);
3773             }
3774             mg->mg_ptr = xf;
3775             mg->mg_len = xlen;
3776         }
3777         else {
3778             if (mg) {
3779                 mg->mg_ptr = NULL;
3780                 mg->mg_len = -1;
3781             }
3782         }
3783     }
3784     if (mg && mg->mg_ptr) {
3785         *nxp = mg->mg_len;
3786         return mg->mg_ptr + sizeof(PL_collation_ix);
3787     }
3788     else {
3789         *nxp = 0;
3790         return NULL;
3791     }
3792 }
3793
3794 #endif /* USE_LOCALE_COLLATE */
3795
3796 char *
3797 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3798 {
3799     dTHR;
3800     char *rsptr;
3801     STRLEN rslen;
3802     register STDCHAR rslast;
3803     register STDCHAR *bp;
3804     register I32 cnt;
3805     I32 i;
3806
3807     SV_CHECK_THINKFIRST(sv);
3808     (void)SvUPGRADE(sv, SVt_PV);
3809
3810     SvSCREAM_off(sv);
3811
3812     if (RsSNARF(PL_rs)) {
3813         rsptr = NULL;
3814         rslen = 0;
3815     }
3816     else if (RsRECORD(PL_rs)) {
3817       I32 recsize, bytesread;
3818       char *buffer;
3819
3820       /* Grab the size of the record we're getting */
3821       recsize = SvIV(SvRV(PL_rs));
3822       (void)SvPOK_only(sv);    /* Validate pointer */
3823       buffer = SvGROW(sv, recsize + 1);
3824       /* Go yank in */
3825 #ifdef VMS
3826       /* VMS wants read instead of fread, because fread doesn't respect */
3827       /* RMS record boundaries. This is not necessarily a good thing to be */
3828       /* doing, but we've got no other real choice */
3829       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3830 #else
3831       bytesread = PerlIO_read(fp, buffer, recsize);
3832 #endif
3833       SvCUR_set(sv, bytesread);
3834       buffer[bytesread] = '\0';
3835       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3836     }
3837     else if (RsPARA(PL_rs)) {
3838         rsptr = "\n\n";
3839         rslen = 2;
3840     }
3841     else
3842         rsptr = SvPV(PL_rs, rslen);
3843     rslast = rslen ? rsptr[rslen - 1] : '\0';
3844
3845     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
3846         do {                    /* to make sure file boundaries work right */
3847             if (PerlIO_eof(fp))
3848                 return 0;
3849             i = PerlIO_getc(fp);
3850             if (i != '\n') {
3851                 if (i == -1)
3852                     return 0;
3853                 PerlIO_ungetc(fp,i);
3854                 break;
3855             }
3856         } while (i != EOF);
3857     }
3858
3859     /* See if we know enough about I/O mechanism to cheat it ! */
3860
3861     /* This used to be #ifdef test - it is made run-time test for ease
3862        of abstracting out stdio interface. One call should be cheap
3863        enough here - and may even be a macro allowing compile
3864        time optimization.
3865      */
3866
3867     if (PerlIO_fast_gets(fp)) {
3868
3869     /*
3870      * We're going to steal some values from the stdio struct
3871      * and put EVERYTHING in the innermost loop into registers.
3872      */
3873     register STDCHAR *ptr;
3874     STRLEN bpx;
3875     I32 shortbuffered;
3876
3877 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3878     /* An ungetc()d char is handled separately from the regular
3879      * buffer, so we getc() it back out and stuff it in the buffer.
3880      */
3881     i = PerlIO_getc(fp);
3882     if (i == EOF) return 0;
3883     *(--((*fp)->_ptr)) = (unsigned char) i;
3884     (*fp)->_cnt++;
3885 #endif
3886
3887     /* Here is some breathtakingly efficient cheating */
3888
3889     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
3890     (void)SvPOK_only(sv);               /* validate pointer */
3891     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3892         if (cnt > 80 && SvLEN(sv) > append) {
3893             shortbuffered = cnt - SvLEN(sv) + append + 1;
3894             cnt -= shortbuffered;
3895         }
3896         else {
3897             shortbuffered = 0;
3898             /* remember that cnt can be negative */
3899             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3900         }
3901     }
3902     else
3903         shortbuffered = 0;
3904     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
3905     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3906     DEBUG_P(PerlIO_printf(Perl_debug_log,
3907         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3908     DEBUG_P(PerlIO_printf(Perl_debug_log,
3909         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3910                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3911                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3912     for (;;) {
3913       screamer:
3914         if (cnt > 0) {
3915             if (rslen) {
3916                 while (cnt > 0) {                    /* this     |  eat */
3917                     cnt--;
3918                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
3919                         goto thats_all_folks;        /* screams  |  sed :-) */
3920                 }
3921             }
3922             else {
3923                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
3924                 bp += cnt;                           /* screams  |  dust */
3925                 ptr += cnt;                          /* louder   |  sed :-) */
3926                 cnt = 0;
3927             }
3928         }
3929
3930         if (shortbuffered) {            /* oh well, must extend */
3931             cnt = shortbuffered;
3932             shortbuffered = 0;
3933             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3934             SvCUR_set(sv, bpx);
3935             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3936             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3937             continue;
3938         }
3939
3940         DEBUG_P(PerlIO_printf(Perl_debug_log,
3941                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3942                               PTR2UV(ptr),(long)cnt));
3943         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3944         DEBUG_P(PerlIO_printf(Perl_debug_log,
3945             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3946             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3947             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3948         /* This used to call 'filbuf' in stdio form, but as that behaves like
3949            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3950            another abstraction.  */
3951         i   = PerlIO_getc(fp);          /* get more characters */
3952         DEBUG_P(PerlIO_printf(Perl_debug_log,
3953             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3954             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3955             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3956         cnt = PerlIO_get_cnt(fp);
3957         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
3958         DEBUG_P(PerlIO_printf(Perl_debug_log,
3959             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3960
3961         if (i == EOF)                   /* all done for ever? */
3962             goto thats_really_all_folks;
3963
3964         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3965         SvCUR_set(sv, bpx);
3966         SvGROW(sv, bpx + cnt + 2);
3967         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3968
3969         *bp++ = i;                      /* store character from PerlIO_getc */
3970
3971         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
3972             goto thats_all_folks;
3973     }
3974
3975 thats_all_folks:
3976     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3977           memNE((char*)bp - rslen, rsptr, rslen))
3978         goto screamer;                          /* go back to the fray */
3979 thats_really_all_folks:
3980     if (shortbuffered)
3981         cnt += shortbuffered;
3982         DEBUG_P(PerlIO_printf(Perl_debug_log,
3983             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3984     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
3985     DEBUG_P(PerlIO_printf(Perl_debug_log,
3986         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3987         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3988         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3989     *bp = '\0';
3990     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
3991     DEBUG_P(PerlIO_printf(Perl_debug_log,
3992         "Screamer: done, len=%ld, string=|%.*s|\n",
3993         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3994     }
3995    else
3996     {
3997 #ifndef EPOC
3998        /*The big, slow, and stupid way */
3999         STDCHAR buf[8192];
4000 #else
4001         /* Need to work around EPOC SDK features          */
4002         /* On WINS: MS VC5 generates calls to _chkstk,    */
4003         /* if a `large' stack frame is allocated          */
4004         /* gcc on MARM does not generate calls like these */
4005         STDCHAR buf[1024];
4006 #endif
4007
4008 screamer2:
4009         if (rslen) {
4010             register STDCHAR *bpe = buf + sizeof(buf);
4011             bp = buf;
4012             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4013                 ; /* keep reading */
4014             cnt = bp - buf;
4015         }
4016         else {
4017             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4018             /* Accomodate broken VAXC compiler, which applies U8 cast to
4019              * both args of ?: operator, causing EOF to change into 255
4020              */
4021             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4022         }
4023
4024         if (append)
4025             sv_catpvn(sv, (char *) buf, cnt);
4026         else
4027             sv_setpvn(sv, (char *) buf, cnt);
4028
4029         if (i != EOF &&                 /* joy */
4030             (!rslen ||
4031              SvCUR(sv) < rslen ||
4032              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4033         {
4034             append = -1;
4035             /*
4036              * If we're reading from a TTY and we get a short read,
4037              * indicating that the user hit his EOF character, we need
4038              * to notice it now, because if we try to read from the TTY
4039              * again, the EOF condition will disappear.
4040              *
4041              * The comparison of cnt to sizeof(buf) is an optimization
4042              * that prevents unnecessary calls to feof().
4043              *
4044              * - jik 9/25/96
4045              */
4046             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4047                 goto screamer2;
4048         }
4049     }
4050
4051     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4052         while (i != EOF) {      /* to make sure file boundaries work right */
4053             i = PerlIO_getc(fp);
4054             if (i != '\n') {
4055                 PerlIO_ungetc(fp,i);
4056                 break;
4057             }
4058         }
4059     }
4060
4061 #ifdef WIN32
4062     win32_strip_return(sv);
4063 #endif
4064
4065     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4066 }
4067
4068
4069 void
4070 Perl_sv_inc(pTHX_ register SV *sv)
4071 {
4072     register char *d;
4073     int flags;
4074
4075     if (!sv)
4076         return;
4077     if (SvGMAGICAL(sv))
4078         mg_get(sv);
4079     if (SvTHINKFIRST(sv)) {
4080         if (SvREADONLY(sv)) {
4081             dTHR;
4082             if (PL_curcop != &PL_compiling)
4083                 Perl_croak(aTHX_ PL_no_modify);
4084         }
4085         if (SvROK(sv)) {
4086             IV i;
4087             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4088                 return;
4089             i = PTR2IV(SvRV(sv));
4090             sv_unref(sv);
4091             sv_setiv(sv, i);
4092         }
4093     }
4094     flags = SvFLAGS(sv);
4095     if (flags & SVp_NOK) {
4096         (void)SvNOK_only(sv);
4097         SvNVX(sv) += 1.0;
4098         return;
4099     }
4100     if (flags & SVp_IOK) {
4101         if (SvIsUV(sv)) {
4102             if (SvUVX(sv) == UV_MAX)
4103                 sv_setnv(sv, (NV)UV_MAX + 1.0);
4104             else
4105                 (void)SvIOK_only_UV(sv);
4106                 ++SvUVX(sv);
4107         } else {
4108             if (SvIVX(sv) == IV_MAX)
4109                 sv_setnv(sv, (NV)IV_MAX + 1.0);
4110             else {
4111                 (void)SvIOK_only(sv);
4112                 ++SvIVX(sv);
4113             }
4114         }
4115         return;
4116     }
4117     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4118         if ((flags & SVTYPEMASK) < SVt_PVNV)
4119             sv_upgrade(sv, SVt_NV);
4120         SvNVX(sv) = 1.0;
4121         (void)SvNOK_only(sv);
4122         return;
4123     }
4124     d = SvPVX(sv);
4125     while (isALPHA(*d)) d++;
4126     while (isDIGIT(*d)) d++;
4127     if (*d) {
4128         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
4129         return;
4130     }
4131     d--;
4132     while (d >= SvPVX(sv)) {
4133         if (isDIGIT(*d)) {
4134             if (++*d <= '9')
4135                 return;
4136             *(d--) = '0';
4137         }
4138         else {
4139 #ifdef EBCDIC
4140             /* MKS: The original code here died if letters weren't consecutive.
4141              * at least it didn't have to worry about non-C locales.  The
4142              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4143              * arranged in order (although not consecutively) and that only
4144              * [A-Za-z] are accepted by isALPHA in the C locale.
4145              */
4146             if (*d != 'z' && *d != 'Z') {
4147                 do { ++*d; } while (!isALPHA(*d));
4148                 return;
4149             }
4150             *(d--) -= 'z' - 'a';
4151 #else
4152             ++*d;
4153             if (isALPHA(*d))
4154                 return;
4155             *(d--) -= 'z' - 'a' + 1;
4156 #endif
4157         }
4158     }
4159     /* oh,oh, the number grew */
4160     SvGROW(sv, SvCUR(sv) + 2);
4161     SvCUR(sv)++;
4162     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4163         *d = d[-1];
4164     if (isDIGIT(d[1]))
4165         *d = '1';
4166     else
4167         *d = d[1];
4168 }
4169
4170 void
4171 Perl_sv_dec(pTHX_ register SV *sv)
4172 {
4173     int flags;
4174
4175     if (!sv)
4176         return;
4177     if (SvGMAGICAL(sv))
4178         mg_get(sv);
4179     if (SvTHINKFIRST(sv)) {
4180         if (SvREADONLY(sv)) {
4181             dTHR;
4182             if (PL_curcop != &PL_compiling)
4183                 Perl_croak(aTHX_ PL_no_modify);
4184         }
4185         if (SvROK(sv)) {
4186             IV i;
4187             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4188                 return;
4189             i = PTR2IV(SvRV(sv));
4190             sv_unref(sv);
4191             sv_setiv(sv, i);
4192         }
4193     }
4194     flags = SvFLAGS(sv);
4195     if (flags & SVp_NOK) {
4196         SvNVX(sv) -= 1.0;
4197         (void)SvNOK_only(sv);
4198         return;
4199     }
4200     if (flags & SVp_IOK) {
4201         if (SvIsUV(sv)) {
4202             if (SvUVX(sv) == 0) {
4203                 (void)SvIOK_only(sv);
4204                 SvIVX(sv) = -1;
4205             }
4206             else {
4207                 (void)SvIOK_only_UV(sv);
4208                 --SvUVX(sv);
4209             }
4210         } else {
4211             if (SvIVX(sv) == IV_MIN)
4212                 sv_setnv(sv, (NV)IV_MIN - 1.0);
4213             else {
4214                 (void)SvIOK_only(sv);
4215                 --SvIVX(sv);
4216             }
4217         }
4218         return;
4219     }
4220     if (!(flags & SVp_POK)) {
4221         if ((flags & SVTYPEMASK) < SVt_PVNV)
4222             sv_upgrade(sv, SVt_NV);
4223         SvNVX(sv) = -1.0;
4224         (void)SvNOK_only(sv);
4225         return;
4226     }
4227     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4228 }
4229
4230 /* Make a string that will exist for the duration of the expression
4231  * evaluation.  Actually, it may have to last longer than that, but
4232  * hopefully we won't free it until it has been assigned to a
4233  * permanent location. */
4234
4235 SV *
4236 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4237 {
4238     dTHR;
4239     register SV *sv;
4240
4241     new_SV(sv);
4242     sv_setsv(sv,oldstr);
4243     EXTEND_MORTAL(1);
4244     PL_tmps_stack[++PL_tmps_ix] = sv;
4245     SvTEMP_on(sv);
4246     return sv;
4247 }
4248
4249 SV *
4250 Perl_sv_newmortal(pTHX)
4251 {
4252     dTHR;
4253     register SV *sv;
4254
4255     new_SV(sv);
4256     SvFLAGS(sv) = SVs_TEMP;
4257     EXTEND_MORTAL(1);
4258     PL_tmps_stack[++PL_tmps_ix] = sv;
4259     return sv;
4260 }
4261
4262 /* same thing without the copying */
4263
4264 SV *
4265 Perl_sv_2mortal(pTHX_ register SV *sv)
4266 {
4267     dTHR;
4268     if (!sv)
4269         return sv;
4270     if (SvREADONLY(sv) && SvIMMORTAL(sv))
4271         return sv;
4272     EXTEND_MORTAL(1);
4273     PL_tmps_stack[++PL_tmps_ix] = sv;
4274     SvTEMP_on(sv);
4275     return sv;
4276 }
4277
4278 SV *
4279 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4280 {
4281     register SV *sv;
4282
4283     new_SV(sv);
4284     if (!len)
4285         len = strlen(s);
4286     sv_setpvn(sv,s,len);
4287     return sv;
4288 }
4289
4290 SV *
4291 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4292 {
4293     register SV *sv;
4294
4295     new_SV(sv);
4296     sv_setpvn(sv,s,len);
4297     return sv;
4298 }
4299
4300 #if defined(PERL_IMPLICIT_CONTEXT)
4301 SV *
4302 Perl_newSVpvf_nocontext(const char* pat, ...)
4303 {
4304     dTHX;
4305     register SV *sv;
4306     va_list args;
4307     va_start(args, pat);
4308     sv = vnewSVpvf(pat, &args);
4309     va_end(args);
4310     return sv;
4311 }
4312 #endif
4313
4314 SV *
4315 Perl_newSVpvf(pTHX_ const char* pat, ...)
4316 {
4317     register SV *sv;
4318     va_list args;
4319     va_start(args, pat);
4320     sv = vnewSVpvf(pat, &args);
4321     va_end(args);
4322     return sv;
4323 }
4324
4325 SV *
4326 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4327 {
4328     register SV *sv;
4329     new_SV(sv);
4330     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4331     return sv;
4332 }
4333
4334 SV *
4335 Perl_newSVnv(pTHX_ NV n)
4336 {
4337     register SV *sv;
4338
4339     new_SV(sv);
4340     sv_setnv(sv,n);
4341     return sv;
4342 }
4343
4344 SV *
4345 Perl_newSViv(pTHX_ IV i)
4346 {
4347     register SV *sv;
4348
4349     new_SV(sv);
4350     sv_setiv(sv,i);
4351     return sv;
4352 }
4353
4354 SV *
4355 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4356 {
4357     dTHR;
4358     register SV *sv;
4359
4360     new_SV(sv);
4361     sv_upgrade(sv, SVt_RV);
4362     SvTEMP_off(tmpRef);
4363     SvRV(sv) = tmpRef;
4364     SvROK_on(sv);
4365     return sv;
4366 }
4367
4368 SV *
4369 Perl_newRV(pTHX_ SV *tmpRef)
4370 {
4371     return newRV_noinc(SvREFCNT_inc(tmpRef));
4372 }
4373
4374 /* make an exact duplicate of old */
4375
4376 SV *
4377 Perl_newSVsv(pTHX_ register SV *old)
4378 {
4379     dTHR;
4380     register SV *sv;
4381
4382     if (!old)
4383         return Nullsv;
4384     if (SvTYPE(old) == SVTYPEMASK) {
4385         if (ckWARN_d(WARN_INTERNAL))
4386             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4387         return Nullsv;
4388     }
4389     new_SV(sv);
4390     if (SvTEMP(old)) {
4391         SvTEMP_off(old);
4392         sv_setsv(sv,old);
4393         SvTEMP_on(old);
4394     }
4395     else
4396         sv_setsv(sv,old);
4397     return sv;
4398 }
4399
4400 void
4401 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4402 {
4403     register HE *entry;
4404     register GV *gv;
4405     register SV *sv;
4406     register I32 i;
4407     register PMOP *pm;
4408     register I32 max;
4409     char todo[PERL_UCHAR_MAX+1];
4410
4411     if (!stash)
4412         return;
4413
4414     if (!*s) {          /* reset ?? searches */
4415         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4416             pm->op_pmdynflags &= ~PMdf_USED;
4417         }
4418         return;
4419     }
4420
4421     /* reset variables */
4422
4423     if (!HvARRAY(stash))
4424         return;
4425
4426     Zero(todo, 256, char);
4427     while (*s) {
4428         i = (unsigned char)*s;
4429         if (s[1] == '-') {
4430             s += 2;
4431         }
4432         max = (unsigned char)*s++;
4433         for ( ; i <= max; i++) {
4434             todo[i] = 1;
4435         }
4436         for (i = 0; i <= (I32) HvMAX(stash); i++) {
4437             for (entry = HvARRAY(stash)[i];
4438                  entry;
4439                  entry = HeNEXT(entry))
4440             {
4441                 if (!todo[(U8)*HeKEY(entry)])
4442                     continue;
4443                 gv = (GV*)HeVAL(entry);
4444                 sv = GvSV(gv);
4445                 if (SvTHINKFIRST(sv)) {
4446                     if (!SvREADONLY(sv) && SvROK(sv))
4447                         sv_unref(sv);
4448                     continue;
4449                 }
4450                 (void)SvOK_off(sv);
4451                 if (SvTYPE(sv) >= SVt_PV) {
4452                     SvCUR_set(sv, 0);
4453                     if (SvPVX(sv) != Nullch)
4454                         *SvPVX(sv) = '\0';
4455                     SvTAINT(sv);
4456                 }
4457                 if (GvAV(gv)) {
4458                     av_clear(GvAV(gv));
4459                 }
4460                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4461                     hv_clear(GvHV(gv));
4462 #ifndef VMS  /* VMS has no environ array */
4463                     if (gv == PL_envgv)
4464                         environ[0] = Nullch;
4465 #endif
4466                 }
4467             }
4468         }
4469     }
4470 }
4471
4472 IO*
4473 Perl_sv_2io(pTHX_ SV *sv)
4474 {
4475     IO* io;
4476     GV* gv;
4477     STRLEN n_a;
4478
4479     switch (SvTYPE(sv)) {
4480     case SVt_PVIO:
4481         io = (IO*)sv;
4482         break;
4483     case SVt_PVGV:
4484         gv = (GV*)sv;
4485         io = GvIO(gv);
4486         if (!io)
4487             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4488         break;
4489     default:
4490         if (!SvOK(sv))
4491             Perl_croak(aTHX_ PL_no_usym, "filehandle");
4492         if (SvROK(sv))
4493             return sv_2io(SvRV(sv));
4494         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4495         if (gv)
4496             io = GvIO(gv);
4497         else
4498             io = 0;
4499         if (!io)
4500             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4501         break;
4502     }
4503     return io;
4504 }
4505
4506 CV *
4507 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4508 {
4509     GV *gv;
4510     CV *cv;
4511     STRLEN n_a;
4512
4513     if (!sv)
4514         return *gvp = Nullgv, Nullcv;
4515     switch (SvTYPE(sv)) {
4516     case SVt_PVCV:
4517         *st = CvSTASH(sv);
4518         *gvp = Nullgv;
4519         return (CV*)sv;
4520     case SVt_PVHV:
4521     case SVt_PVAV:
4522         *gvp = Nullgv;
4523         return Nullcv;
4524     case SVt_PVGV:
4525         gv = (GV*)sv;
4526         *gvp = gv;
4527         *st = GvESTASH(gv);
4528         goto fix_gv;
4529
4530     default:
4531         if (SvGMAGICAL(sv))
4532             mg_get(sv);
4533         if (SvROK(sv)) {
4534             dTHR;
4535             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
4536             tryAMAGICunDEREF(to_cv);
4537
4538             sv = SvRV(sv);
4539             if (SvTYPE(sv) == SVt_PVCV) {
4540                 cv = (CV*)sv;
4541                 *gvp = Nullgv;
4542                 *st = CvSTASH(cv);
4543                 return cv;
4544             }
4545             else if(isGV(sv))
4546                 gv = (GV*)sv;
4547             else
4548                 Perl_croak(aTHX_ "Not a subroutine reference");
4549         }
4550         else if (isGV(sv))
4551             gv = (GV*)sv;
4552         else
4553             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4554         *gvp = gv;
4555         if (!gv)
4556             return Nullcv;
4557         *st = GvESTASH(gv);
4558     fix_gv:
4559         if (lref && !GvCVu(gv)) {
4560             SV *tmpsv;
4561             ENTER;
4562             tmpsv = NEWSV(704,0);
4563             gv_efullname3(tmpsv, gv, Nullch);
4564             /* XXX this is probably not what they think they're getting.
4565              * It has the same effect as "sub name;", i.e. just a forward
4566              * declaration! */
4567             newSUB(start_subparse(FALSE, 0),
4568                    newSVOP(OP_CONST, 0, tmpsv),
4569                    Nullop,
4570                    Nullop);
4571             LEAVE;
4572             if (!GvCVu(gv))
4573                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4574         }
4575         return GvCVu(gv);
4576     }
4577 }
4578
4579 I32
4580 Perl_sv_true(pTHX_ register SV *sv)
4581 {
4582     dTHR;
4583     if (!sv)
4584         return 0;
4585     if (SvPOK(sv)) {
4586         register XPV* tXpv;
4587         if ((tXpv = (XPV*)SvANY(sv)) &&
4588                 (*tXpv->xpv_pv > '0' ||
4589                 tXpv->xpv_cur > 1 ||
4590                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4591             return 1;
4592         else
4593             return 0;
4594     }
4595     else {
4596         if (SvIOK(sv))
4597             return SvIVX(sv) != 0;
4598         else {
4599             if (SvNOK(sv))
4600                 return SvNVX(sv) != 0.0;
4601             else
4602                 return sv_2bool(sv);
4603         }
4604     }
4605 }
4606
4607 IV
4608 Perl_sv_iv(pTHX_ register SV *sv)
4609 {
4610     if (SvIOK(sv)) {
4611         if (SvIsUV(sv))
4612             return (IV)SvUVX(sv);
4613         return SvIVX(sv);
4614     }
4615     return sv_2iv(sv);
4616 }
4617
4618 UV
4619 Perl_sv_uv(pTHX_ register SV *sv)
4620 {
4621     if (SvIOK(sv)) {
4622         if (SvIsUV(sv))
4623             return SvUVX(sv);
4624         return (UV)SvIVX(sv);
4625     }
4626     return sv_2uv(sv);
4627 }
4628
4629 NV
4630 Perl_sv_nv(pTHX_ register SV *sv)
4631 {
4632     if (SvNOK(sv))
4633         return SvNVX(sv);
4634     return sv_2nv(sv);
4635 }
4636
4637 char *
4638 Perl_sv_pv(pTHX_ SV *sv)
4639 {
4640     STRLEN n_a;
4641
4642     if (SvPOK(sv))
4643         return SvPVX(sv);
4644
4645     return sv_2pv(sv, &n_a);
4646 }
4647
4648 char *
4649 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4650 {
4651     if (SvPOK(sv)) {
4652         *lp = SvCUR(sv);
4653         return SvPVX(sv);
4654     }
4655     return sv_2pv(sv, lp);
4656 }
4657
4658 char *
4659 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4660 {
4661     char *s;
4662
4663     if (SvTHINKFIRST(sv) && !SvROK(sv))
4664         sv_force_normal(sv);
4665
4666     if (SvPOK(sv)) {
4667         *lp = SvCUR(sv);
4668     }
4669     else {
4670         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4671             dTHR;
4672             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4673                 PL_op_name[PL_op->op_type]);
4674         }
4675         else
4676             s = sv_2pv(sv, lp);
4677         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
4678             STRLEN len = *lp;
4679
4680             if (SvROK(sv))
4681                 sv_unref(sv);
4682             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
4683             SvGROW(sv, len + 1);
4684             Move(s,SvPVX(sv),len,char);
4685             SvCUR_set(sv, len);
4686             *SvEND(sv) = '\0';
4687         }
4688         if (!SvPOK(sv)) {
4689             SvPOK_on(sv);               /* validate pointer */
4690             SvTAINT(sv);
4691             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4692                                   PTR2UV(sv),SvPVX(sv)));
4693         }
4694     }
4695     return SvPVX(sv);
4696 }
4697
4698 char *
4699 Perl_sv_pvbyte(pTHX_ SV *sv)
4700 {
4701     return sv_pv(sv);
4702 }
4703
4704 char *
4705 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
4706 {
4707     return sv_pvn(sv,lp);
4708 }
4709
4710 char *
4711 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
4712 {
4713     return sv_pvn_force(sv,lp);
4714 }
4715
4716 char *
4717 Perl_sv_pvutf8(pTHX_ SV *sv)
4718 {
4719     return sv_pv(sv);
4720 }
4721
4722 char *
4723 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
4724 {
4725     return sv_pvn(sv,lp);
4726 }
4727
4728 char *
4729 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
4730 {
4731     return sv_pvn_force(sv,lp);
4732 }
4733
4734 char *
4735 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4736 {
4737     if (ob && SvOBJECT(sv))
4738         return HvNAME(SvSTASH(sv));
4739     else {
4740         switch (SvTYPE(sv)) {
4741         case SVt_NULL:
4742         case SVt_IV:
4743         case SVt_NV:
4744         case SVt_RV:
4745         case SVt_PV:
4746         case SVt_PVIV:
4747         case SVt_PVNV:
4748         case SVt_PVMG:
4749         case SVt_PVBM:
4750                                 if (SvROK(sv))
4751                                     return "REF";
4752                                 else
4753                                     return "SCALAR";
4754         case SVt_PVLV:          return "LVALUE";
4755         case SVt_PVAV:          return "ARRAY";
4756         case SVt_PVHV:          return "HASH";
4757         case SVt_PVCV:          return "CODE";
4758         case SVt_PVGV:          return "GLOB";
4759         case SVt_PVFM:          return "FORMAT";
4760         default:                return "UNKNOWN";
4761         }
4762     }
4763 }
4764
4765 int
4766 Perl_sv_isobject(pTHX_ SV *sv)
4767 {
4768     if (!sv)
4769         return 0;
4770     if (SvGMAGICAL(sv))
4771         mg_get(sv);
4772     if (!SvROK(sv))
4773         return 0;
4774     sv = (SV*)SvRV(sv);
4775     if (!SvOBJECT(sv))
4776         return 0;
4777     return 1;
4778 }
4779
4780 int
4781 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4782 {
4783     if (!sv)
4784         return 0;
4785     if (SvGMAGICAL(sv))
4786         mg_get(sv);
4787     if (!SvROK(sv))
4788         return 0;
4789     sv = (SV*)SvRV(sv);
4790     if (!SvOBJECT(sv))
4791         return 0;
4792
4793     return strEQ(HvNAME(SvSTASH(sv)), name);
4794 }
4795
4796 SV*
4797 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4798 {
4799     dTHR;
4800     SV *sv;
4801
4802     new_SV(sv);
4803
4804     SV_CHECK_THINKFIRST(rv);
4805     SvAMAGIC_off(rv);
4806
4807     if (SvTYPE(rv) < SVt_RV)
4808       sv_upgrade(rv, SVt_RV);
4809
4810     (void)SvOK_off(rv);
4811     SvRV(rv) = sv;
4812     SvROK_on(rv);
4813
4814     if (classname) {
4815         HV* stash = gv_stashpv(classname, TRUE);
4816         (void)sv_bless(rv, stash);
4817     }
4818     return sv;
4819 }
4820
4821 SV*
4822 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4823 {
4824     if (!pv) {
4825         sv_setsv(rv, &PL_sv_undef);
4826         SvSETMAGIC(rv);
4827     }
4828     else
4829         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4830     return rv;
4831 }
4832
4833 SV*
4834 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4835 {
4836     sv_setiv(newSVrv(rv,classname), iv);
4837     return rv;
4838 }
4839
4840 SV*
4841 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4842 {
4843     sv_setnv(newSVrv(rv,classname), nv);
4844     return rv;
4845 }
4846
4847 SV*
4848 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4849 {
4850     sv_setpvn(newSVrv(rv,classname), pv, n);
4851     return rv;
4852 }
4853
4854 SV*
4855 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4856 {
4857     dTHR;
4858     SV *tmpRef;
4859     if (!SvROK(sv))
4860         Perl_croak(aTHX_ "Can't bless non-reference value");
4861     tmpRef = SvRV(sv);
4862     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4863         if (SvREADONLY(tmpRef))
4864             Perl_croak(aTHX_ PL_no_modify);
4865         if (SvOBJECT(tmpRef)) {
4866             if (SvTYPE(tmpRef) != SVt_PVIO)
4867                 --PL_sv_objcount;
4868             SvREFCNT_dec(SvSTASH(tmpRef));
4869         }
4870     }
4871     SvOBJECT_on(tmpRef);
4872     if (SvTYPE(tmpRef) != SVt_PVIO)
4873         ++PL_sv_objcount;
4874     (void)SvUPGRADE(tmpRef, SVt_PVMG);
4875     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4876
4877     if (Gv_AMG(stash))
4878         SvAMAGIC_on(sv);
4879     else
4880         SvAMAGIC_off(sv);
4881
4882     return sv;
4883 }
4884
4885 STATIC void
4886 S_sv_unglob(pTHX_ SV *sv)
4887 {
4888     assert(SvTYPE(sv) == SVt_PVGV);
4889     SvFAKE_off(sv);
4890     if (GvGP(sv))
4891         gp_free((GV*)sv);
4892     if (GvSTASH(sv)) {
4893         SvREFCNT_dec(GvSTASH(sv));
4894         GvSTASH(sv) = Nullhv;
4895     }
4896     sv_unmagic(sv, '*');
4897     Safefree(GvNAME(sv));
4898     GvMULTI_off(sv);
4899     SvFLAGS(sv) &= ~SVTYPEMASK;
4900     SvFLAGS(sv) |= SVt_PVMG;
4901 }
4902
4903 void
4904 Perl_sv_unref(pTHX_ SV *sv)
4905 {
4906     SV* rv = SvRV(sv);
4907
4908     if (SvWEAKREF(sv)) {
4909         sv_del_backref(sv);
4910         SvWEAKREF_off(sv);
4911         SvRV(sv) = 0;
4912         return;
4913     }
4914     SvRV(sv) = 0;
4915     SvROK_off(sv);
4916     if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4917         SvREFCNT_dec(rv);
4918     else
4919         sv_2mortal(rv);         /* Schedule for freeing later */
4920 }
4921
4922 void
4923 Perl_sv_taint(pTHX_ SV *sv)
4924 {
4925     sv_magic((sv), Nullsv, 't', Nullch, 0);
4926 }
4927
4928 void
4929 Perl_sv_untaint(pTHX_ SV *sv)
4930 {
4931     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4932         MAGIC *mg = mg_find(sv, 't');
4933         if (mg)
4934             mg->mg_len &= ~1;
4935     }
4936 }
4937
4938 bool
4939 Perl_sv_tainted(pTHX_ SV *sv)
4940 {
4941     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4942         MAGIC *mg = mg_find(sv, 't');
4943         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4944             return TRUE;
4945     }
4946     return FALSE;
4947 }
4948
4949 void
4950 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4951 {
4952     char buf[TYPE_CHARS(UV)];
4953     char *ebuf;
4954     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4955
4956     sv_setpvn(sv, ptr, ebuf - ptr);
4957 }
4958
4959
4960 void
4961 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4962 {
4963     char buf[TYPE_CHARS(UV)];
4964     char *ebuf;
4965     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4966
4967     sv_setpvn(sv, ptr, ebuf - ptr);
4968     SvSETMAGIC(sv);
4969 }
4970
4971 #if defined(PERL_IMPLICIT_CONTEXT)
4972 void
4973 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4974 {
4975     dTHX;
4976     va_list args;
4977     va_start(args, pat);
4978     sv_vsetpvf(sv, pat, &args);
4979     va_end(args);
4980 }
4981
4982
4983 void
4984 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4985 {
4986     dTHX;
4987     va_list args;
4988     va_start(args, pat);
4989     sv_vsetpvf_mg(sv, pat, &args);
4990     va_end(args);
4991 }
4992 #endif
4993
4994 void
4995 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4996 {
4997     va_list args;
4998     va_start(args, pat);
4999     sv_vsetpvf(sv, pat, &args);
5000     va_end(args);
5001 }
5002
5003 void
5004 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5005 {
5006     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5007 }
5008
5009 void
5010 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5011 {
5012     va_list args;
5013     va_start(args, pat);
5014     sv_vsetpvf_mg(sv, pat, &args);
5015     va_end(args);
5016 }
5017
5018 void
5019 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5020 {
5021     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5022     SvSETMAGIC(sv);
5023 }
5024
5025 #if defined(PERL_IMPLICIT_CONTEXT)
5026 void
5027 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5028 {
5029     dTHX;
5030     va_list args;
5031     va_start(args, pat);
5032     sv_vcatpvf(sv, pat, &args);
5033     va_end(args);
5034 }
5035
5036 void
5037 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5038 {
5039     dTHX;
5040     va_list args;
5041     va_start(args, pat);
5042     sv_vcatpvf_mg(sv, pat, &args);
5043     va_end(args);
5044 }
5045 #endif
5046
5047 void
5048 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5049 {
5050     va_list args;
5051     va_start(args, pat);
5052     sv_vcatpvf(sv, pat, &args);
5053     va_end(args);
5054 }
5055
5056 void
5057 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5058 {
5059     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5060 }
5061
5062 void
5063 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5064 {
5065     va_list args;
5066     va_start(args, pat);
5067     sv_vcatpvf_mg(sv, pat, &args);
5068     va_end(args);
5069 }
5070
5071 void
5072 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5073 {
5074     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5075     SvSETMAGIC(sv);
5076 }
5077
5078 void
5079 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5080 {
5081     sv_setpvn(sv, "", 0);
5082     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5083 }
5084
5085 void
5086 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5087 {
5088     dTHR;
5089     char *p;
5090     char *q;
5091     char *patend;
5092     STRLEN origlen;
5093     I32 svix = 0;
5094     static char nullstr[] = "(null)";
5095
5096     /* no matter what, this is a string now */
5097     (void)SvPV_force(sv, origlen);
5098
5099     /* special-case "", "%s", and "%_" */
5100     if (patlen == 0)
5101         return;
5102     if (patlen == 2 && pat[0] == '%') {
5103         switch (pat[1]) {
5104         case 's':
5105             if (args) {
5106                 char *s = va_arg(*args, char*);
5107                 sv_catpv(sv, s ? s : nullstr);
5108             }
5109             else if (svix < svmax)
5110                 sv_catsv(sv, *svargs);
5111             return;
5112         case '_':
5113             if (args) {
5114                 sv_catsv(sv, va_arg(*args, SV*));
5115                 return;
5116             }
5117             /* See comment on '_' below */
5118             break;
5119         }
5120     }
5121
5122     patend = (char*)pat + patlen;
5123     for (p = (char*)pat; p < patend; p = q) {
5124         bool alt = FALSE;
5125         bool left = FALSE;
5126         char fill = ' ';
5127         char plus = 0;
5128         char intsize = 0;
5129         STRLEN width = 0;
5130         STRLEN zeros = 0;
5131         bool has_precis = FALSE;
5132         STRLEN precis = 0;
5133
5134         char esignbuf[4];
5135         U8 utf8buf[10];
5136         STRLEN esignlen = 0;
5137
5138         char *eptr = Nullch;
5139         STRLEN elen = 0;
5140         /* Times 4: a decimal digit takes more than 3 binary digits.
5141          * NV_DIG: mantissa takes than many decimal digits.
5142          * Plus 32: Playing safe. */
5143         char ebuf[IV_DIG * 4 + NV_DIG + 32];
5144         /* large enough for "%#.#f" --chip */
5145         /* what about long double NVs? --jhi */
5146         char c;
5147         int i;
5148         unsigned base;
5149         IV iv;
5150         UV uv;
5151         NV nv;
5152         STRLEN have;
5153         STRLEN need;
5154         STRLEN gap;
5155
5156         for (q = p; q < patend && *q != '%'; ++q) ;
5157         if (q > p) {
5158             sv_catpvn(sv, p, q - p);
5159             p = q;
5160         }
5161         if (q++ >= patend)
5162             break;
5163
5164         /* FLAGS */
5165
5166         while (*q) {
5167             switch (*q) {
5168             case ' ':
5169             case '+':
5170                 plus = *q++;
5171                 continue;
5172
5173             case '-':
5174                 left = TRUE;
5175                 q++;
5176                 continue;
5177
5178             case '0':
5179                 fill = *q++;
5180                 continue;
5181
5182             case '#':
5183                 alt = TRUE;
5184                 q++;
5185                 continue;
5186
5187             default:
5188                 break;
5189             }
5190             break;
5191         }
5192
5193         /* WIDTH */
5194
5195         switch (*q) {
5196         case '1': case '2': case '3':
5197         case '4': case '5': case '6':
5198         case '7': case '8': case '9':
5199             width = 0;
5200             while (isDIGIT(*q))
5201                 width = width * 10 + (*q++ - '0');
5202             break;
5203
5204         case '*':
5205             if (args)
5206                 i = va_arg(*args, int);
5207             else
5208                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5209             left |= (i < 0);
5210             width = (i < 0) ? -i : i;
5211             q++;
5212             break;
5213         }
5214
5215         /* PRECISION */
5216
5217         if (*q == '.') {
5218             q++;
5219             if (*q == '*') {
5220                 if (args)
5221                     i = va_arg(*args, int);
5222                 else
5223                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5224                 precis = (i < 0) ? 0 : i;
5225                 q++;
5226             }
5227             else {
5228                 precis = 0;
5229                 while (isDIGIT(*q))
5230                     precis = precis * 10 + (*q++ - '0');
5231             }
5232             has_precis = TRUE;
5233         }
5234
5235         /* SIZE */
5236
5237         switch (*q) {
5238 #ifdef HAS_QUAD
5239         case 'L':                       /* Ld */
5240         case 'q':                       /* qd */
5241             intsize = 'q';
5242             q++;
5243             break;
5244 #endif
5245         case 'l':
5246 #ifdef HAS_QUAD
5247              if (*(q + 1) == 'l') {     /* lld */
5248                 intsize = 'q';
5249                 q += 2;
5250                 break;
5251              }
5252 #endif
5253             /* FALL THROUGH */
5254         case 'h':
5255             /* FALL THROUGH */
5256         case 'V':
5257             intsize = *q++;
5258             break;
5259         }
5260
5261         /* CONVERSION */
5262
5263         switch (c = *q++) {
5264
5265             /* STRINGS */
5266
5267         case '%':
5268             eptr = q - 1;
5269             elen = 1;
5270             goto string;
5271
5272         case 'c':
5273             if (IN_UTF8) {
5274                 if (args)
5275                     uv = va_arg(*args, int);
5276                 else
5277                     uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5278
5279                 eptr = (char*)utf8buf;
5280                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5281                 goto string;
5282             }
5283             if (args)
5284                 c = va_arg(*args, int);
5285             else
5286                 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5287             eptr = &c;
5288             elen = 1;
5289             goto string;
5290
5291         case 's':
5292             if (args) {
5293                 eptr = va_arg(*args, char*);
5294                 if (eptr)
5295 #ifdef MACOS_TRADITIONAL
5296                   /* On MacOS, %#s format is used for Pascal strings */
5297                   if (alt)
5298                     elen = *eptr++;
5299                   else
5300 #endif
5301                     elen = strlen(eptr);
5302                 else {
5303                     eptr = nullstr;
5304                     elen = sizeof nullstr - 1;
5305                 }
5306             }
5307             else if (svix < svmax) {
5308                 eptr = SvPVx(svargs[svix++], elen);
5309                 if (IN_UTF8) {
5310                     if (has_precis && precis < elen) {
5311                         I32 p = precis;
5312                         sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5313                         precis = p;
5314                     }
5315                     if (width) { /* fudge width (can't fudge elen) */
5316                         width += elen - sv_len_utf8(svargs[svix - 1]);
5317                     }
5318                 }
5319             }
5320             goto string;
5321
5322         case '_':
5323             /*
5324              * The "%_" hack might have to be changed someday,
5325              * if ISO or ANSI decide to use '_' for something.
5326              * So we keep it hidden from users' code.
5327              */
5328             if (!args)
5329                 goto unknown;
5330             eptr = SvPVx(va_arg(*args, SV*), elen);
5331
5332         string:
5333             if (has_precis && elen > precis)
5334                 elen = precis;
5335             break;
5336
5337             /* INTEGERS */
5338
5339         case 'p':
5340             if (args)
5341                 uv = PTR2UV(va_arg(*args, void*));
5342             else
5343                 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5344             base = 16;
5345             goto integer;
5346
5347         case 'D':
5348 #ifdef IV_IS_QUAD
5349             intsize = 'q';
5350 #else
5351             intsize = 'l';
5352 #endif
5353             /* FALL THROUGH */
5354         case 'd':
5355         case 'i':
5356             if (args) {
5357                 switch (intsize) {
5358                 case 'h':       iv = (short)va_arg(*args, int); break;
5359                 default:        iv = va_arg(*args, int); break;
5360                 case 'l':       iv = va_arg(*args, long); break;
5361                 case 'V':       iv = va_arg(*args, IV); break;
5362 #ifdef HAS_QUAD
5363                 case 'q':       iv = va_arg(*args, Quad_t); break;
5364 #endif
5365                 }
5366             }
5367             else {
5368                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5369                 switch (intsize) {
5370                 case 'h':       iv = (short)iv; break;
5371                 default:        iv = (int)iv; break;
5372                 case 'l':       iv = (long)iv; break;
5373                 case 'V':       break;
5374 #ifdef HAS_QUAD
5375                 case 'q':       iv = (Quad_t)iv; break;
5376 #endif
5377                 }
5378             }
5379             if (iv >= 0) {
5380                 uv = iv;
5381                 if (plus)
5382                     esignbuf[esignlen++] = plus;
5383             }
5384             else {
5385                 uv = -iv;
5386                 esignbuf[esignlen++] = '-';
5387             }
5388             base = 10;
5389             goto integer;
5390
5391         case 'U':
5392 #ifdef IV_IS_QUAD
5393             intsize = 'q';
5394 #else
5395             intsize = 'l';
5396 #endif
5397             /* FALL THROUGH */
5398         case 'u':
5399             base = 10;
5400             goto uns_integer;
5401
5402         case 'b':
5403             base = 2;
5404             goto uns_integer;
5405
5406         case 'O':
5407 #ifdef IV_IS_QUAD
5408             intsize = 'q';
5409 #else
5410             intsize = 'l';
5411 #endif
5412             /* FALL THROUGH */
5413         case 'o':
5414             base = 8;
5415             goto uns_integer;
5416
5417         case 'X':
5418         case 'x':
5419             base = 16;
5420
5421         uns_integer:
5422             if (args) {
5423                 switch (intsize) {
5424                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
5425                 default:   uv = va_arg(*args, unsigned); break;
5426                 case 'l':  uv = va_arg(*args, unsigned long); break;
5427                 case 'V':  uv = va_arg(*args, UV); break;
5428 #ifdef HAS_QUAD
5429                 case 'q':  uv = va_arg(*args, Quad_t); break;
5430 #endif
5431                 }
5432             }
5433             else {
5434                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5435                 switch (intsize) {
5436                 case 'h':       uv = (unsigned short)uv; break;
5437                 default:        uv = (unsigned)uv; break;
5438                 case 'l':       uv = (unsigned long)uv; break;
5439                 case 'V':       break;
5440 #ifdef HAS_QUAD
5441                 case 'q':       uv = (Quad_t)uv; break;
5442 #endif
5443                 }
5444             }
5445
5446         integer:
5447             eptr = ebuf + sizeof ebuf;
5448             switch (base) {
5449                 unsigned dig;
5450             case 16:
5451                 if (!uv)
5452                     alt = FALSE;
5453                 p = (char*)((c == 'X')
5454                             ? "0123456789ABCDEF" : "0123456789abcdef");
5455                 do {
5456                     dig = uv & 15;
5457                     *--eptr = p[dig];
5458                 } while (uv >>= 4);
5459                 if (alt) {
5460                     esignbuf[esignlen++] = '0';
5461                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
5462                 }
5463                 break;
5464             case 8:
5465                 do {
5466                     dig = uv & 7;
5467                     *--eptr = '0' + dig;
5468                 } while (uv >>= 3);
5469                 if (alt && *eptr != '0')
5470                     *--eptr = '0';
5471                 break;
5472             case 2:
5473                 do {
5474                     dig = uv & 1;
5475                     *--eptr = '0' + dig;
5476                 } while (uv >>= 1);
5477                 if (alt) {
5478                     esignbuf[esignlen++] = '0';
5479                     esignbuf[esignlen++] = 'b';
5480                 }
5481                 break;
5482             default:            /* it had better be ten or less */
5483 #if defined(PERL_Y2KWARN)
5484                 if (ckWARN(WARN_MISC)) {
5485                     STRLEN n;
5486                     char *s = SvPV(sv,n);
5487                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5488                         && (n == 2 || !isDIGIT(s[n-3])))
5489                     {
5490                         Perl_warner(aTHX_ WARN_MISC,
5491                                     "Possible Y2K bug: %%%c %s",
5492                                     c, "format string following '19'");
5493                     }
5494                 }
5495 #endif
5496                 do {
5497                     dig = uv % base;
5498                     *--eptr = '0' + dig;
5499                 } while (uv /= base);
5500                 break;
5501             }
5502             elen = (ebuf + sizeof ebuf) - eptr;
5503             if (has_precis) {
5504                 if (precis > elen)
5505                     zeros = precis - elen;
5506                 else if (precis == 0 && elen == 1 && *eptr == '0')
5507                     elen = 0;
5508             }
5509             break;
5510
5511             /* FLOATING POINT */
5512
5513         case 'F':
5514             c = 'f';            /* maybe %F isn't supported here */
5515             /* FALL THROUGH */
5516         case 'e': case 'E':
5517         case 'f':
5518         case 'g': case 'G':
5519
5520             /* This is evil, but floating point is even more evil */
5521
5522             if (args)
5523                 nv = va_arg(*args, NV);
5524             else
5525                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5526
5527             need = 0;
5528             if (c != 'e' && c != 'E') {
5529                 i = PERL_INT_MIN;
5530                 (void)frexp(nv, &i);
5531                 if (i == PERL_INT_MIN)
5532                     Perl_die(aTHX_ "panic: frexp");
5533                 if (i > 0)
5534                     need = BIT_DIGITS(i);
5535             }
5536             need += has_precis ? precis : 6; /* known default */
5537             if (need < width)
5538                 need = width;
5539
5540             need += 20; /* fudge factor */
5541             if (PL_efloatsize < need) {
5542                 Safefree(PL_efloatbuf);
5543                 PL_efloatsize = need + 20; /* more fudge */
5544                 New(906, PL_efloatbuf, PL_efloatsize, char);
5545                 PL_efloatbuf[0] = '\0';
5546             }
5547
5548             eptr = ebuf + sizeof ebuf;
5549             *--eptr = '\0';
5550             *--eptr = c;
5551 #ifdef USE_LONG_DOUBLE
5552             {
5553                 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5554                 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5555             }
5556 #endif
5557             if (has_precis) {
5558                 base = precis;
5559                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5560                 *--eptr = '.';
5561             }
5562             if (width) {
5563                 base = width;
5564                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5565             }
5566             if (fill == '0')
5567                 *--eptr = fill;
5568             if (left)
5569                 *--eptr = '-';
5570             if (plus)
5571                 *--eptr = plus;
5572             if (alt)
5573                 *--eptr = '#';
5574             *--eptr = '%';
5575
5576             {
5577                 RESTORE_NUMERIC_STANDARD();
5578                 (void)sprintf(PL_efloatbuf, eptr, nv);
5579                 RESTORE_NUMERIC_LOCAL();
5580             }
5581
5582             eptr = PL_efloatbuf;
5583             elen = strlen(PL_efloatbuf);
5584             break;
5585
5586             /* SPECIAL */
5587
5588         case 'n':
5589             i = SvCUR(sv) - origlen;
5590             if (args) {
5591                 switch (intsize) {
5592                 case 'h':       *(va_arg(*args, short*)) = i; break;
5593                 default:        *(va_arg(*args, int*)) = i; break;
5594                 case 'l':       *(va_arg(*args, long*)) = i; break;
5595                 case 'V':       *(va_arg(*args, IV*)) = i; break;
5596 #ifdef HAS_QUAD
5597                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
5598 #endif
5599                 }
5600             }
5601             else if (svix < svmax)
5602                 sv_setuv(svargs[svix++], (UV)i);
5603             continue;   /* not "break" */
5604
5605             /* UNKNOWN */
5606
5607         default:
5608       unknown:
5609             if (!args && ckWARN(WARN_PRINTF) &&
5610                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5611                 SV *msg = sv_newmortal();
5612                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5613                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5614                 if (c) {
5615                     if (isPRINT(c))
5616                         Perl_sv_catpvf(aTHX_ msg,
5617                                        "\"%%%c\"", c & 0xFF);
5618                     else
5619                         Perl_sv_catpvf(aTHX_ msg,
5620                                        "\"%%\\%03"UVof"\"",
5621                                        (UV)c & 0xFF);
5622                 } else
5623                     sv_catpv(msg, "end of string");
5624                 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5625             }
5626
5627             /* output mangled stuff ... */
5628             if (c == '\0')
5629                 --q;
5630             eptr = p;
5631             elen = q - p;
5632
5633             /* ... right here, because formatting flags should not apply */
5634             SvGROW(sv, SvCUR(sv) + elen + 1);
5635             p = SvEND(sv);
5636             memcpy(p, eptr, elen);
5637             p += elen;
5638             *p = '\0';
5639             SvCUR(sv) = p - SvPVX(sv);
5640             continue;   /* not "break" */
5641         }
5642
5643         have = esignlen + zeros + elen;
5644         need = (have > width ? have : width);
5645         gap = need - have;
5646
5647         SvGROW(sv, SvCUR(sv) + need + 1);
5648         p = SvEND(sv);
5649         if (esignlen && fill == '0') {
5650             for (i = 0; i < esignlen; i++)
5651                 *p++ = esignbuf[i];
5652         }
5653         if (gap && !left) {
5654             memset(p, fill, gap);
5655             p += gap;
5656         }
5657         if (esignlen && fill != '0') {
5658             for (i = 0; i < esignlen; i++)
5659                 *p++ = esignbuf[i];
5660         }
5661         if (zeros) {
5662             for (i = zeros; i; i--)
5663                 *p++ = '0';
5664         }
5665         if (elen) {
5666             memcpy(p, eptr, elen);
5667             p += elen;
5668         }
5669         if (gap && left) {
5670             memset(p, ' ', gap);
5671             p += gap;
5672         }
5673         *p = '\0';
5674         SvCUR(sv) = p - SvPVX(sv);
5675     }
5676 }
5677
5678 #if defined(USE_ITHREADS)
5679
5680 #if defined(USE_THREADS)
5681 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
5682 #endif
5683
5684 #ifndef OpREFCNT_inc
5685 #  define OpREFCNT_inc(o)       ((o) ? (++(o)->op_targ, (o)) : Nullop)
5686 #endif
5687
5688 #ifndef GpREFCNT_inc
5689 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
5690 #endif
5691
5692
5693 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
5694 #define av_dup(s)       (AV*)sv_dup((SV*)s)
5695 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5696 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
5697 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5698 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
5699 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5700 #define io_dup(s)       (IO*)sv_dup((SV*)s)
5701 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5702 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
5703 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5704 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
5705 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
5706
5707 REGEXP *
5708 Perl_re_dup(pTHX_ REGEXP *r)
5709 {
5710     /* XXX fix when pmop->op_pmregexp becomes shared */
5711     return ReREFCNT_inc(r);
5712 }
5713
5714 PerlIO *
5715 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5716 {
5717     PerlIO *ret;
5718     if (!fp)
5719         return (PerlIO*)NULL;
5720
5721     /* look for it in the table first */
5722     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
5723     if (ret)
5724         return ret;
5725
5726     /* create anew and remember what it is */
5727     ret = PerlIO_fdupopen(fp);
5728     ptr_table_store(PL_ptr_table, fp, ret);
5729     return ret;
5730 }
5731
5732 DIR *
5733 Perl_dirp_dup(pTHX_ DIR *dp)
5734 {
5735     if (!dp)
5736         return (DIR*)NULL;
5737     /* XXX TODO */
5738     return dp;
5739 }
5740
5741 GP *
5742 Perl_gp_dup(pTHX_ GP *gp)
5743 {
5744     GP *ret;
5745     if (!gp)
5746         return (GP*)NULL;
5747     /* look for it in the table first */
5748     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
5749     if (ret)
5750         return ret;
5751
5752     /* create anew and remember what it is */
5753     Newz(0, ret, 1, GP);
5754     ptr_table_store(PL_ptr_table, gp, ret);
5755
5756     /* clone */
5757     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
5758     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
5759     ret->gp_io          = io_dup_inc(gp->gp_io);
5760     ret->gp_form        = cv_dup_inc(gp->gp_form);
5761     ret->gp_av          = av_dup_inc(gp->gp_av);
5762     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
5763     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
5764     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
5765     ret->gp_cvgen       = gp->gp_cvgen;
5766     ret->gp_flags       = gp->gp_flags;
5767     ret->gp_line        = gp->gp_line;
5768     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
5769     return ret;
5770 }
5771
5772 MAGIC *
5773 Perl_mg_dup(pTHX_ MAGIC *mg)
5774 {
5775     MAGIC *mgret = (MAGIC*)NULL;
5776     MAGIC *mgprev;
5777     if (!mg)
5778         return (MAGIC*)NULL;
5779     /* look for it in the table first */
5780     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
5781     if (mgret)
5782         return mgret;
5783
5784     for (; mg; mg = mg->mg_moremagic) {
5785         MAGIC *nmg;
5786         Newz(0, nmg, 1, MAGIC);
5787         if (!mgret)
5788             mgret = nmg;
5789         else
5790             mgprev->mg_moremagic = nmg;
5791         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
5792         nmg->mg_private = mg->mg_private;
5793         nmg->mg_type    = mg->mg_type;
5794         nmg->mg_flags   = mg->mg_flags;
5795         if (mg->mg_type == 'r') {
5796             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5797         }
5798         else {
5799             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5800                               ? sv_dup_inc(mg->mg_obj)
5801                               : sv_dup(mg->mg_obj);
5802         }
5803         nmg->mg_len     = mg->mg_len;
5804         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
5805         if (mg->mg_ptr && mg->mg_type != 'g') {
5806             if (mg->mg_len >= 0) {
5807                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
5808                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
5809                     AMT *amtp = (AMT*)mg->mg_ptr;
5810                     AMT *namtp = (AMT*)nmg->mg_ptr;
5811                     I32 i;
5812                     for (i = 1; i < NofAMmeth; i++) {
5813                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
5814                     }
5815                 }
5816             }
5817             else if (mg->mg_len == HEf_SVKEY)
5818                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5819         }
5820         mgprev = nmg;
5821     }
5822     return mgret;
5823 }
5824
5825 PTR_TBL_t *
5826 Perl_ptr_table_new(pTHX)
5827 {
5828     PTR_TBL_t *tbl;
5829     Newz(0, tbl, 1, PTR_TBL_t);
5830     tbl->tbl_max        = 511;
5831     tbl->tbl_items      = 0;
5832     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
5833     return tbl;
5834 }
5835
5836 void *
5837 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
5838 {
5839     PTR_TBL_ENT_t *tblent;
5840     UV hash = (UV)sv;
5841     assert(tbl);
5842     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5843     for (; tblent; tblent = tblent->next) {
5844         if (tblent->oldval == sv)
5845             return tblent->newval;
5846     }
5847     return (void*)NULL;
5848 }
5849
5850 void
5851 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
5852 {
5853     PTR_TBL_ENT_t *tblent, **otblent;
5854     /* XXX this may be pessimal on platforms where pointers aren't good
5855      * hash values e.g. if they grow faster in the most significant
5856      * bits */
5857     UV hash = (UV)oldv;
5858     bool i = 1;
5859
5860     assert(tbl);
5861     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5862     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5863         if (tblent->oldval == oldv) {
5864             tblent->newval = newv;
5865             tbl->tbl_items++;
5866             return;
5867         }
5868     }
5869     Newz(0, tblent, 1, PTR_TBL_ENT_t);
5870     tblent->oldval = oldv;
5871     tblent->newval = newv;
5872     tblent->next = *otblent;
5873     *otblent = tblent;
5874     tbl->tbl_items++;
5875     if (i && tbl->tbl_items > tbl->tbl_max)
5876         ptr_table_split(tbl);
5877 }
5878
5879 void
5880 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
5881 {
5882     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
5883     UV oldsize = tbl->tbl_max + 1;
5884     UV newsize = oldsize * 2;
5885     UV i;
5886
5887     Renew(ary, newsize, PTR_TBL_ENT_t*);
5888     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
5889     tbl->tbl_max = --newsize;
5890     tbl->tbl_ary = ary;
5891     for (i=0; i < oldsize; i++, ary++) {
5892         PTR_TBL_ENT_t **curentp, **entp, *ent;
5893         if (!*ary)
5894             continue;
5895         curentp = ary + oldsize;
5896         for (entp = ary, ent = *ary; ent; ent = *entp) {
5897             if ((newsize & (UV)ent->oldval) != i) {
5898                 *entp = ent->next;
5899                 ent->next = *curentp;
5900                 *curentp = ent;
5901                 continue;
5902             }
5903             else
5904                 entp = &ent->next;
5905         }
5906     }
5907 }
5908
5909 #ifdef DEBUGGING
5910 char *PL_watch_pvx;
5911 #endif
5912
5913 SV *
5914 Perl_sv_dup(pTHX_ SV *sstr)
5915 {
5916     U32 sflags;
5917     int dtype;
5918     int stype;
5919     SV *dstr;
5920
5921     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
5922         return Nullsv;
5923     /* look for it in the table first */
5924     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
5925     if (dstr)
5926         return dstr;
5927
5928     /* create anew and remember what it is */
5929     new_SV(dstr);
5930     ptr_table_store(PL_ptr_table, sstr, dstr);
5931
5932     /* clone */
5933     SvFLAGS(dstr)       = SvFLAGS(sstr);
5934     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
5935     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
5936
5937 #ifdef DEBUGGING
5938     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
5939         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
5940                       PL_watch_pvx, SvPVX(sstr));
5941 #endif
5942
5943     switch (SvTYPE(sstr)) {
5944     case SVt_NULL:
5945         SvANY(dstr)     = NULL;
5946         break;
5947     case SVt_IV:
5948         SvANY(dstr)     = new_XIV();
5949         SvIVX(dstr)     = SvIVX(sstr);
5950         break;
5951     case SVt_NV:
5952         SvANY(dstr)     = new_XNV();
5953         SvNVX(dstr)     = SvNVX(sstr);
5954         break;
5955     case SVt_RV:
5956         SvANY(dstr)     = new_XRV();
5957         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
5958         break;
5959     case SVt_PV:
5960         SvANY(dstr)     = new_XPV();
5961         SvCUR(dstr)     = SvCUR(sstr);
5962         SvLEN(dstr)     = SvLEN(sstr);
5963         if (SvROK(sstr))
5964             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5965         else if (SvPVX(sstr) && SvLEN(sstr))
5966             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5967         else
5968             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5969         break;
5970     case SVt_PVIV:
5971         SvANY(dstr)     = new_XPVIV();
5972         SvCUR(dstr)     = SvCUR(sstr);
5973         SvLEN(dstr)     = SvLEN(sstr);
5974         SvIVX(dstr)     = SvIVX(sstr);
5975         if (SvROK(sstr))
5976             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5977         else if (SvPVX(sstr) && SvLEN(sstr))
5978             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5979         else
5980             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5981         break;
5982     case SVt_PVNV:
5983         SvANY(dstr)     = new_XPVNV();
5984         SvCUR(dstr)     = SvCUR(sstr);
5985         SvLEN(dstr)     = SvLEN(sstr);
5986         SvIVX(dstr)     = SvIVX(sstr);
5987         SvNVX(dstr)     = SvNVX(sstr);
5988         if (SvROK(sstr))
5989             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5990         else if (SvPVX(sstr) && SvLEN(sstr))
5991             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5992         else
5993             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5994         break;
5995     case SVt_PVMG:
5996         SvANY(dstr)     = new_XPVMG();
5997         SvCUR(dstr)     = SvCUR(sstr);
5998         SvLEN(dstr)     = SvLEN(sstr);
5999         SvIVX(dstr)     = SvIVX(sstr);
6000         SvNVX(dstr)     = SvNVX(sstr);
6001         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6002         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6003         if (SvROK(sstr))
6004             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6005         else if (SvPVX(sstr) && SvLEN(sstr))
6006             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6007         else
6008             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6009         break;
6010     case SVt_PVBM:
6011         SvANY(dstr)     = new_XPVBM();
6012         SvCUR(dstr)     = SvCUR(sstr);
6013         SvLEN(dstr)     = SvLEN(sstr);
6014         SvIVX(dstr)     = SvIVX(sstr);
6015         SvNVX(dstr)     = SvNVX(sstr);
6016         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6017         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6018         if (SvROK(sstr))
6019             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6020         else if (SvPVX(sstr) && SvLEN(sstr))
6021             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6022         else
6023             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6024         BmRARE(dstr)    = BmRARE(sstr);
6025         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
6026         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6027         break;
6028     case SVt_PVLV:
6029         SvANY(dstr)     = new_XPVLV();
6030         SvCUR(dstr)     = SvCUR(sstr);
6031         SvLEN(dstr)     = SvLEN(sstr);
6032         SvIVX(dstr)     = SvIVX(sstr);
6033         SvNVX(dstr)     = SvNVX(sstr);
6034         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6035         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6036         if (SvROK(sstr))
6037             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6038         else if (SvPVX(sstr) && SvLEN(sstr))
6039             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6040         else
6041             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6042         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
6043         LvTARGLEN(dstr) = LvTARGLEN(sstr);
6044         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
6045         LvTYPE(dstr)    = LvTYPE(sstr);
6046         break;
6047     case SVt_PVGV:
6048         SvANY(dstr)     = new_XPVGV();
6049         SvCUR(dstr)     = SvCUR(sstr);
6050         SvLEN(dstr)     = SvLEN(sstr);
6051         SvIVX(dstr)     = SvIVX(sstr);
6052         SvNVX(dstr)     = SvNVX(sstr);
6053         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6054         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6055         if (SvROK(sstr))
6056             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6057         else if (SvPVX(sstr) && SvLEN(sstr))
6058             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6059         else
6060             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6061         GvNAMELEN(dstr) = GvNAMELEN(sstr);
6062         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6063         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
6064         GvFLAGS(dstr)   = GvFLAGS(sstr);
6065         GvGP(dstr)      = gp_dup(GvGP(sstr));
6066         (void)GpREFCNT_inc(GvGP(dstr));
6067         break;
6068     case SVt_PVIO:
6069         SvANY(dstr)     = new_XPVIO();
6070         SvCUR(dstr)     = SvCUR(sstr);
6071         SvLEN(dstr)     = SvLEN(sstr);
6072         SvIVX(dstr)     = SvIVX(sstr);
6073         SvNVX(dstr)     = SvNVX(sstr);
6074         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6075         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6076         if (SvROK(sstr))
6077             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6078         else if (SvPVX(sstr) && SvLEN(sstr))
6079             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6080         else
6081             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6082         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6083         if (IoOFP(sstr) == IoIFP(sstr))
6084             IoOFP(dstr) = IoIFP(dstr);
6085         else
6086             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6087         /* PL_rsfp_filters entries have fake IoDIRP() */
6088         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6089             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
6090         else
6091             IoDIRP(dstr)        = IoDIRP(sstr);
6092         IoLINES(dstr)           = IoLINES(sstr);
6093         IoPAGE(dstr)            = IoPAGE(sstr);
6094         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
6095         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
6096         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
6097         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
6098         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
6099         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
6100         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
6101         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
6102         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
6103         IoTYPE(dstr)            = IoTYPE(sstr);
6104         IoFLAGS(dstr)           = IoFLAGS(sstr);
6105         break;
6106     case SVt_PVAV:
6107         SvANY(dstr)     = new_XPVAV();
6108         SvCUR(dstr)     = SvCUR(sstr);
6109         SvLEN(dstr)     = SvLEN(sstr);
6110         SvIVX(dstr)     = SvIVX(sstr);
6111         SvNVX(dstr)     = SvNVX(sstr);
6112         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6113         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6114         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6115         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6116         if (AvARRAY((AV*)sstr)) {
6117             SV **dst_ary, **src_ary;
6118             SSize_t items = AvFILLp((AV*)sstr) + 1;
6119
6120             src_ary = AvARRAY((AV*)sstr);
6121             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6122             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6123             SvPVX(dstr) = (char*)dst_ary;
6124             AvALLOC((AV*)dstr) = dst_ary;
6125             if (AvREAL((AV*)sstr)) {
6126                 while (items-- > 0)
6127                     *dst_ary++ = sv_dup_inc(*src_ary++);
6128             }
6129             else {
6130                 while (items-- > 0)
6131                     *dst_ary++ = sv_dup(*src_ary++);
6132             }
6133             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6134             while (items-- > 0) {
6135                 *dst_ary++ = &PL_sv_undef;
6136             }
6137         }
6138         else {
6139             SvPVX(dstr)         = Nullch;
6140             AvALLOC((AV*)dstr)  = (SV**)NULL;
6141         }
6142         break;
6143     case SVt_PVHV:
6144         SvANY(dstr)     = new_XPVHV();
6145         SvCUR(dstr)     = SvCUR(sstr);
6146         SvLEN(dstr)     = SvLEN(sstr);
6147         SvIVX(dstr)     = SvIVX(sstr);
6148         SvNVX(dstr)     = SvNVX(sstr);
6149         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6150         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6151         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
6152         if (HvARRAY((HV*)sstr)) {
6153             HE *entry;
6154             STRLEN i = 0;
6155             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6156             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6157             Newz(0, dxhv->xhv_array,
6158                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6159             while (i <= sxhv->xhv_max) {
6160                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6161                                                     !!HvSHAREKEYS(sstr));
6162                 ++i;
6163             }
6164             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6165         }
6166         else {
6167             SvPVX(dstr)         = Nullch;
6168             HvEITER((HV*)dstr)  = (HE*)NULL;
6169         }
6170         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
6171         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
6172         break;
6173     case SVt_PVFM:
6174         SvANY(dstr)     = new_XPVFM();
6175         FmLINES(dstr)   = FmLINES(sstr);
6176         goto dup_pvcv;
6177         /* NOTREACHED */
6178     case SVt_PVCV:
6179         SvANY(dstr)     = new_XPVCV();
6180 dup_pvcv:
6181         SvCUR(dstr)     = SvCUR(sstr);
6182         SvLEN(dstr)     = SvLEN(sstr);
6183         SvIVX(dstr)     = SvIVX(sstr);
6184         SvNVX(dstr)     = SvNVX(sstr);
6185         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6186         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6187         if (SvPVX(sstr) && SvLEN(sstr))
6188             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6189         else
6190             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6191         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6192         CvSTART(dstr)   = CvSTART(sstr);
6193         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
6194         CvXSUB(dstr)    = CvXSUB(sstr);
6195         CvXSUBANY(dstr) = CvXSUBANY(sstr);
6196         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
6197         CvDEPTH(dstr)   = CvDEPTH(sstr);
6198         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6199             /* XXX padlists are real, but pretend to be not */
6200             AvREAL_on(CvPADLIST(sstr));
6201             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6202             AvREAL_off(CvPADLIST(sstr));
6203             AvREAL_off(CvPADLIST(dstr));
6204         }
6205         else
6206             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6207         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6208         CvFLAGS(dstr)   = CvFLAGS(sstr);
6209         break;
6210     default:
6211         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6212         break;
6213     }
6214
6215     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6216         ++PL_sv_objcount;
6217
6218     return dstr;
6219 }
6220
6221 PERL_CONTEXT *
6222 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6223 {
6224     PERL_CONTEXT *ncxs;
6225
6226     if (!cxs)
6227         return (PERL_CONTEXT*)NULL;
6228
6229     /* look for it in the table first */
6230     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6231     if (ncxs)
6232         return ncxs;
6233
6234     /* create anew and remember what it is */
6235     Newz(56, ncxs, max + 1, PERL_CONTEXT);
6236     ptr_table_store(PL_ptr_table, cxs, ncxs);
6237
6238     while (ix >= 0) {
6239         PERL_CONTEXT *cx = &cxs[ix];
6240         PERL_CONTEXT *ncx = &ncxs[ix];
6241         ncx->cx_type    = cx->cx_type;
6242         if (CxTYPE(cx) == CXt_SUBST) {
6243             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6244         }
6245         else {
6246             ncx->blk_oldsp      = cx->blk_oldsp;
6247             ncx->blk_oldcop     = cx->blk_oldcop;
6248             ncx->blk_oldretsp   = cx->blk_oldretsp;
6249             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
6250             ncx->blk_oldscopesp = cx->blk_oldscopesp;
6251             ncx->blk_oldpm      = cx->blk_oldpm;
6252             ncx->blk_gimme      = cx->blk_gimme;
6253             switch (CxTYPE(cx)) {
6254             case CXt_SUB:
6255                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
6256                                            ? cv_dup_inc(cx->blk_sub.cv)
6257                                            : cv_dup(cx->blk_sub.cv));
6258                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
6259                                            ? av_dup_inc(cx->blk_sub.argarray)
6260                                            : Nullav);
6261                 ncx->blk_sub.savearray  = av_dup(cx->blk_sub.savearray);
6262                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
6263                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6264                 ncx->blk_sub.lval       = cx->blk_sub.lval;
6265                 break;
6266             case CXt_EVAL:
6267                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6268                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6269                 ncx->blk_eval.old_name  = SAVEPV(cx->blk_eval.old_name);
6270                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6271                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
6272                 break;
6273             case CXt_LOOP:
6274                 ncx->blk_loop.label     = cx->blk_loop.label;
6275                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
6276                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
6277                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
6278                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
6279                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
6280                                            ? cx->blk_loop.iterdata
6281                                            : gv_dup((GV*)cx->blk_loop.iterdata));
6282                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
6283                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
6284                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
6285                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
6286                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
6287                 break;
6288             case CXt_FORMAT:
6289                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
6290                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
6291                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
6292                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6293                 break;
6294             case CXt_BLOCK:
6295             case CXt_NULL:
6296                 break;
6297             }
6298         }
6299         --ix;
6300     }
6301     return ncxs;
6302 }
6303
6304 PERL_SI *
6305 Perl_si_dup(pTHX_ PERL_SI *si)
6306 {
6307     PERL_SI *nsi;
6308
6309     if (!si)
6310         return (PERL_SI*)NULL;
6311
6312     /* look for it in the table first */
6313     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6314     if (nsi)
6315         return nsi;
6316
6317     /* create anew and remember what it is */
6318     Newz(56, nsi, 1, PERL_SI);
6319     ptr_table_store(PL_ptr_table, si, nsi);
6320
6321     nsi->si_stack       = av_dup_inc(si->si_stack);
6322     nsi->si_cxix        = si->si_cxix;
6323     nsi->si_cxmax       = si->si_cxmax;
6324     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6325     nsi->si_type        = si->si_type;
6326     nsi->si_prev        = si_dup(si->si_prev);
6327     nsi->si_next        = si_dup(si->si_next);
6328     nsi->si_markoff     = si->si_markoff;
6329
6330     return nsi;
6331 }
6332
6333 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
6334 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
6335 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
6336 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
6337 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
6338 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
6339 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
6340 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
6341 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
6342 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
6343 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
6344 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
6345
6346 /* XXXXX todo */
6347 #define pv_dup_inc(p)   SAVEPV(p)
6348 #define pv_dup(p)       SAVEPV(p)
6349 #define svp_dup_inc(p,pp)       any_dup(p,pp)
6350
6351 void *
6352 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
6353 {
6354     void *ret;
6355
6356     if (!v)
6357         return (void*)NULL;
6358
6359     /* look for it in the table first */
6360     ret = ptr_table_fetch(PL_ptr_table, v);
6361     if (ret)
6362         return ret;
6363
6364     /* see if it is part of the interpreter structure */
6365     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
6366         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
6367     else
6368         ret = v;
6369
6370     return ret;
6371 }
6372
6373 ANY *
6374 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
6375 {
6376     ANY *ss     = proto_perl->Tsavestack;
6377     I32 ix      = proto_perl->Tsavestack_ix;
6378     I32 max     = proto_perl->Tsavestack_max;
6379     ANY *nss;
6380     SV *sv;
6381     GV *gv;
6382     AV *av;
6383     HV *hv;
6384     void* ptr;
6385     int intval;
6386     long longval;
6387     GP *gp;
6388     IV iv;
6389     I32 i;
6390     char *c;
6391     void (*dptr) (void*);
6392     void (*dxptr) (pTHXo_ void*);
6393
6394     Newz(54, nss, max, ANY);
6395
6396     while (ix > 0) {
6397         i = POPINT(ss,ix);
6398         TOPINT(nss,ix) = i;
6399         switch (i) {
6400         case SAVEt_ITEM:                        /* normal string */
6401             sv = (SV*)POPPTR(ss,ix);
6402             TOPPTR(nss,ix) = sv_dup_inc(sv);
6403             sv = (SV*)POPPTR(ss,ix);
6404             TOPPTR(nss,ix) = sv_dup_inc(sv);
6405             break;
6406         case SAVEt_SV:                          /* scalar reference */
6407             sv = (SV*)POPPTR(ss,ix);
6408             TOPPTR(nss,ix) = sv_dup_inc(sv);
6409             gv = (GV*)POPPTR(ss,ix);
6410             TOPPTR(nss,ix) = gv_dup_inc(gv);
6411             break;
6412         case SAVEt_GENERIC_SVREF:               /* generic sv */
6413         case SAVEt_SVREF:                       /* scalar reference */
6414             sv = (SV*)POPPTR(ss,ix);
6415             TOPPTR(nss,ix) = sv_dup_inc(sv);
6416             ptr = POPPTR(ss,ix);
6417             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
6418             break;
6419         case SAVEt_AV:                          /* array reference */
6420             av = (AV*)POPPTR(ss,ix);
6421             TOPPTR(nss,ix) = av_dup_inc(av);
6422             gv = (GV*)POPPTR(ss,ix);
6423             TOPPTR(nss,ix) = gv_dup(gv);
6424             break;
6425         case SAVEt_HV:                          /* hash reference */
6426             hv = (HV*)POPPTR(ss,ix);
6427             TOPPTR(nss,ix) = hv_dup_inc(hv);
6428             gv = (GV*)POPPTR(ss,ix);
6429             TOPPTR(nss,ix) = gv_dup(gv);
6430             break;
6431         case SAVEt_INT:                         /* int reference */
6432             ptr = POPPTR(ss,ix);
6433             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6434             intval = (int)POPINT(ss,ix);
6435             TOPINT(nss,ix) = intval;
6436             break;
6437         case SAVEt_LONG:                        /* long reference */
6438             ptr = POPPTR(ss,ix);
6439             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6440             longval = (long)POPLONG(ss,ix);
6441             TOPLONG(nss,ix) = longval;
6442             break;
6443         case SAVEt_I32:                         /* I32 reference */
6444         case SAVEt_I16:                         /* I16 reference */
6445         case SAVEt_I8:                          /* I8 reference */
6446             ptr = POPPTR(ss,ix);
6447             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6448             i = POPINT(ss,ix);
6449             TOPINT(nss,ix) = i;
6450             break;
6451         case SAVEt_IV:                          /* IV reference */
6452             ptr = POPPTR(ss,ix);
6453             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6454             iv = POPIV(ss,ix);
6455             TOPIV(nss,ix) = iv;
6456             break;
6457         case SAVEt_SPTR:                        /* SV* reference */
6458             ptr = POPPTR(ss,ix);
6459             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6460             sv = (SV*)POPPTR(ss,ix);
6461             TOPPTR(nss,ix) = sv_dup(sv);
6462             break;
6463         case SAVEt_VPTR:                        /* random* reference */
6464             ptr = POPPTR(ss,ix);
6465             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6466             ptr = POPPTR(ss,ix);
6467             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6468             break;
6469         case SAVEt_PPTR:                        /* char* reference */
6470             ptr = POPPTR(ss,ix);
6471             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6472             c = (char*)POPPTR(ss,ix);
6473             TOPPTR(nss,ix) = pv_dup(c);
6474             break;
6475         case SAVEt_HPTR:                        /* HV* reference */
6476             ptr = POPPTR(ss,ix);
6477             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6478             hv = (HV*)POPPTR(ss,ix);
6479             TOPPTR(nss,ix) = hv_dup(hv);
6480             break;
6481         case SAVEt_APTR:                        /* AV* reference */
6482             ptr = POPPTR(ss,ix);
6483             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6484             av = (AV*)POPPTR(ss,ix);
6485             TOPPTR(nss,ix) = av_dup(av);
6486             break;
6487         case SAVEt_NSTAB:
6488             gv = (GV*)POPPTR(ss,ix);
6489             TOPPTR(nss,ix) = gv_dup(gv);
6490             break;
6491         case SAVEt_GP:                          /* scalar reference */
6492             gp = (GP*)POPPTR(ss,ix);
6493             TOPPTR(nss,ix) = gp = gp_dup(gp);
6494             (void)GpREFCNT_inc(gp);
6495             gv = (GV*)POPPTR(ss,ix);
6496             TOPPTR(nss,ix) = gv_dup_inc(c);
6497             c = (char*)POPPTR(ss,ix);
6498             TOPPTR(nss,ix) = pv_dup(c);
6499             iv = POPIV(ss,ix);
6500             TOPIV(nss,ix) = iv;
6501             iv = POPIV(ss,ix);
6502             TOPIV(nss,ix) = iv;
6503             break;
6504         case SAVEt_FREESV:
6505             sv = (SV*)POPPTR(ss,ix);
6506             TOPPTR(nss,ix) = sv_dup_inc(sv);
6507             break;
6508         case SAVEt_FREEOP:
6509             ptr = POPPTR(ss,ix);
6510             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
6511                 /* these are assumed to be refcounted properly */
6512                 switch (((OP*)ptr)->op_type) {
6513                 case OP_LEAVESUB:
6514                 case OP_LEAVESUBLV:
6515                 case OP_LEAVEEVAL:
6516                 case OP_LEAVE:
6517                 case OP_SCOPE:
6518                 case OP_LEAVEWRITE:
6519                     TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6520                     break;
6521                 default:
6522                     TOPPTR(nss,ix) = Nullop;
6523                     break;
6524                 }
6525             }
6526             else
6527                 TOPPTR(nss,ix) = Nullop;
6528             break;
6529         case SAVEt_FREEPV:
6530             c = (char*)POPPTR(ss,ix);
6531             TOPPTR(nss,ix) = pv_dup_inc(c);
6532             break;
6533         case SAVEt_CLEARSV:
6534             longval = POPLONG(ss,ix);
6535             TOPLONG(nss,ix) = longval;
6536             break;
6537         case SAVEt_DELETE:
6538             hv = (HV*)POPPTR(ss,ix);
6539             TOPPTR(nss,ix) = hv_dup_inc(hv);
6540             c = (char*)POPPTR(ss,ix);
6541             TOPPTR(nss,ix) = pv_dup_inc(c);
6542             i = POPINT(ss,ix);
6543             TOPINT(nss,ix) = i;
6544             break;
6545         case SAVEt_DESTRUCTOR:
6546             ptr = POPPTR(ss,ix);
6547             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
6548             dptr = POPDPTR(ss,ix);
6549             TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
6550             break;
6551         case SAVEt_DESTRUCTOR_X:
6552             ptr = POPPTR(ss,ix);
6553             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
6554             dxptr = POPDXPTR(ss,ix);
6555             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
6556             break;
6557         case SAVEt_REGCONTEXT:
6558         case SAVEt_ALLOC:
6559             i = POPINT(ss,ix);
6560             TOPINT(nss,ix) = i;
6561             ix -= i;
6562             break;
6563         case SAVEt_STACK_POS:           /* Position on Perl stack */
6564             i = POPINT(ss,ix);
6565             TOPINT(nss,ix) = i;
6566             break;
6567         case SAVEt_AELEM:               /* array element */
6568             sv = (SV*)POPPTR(ss,ix);
6569             TOPPTR(nss,ix) = sv_dup_inc(sv);
6570             i = POPINT(ss,ix);
6571             TOPINT(nss,ix) = i;
6572             av = (AV*)POPPTR(ss,ix);
6573             TOPPTR(nss,ix) = av_dup_inc(av);
6574             break;
6575         case SAVEt_HELEM:               /* hash element */
6576             sv = (SV*)POPPTR(ss,ix);
6577             TOPPTR(nss,ix) = sv_dup_inc(sv);
6578             sv = (SV*)POPPTR(ss,ix);
6579             TOPPTR(nss,ix) = sv_dup_inc(sv);
6580             hv = (HV*)POPPTR(ss,ix);
6581             TOPPTR(nss,ix) = hv_dup_inc(hv);
6582             break;
6583         case SAVEt_OP:
6584             ptr = POPPTR(ss,ix);
6585             TOPPTR(nss,ix) = ptr;
6586             break;
6587         case SAVEt_HINTS:
6588             i = POPINT(ss,ix);
6589             TOPINT(nss,ix) = i;
6590             break;
6591         default:
6592             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
6593         }
6594     }
6595
6596     return nss;
6597 }
6598
6599 #ifdef PERL_OBJECT
6600 #include "XSUB.h"
6601 #endif
6602
6603 PerlInterpreter *
6604 perl_clone(PerlInterpreter *proto_perl, UV flags)
6605 {
6606 #ifdef PERL_OBJECT
6607     CPerlObj *pPerl = (CPerlObj*)proto_perl;
6608 #endif
6609
6610 #ifdef PERL_IMPLICIT_SYS
6611     return perl_clone_using(proto_perl, flags,
6612                             proto_perl->IMem,
6613                             proto_perl->IMemShared,
6614                             proto_perl->IMemParse,
6615                             proto_perl->IEnv,
6616                             proto_perl->IStdIO,
6617                             proto_perl->ILIO,
6618                             proto_perl->IDir,
6619                             proto_perl->ISock,
6620                             proto_perl->IProc);
6621 }
6622
6623 PerlInterpreter *
6624 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
6625                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
6626                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
6627                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6628                  struct IPerlDir* ipD, struct IPerlSock* ipS,
6629                  struct IPerlProc* ipP)
6630 {
6631     /* XXX many of the string copies here can be optimized if they're
6632      * constants; they need to be allocated as common memory and just
6633      * their pointers copied. */
6634
6635     IV i;
6636     SV *sv;
6637     SV **svp;
6638 #  ifdef PERL_OBJECT
6639     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
6640                                         ipD, ipS, ipP);
6641     PERL_SET_INTERP(pPerl);
6642 #  else         /* !PERL_OBJECT */
6643     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6644     PERL_SET_INTERP(my_perl);
6645
6646 #    ifdef DEBUGGING
6647     memset(my_perl, 0xab, sizeof(PerlInterpreter));
6648     PL_markstack = 0;
6649     PL_scopestack = 0;
6650     PL_savestack = 0;
6651     PL_retstack = 0;
6652 #    else       /* !DEBUGGING */
6653     Zero(my_perl, 1, PerlInterpreter);
6654 #    endif      /* DEBUGGING */
6655
6656     /* host pointers */
6657     PL_Mem              = ipM;
6658     PL_MemShared        = ipMS;
6659     PL_MemParse         = ipMP;
6660     PL_Env              = ipE;
6661     PL_StdIO            = ipStd;
6662     PL_LIO              = ipLIO;
6663     PL_Dir              = ipD;
6664     PL_Sock             = ipS;
6665     PL_Proc             = ipP;
6666 #  endif        /* PERL_OBJECT */
6667 #else           /* !PERL_IMPLICIT_SYS */
6668     IV i;
6669     SV *sv;
6670     SV **svp;
6671     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
6672     PERL_SET_INTERP(my_perl);
6673
6674 #    ifdef DEBUGGING
6675     memset(my_perl, 0xab, sizeof(PerlInterpreter));
6676     PL_markstack = 0;
6677     PL_scopestack = 0;
6678     PL_savestack = 0;
6679     PL_retstack = 0;
6680 #    else       /* !DEBUGGING */
6681     Zero(my_perl, 1, PerlInterpreter);
6682 #    endif      /* DEBUGGING */
6683 #endif          /* PERL_IMPLICIT_SYS */
6684
6685     /* arena roots */
6686     PL_xiv_arenaroot    = NULL;
6687     PL_xiv_root         = NULL;
6688     PL_xnv_root         = NULL;
6689     PL_xrv_root         = NULL;
6690     PL_xpv_root         = NULL;
6691     PL_xpviv_root       = NULL;
6692     PL_xpvnv_root       = NULL;
6693     PL_xpvcv_root       = NULL;
6694     PL_xpvav_root       = NULL;
6695     PL_xpvhv_root       = NULL;
6696     PL_xpvmg_root       = NULL;
6697     PL_xpvlv_root       = NULL;
6698     PL_xpvbm_root       = NULL;
6699     PL_he_root          = NULL;
6700     PL_nice_chunk       = NULL;
6701     PL_nice_chunk_size  = 0;
6702     PL_sv_count         = 0;
6703     PL_sv_objcount      = 0;
6704     PL_sv_root          = Nullsv;
6705     PL_sv_arenaroot     = Nullsv;
6706
6707     PL_debug            = proto_perl->Idebug;
6708
6709     /* create SV map for pointer relocation */
6710     PL_ptr_table = ptr_table_new();
6711
6712     /* initialize these special pointers as early as possible */
6713     SvANY(&PL_sv_undef)         = NULL;
6714     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
6715     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
6716     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
6717
6718 #ifdef PERL_OBJECT
6719     SvUPGRADE(&PL_sv_no, SVt_PVNV);
6720 #else
6721     SvANY(&PL_sv_no)            = new_XPVNV();
6722 #endif
6723     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
6724     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6725     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
6726     SvCUR(&PL_sv_no)            = 0;
6727     SvLEN(&PL_sv_no)            = 1;
6728     SvNVX(&PL_sv_no)            = 0;
6729     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
6730
6731 #ifdef PERL_OBJECT
6732     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
6733 #else
6734     SvANY(&PL_sv_yes)           = new_XPVNV();
6735 #endif
6736     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
6737     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6738     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
6739     SvCUR(&PL_sv_yes)           = 1;
6740     SvLEN(&PL_sv_yes)           = 2;
6741     SvNVX(&PL_sv_yes)           = 1;
6742     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
6743
6744     /* create shared string table */
6745     PL_strtab           = newHV();
6746     HvSHAREKEYS_off(PL_strtab);
6747     hv_ksplit(PL_strtab, 512);
6748     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
6749
6750     PL_compiling                = proto_perl->Icompiling;
6751     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
6752     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
6753     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
6754     if (!specialWARN(PL_compiling.cop_warnings))
6755         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6756     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
6757
6758     /* pseudo environmental stuff */
6759     PL_origargc         = proto_perl->Iorigargc;
6760     i = PL_origargc;
6761     New(0, PL_origargv, i+1, char*);
6762     PL_origargv[i] = '\0';
6763     while (i-- > 0) {
6764         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
6765     }
6766     PL_envgv            = gv_dup(proto_perl->Ienvgv);
6767     PL_incgv            = gv_dup(proto_perl->Iincgv);
6768     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
6769     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
6770     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
6771     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
6772
6773     /* switches */
6774     PL_minus_c          = proto_perl->Iminus_c;
6775     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
6776     PL_localpatches     = proto_perl->Ilocalpatches;
6777     PL_splitstr         = proto_perl->Isplitstr;
6778     PL_preprocess       = proto_perl->Ipreprocess;
6779     PL_minus_n          = proto_perl->Iminus_n;
6780     PL_minus_p          = proto_perl->Iminus_p;
6781     PL_minus_l          = proto_perl->Iminus_l;
6782     PL_minus_a          = proto_perl->Iminus_a;
6783     PL_minus_F          = proto_perl->Iminus_F;
6784     PL_doswitches       = proto_perl->Idoswitches;
6785     PL_dowarn           = proto_perl->Idowarn;
6786     PL_doextract        = proto_perl->Idoextract;
6787     PL_sawampersand     = proto_perl->Isawampersand;
6788     PL_unsafe           = proto_perl->Iunsafe;
6789     PL_inplace          = SAVEPV(proto_perl->Iinplace);
6790     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
6791     PL_perldb           = proto_perl->Iperldb;
6792     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6793
6794     /* magical thingies */
6795     /* XXX time(&PL_basetime) when asked for? */
6796     PL_basetime         = proto_perl->Ibasetime;
6797     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
6798
6799     PL_maxsysfd         = proto_perl->Imaxsysfd;
6800     PL_multiline        = proto_perl->Imultiline;
6801     PL_statusvalue      = proto_perl->Istatusvalue;
6802 #ifdef VMS
6803     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
6804 #endif
6805
6806     /* shortcuts to various I/O objects */
6807     PL_stdingv          = gv_dup(proto_perl->Istdingv);
6808     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
6809     PL_defgv            = gv_dup(proto_perl->Idefgv);
6810     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
6811     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
6812     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
6813
6814     /* shortcuts to regexp stuff */
6815     PL_replgv           = gv_dup(proto_perl->Ireplgv);
6816
6817     /* shortcuts to misc objects */
6818     PL_errgv            = gv_dup(proto_perl->Ierrgv);
6819
6820     /* shortcuts to debugging objects */
6821     PL_DBgv             = gv_dup(proto_perl->IDBgv);
6822     PL_DBline           = gv_dup(proto_perl->IDBline);
6823     PL_DBsub            = gv_dup(proto_perl->IDBsub);
6824     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
6825     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
6826     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
6827     PL_lineary          = av_dup(proto_perl->Ilineary);
6828     PL_dbargs           = av_dup(proto_perl->Idbargs);
6829
6830     /* symbol tables */
6831     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
6832     PL_curstash         = hv_dup(proto_perl->Tcurstash);
6833     PL_debstash         = hv_dup(proto_perl->Idebstash);
6834     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
6835     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
6836
6837     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
6838     PL_endav            = av_dup_inc(proto_perl->Iendav);
6839     PL_stopav           = av_dup_inc(proto_perl->Istopav);
6840     PL_initav           = av_dup_inc(proto_perl->Iinitav);
6841
6842     PL_sub_generation   = proto_perl->Isub_generation;
6843
6844     /* funky return mechanisms */
6845     PL_forkprocess      = proto_perl->Iforkprocess;
6846
6847     /* subprocess state */
6848     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
6849
6850     /* internal state */
6851     PL_tainting         = proto_perl->Itainting;
6852     PL_maxo             = proto_perl->Imaxo;
6853     if (proto_perl->Iop_mask)
6854         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6855     else
6856         PL_op_mask      = Nullch;
6857
6858     /* current interpreter roots */
6859     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
6860     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
6861     PL_main_start       = proto_perl->Imain_start;
6862     PL_eval_root        = OpREFCNT_inc(proto_perl->Ieval_root);
6863     PL_eval_start       = proto_perl->Ieval_start;
6864
6865     /* runtime control stuff */
6866     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
6867     PL_copline          = proto_perl->Icopline;
6868
6869     PL_filemode         = proto_perl->Ifilemode;
6870     PL_lastfd           = proto_perl->Ilastfd;
6871     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
6872     PL_Argv             = NULL;
6873     PL_Cmd              = Nullch;
6874     PL_gensym           = proto_perl->Igensym;
6875     PL_preambled        = proto_perl->Ipreambled;
6876     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
6877     PL_laststatval      = proto_perl->Ilaststatval;
6878     PL_laststype        = proto_perl->Ilaststype;
6879     PL_mess_sv          = Nullsv;
6880
6881     PL_orslen           = proto_perl->Iorslen;
6882     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
6883     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
6884
6885     /* interpreter atexit processing */
6886     PL_exitlistlen      = proto_perl->Iexitlistlen;
6887     if (PL_exitlistlen) {
6888         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6889         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6890     }
6891     else
6892         PL_exitlist     = (PerlExitListEntry*)NULL;
6893     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
6894
6895     PL_profiledata      = NULL;
6896     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
6897     /* PL_rsfp_filters entries have fake IoDIRP() */
6898     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
6899
6900     PL_compcv                   = cv_dup(proto_perl->Icompcv);
6901     PL_comppad                  = av_dup(proto_perl->Icomppad);
6902     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
6903     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
6904     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
6905     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
6906                                                         proto_perl->Tcurpad);
6907
6908 #ifdef HAVE_INTERP_INTERN
6909     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6910 #endif
6911
6912     /* more statics moved here */
6913     PL_generation       = proto_perl->Igeneration;
6914     PL_DBcv             = cv_dup(proto_perl->IDBcv);
6915
6916     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
6917     PL_in_clean_all     = proto_perl->Iin_clean_all;
6918
6919     PL_uid              = proto_perl->Iuid;
6920     PL_euid             = proto_perl->Ieuid;
6921     PL_gid              = proto_perl->Igid;
6922     PL_egid             = proto_perl->Iegid;
6923     PL_nomemok          = proto_perl->Inomemok;
6924     PL_an               = proto_perl->Ian;
6925     PL_cop_seqmax       = proto_perl->Icop_seqmax;
6926     PL_op_seqmax        = proto_perl->Iop_seqmax;
6927     PL_evalseq          = proto_perl->Ievalseq;
6928     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
6929     PL_origalen         = proto_perl->Iorigalen;
6930     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
6931     PL_osname           = SAVEPV(proto_perl->Iosname);
6932     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
6933     PL_sighandlerp      = proto_perl->Isighandlerp;
6934
6935
6936     PL_runops           = proto_perl->Irunops;
6937
6938     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
6939
6940 #ifdef CSH
6941     PL_cshlen           = proto_perl->Icshlen;
6942     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6943 #endif
6944
6945     PL_lex_state        = proto_perl->Ilex_state;
6946     PL_lex_defer        = proto_perl->Ilex_defer;
6947     PL_lex_expect       = proto_perl->Ilex_expect;
6948     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
6949     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
6950     PL_lex_starts       = proto_perl->Ilex_starts;
6951     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
6952     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
6953     PL_lex_op           = proto_perl->Ilex_op;
6954     PL_lex_inpat        = proto_perl->Ilex_inpat;
6955     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
6956     PL_lex_brackets     = proto_perl->Ilex_brackets;
6957     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6958     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
6959     PL_lex_casemods     = proto_perl->Ilex_casemods;
6960     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6961     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
6962
6963     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6964     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6965     PL_nexttoke         = proto_perl->Inexttoke;
6966
6967     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
6968     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6969     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6970     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6971     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6972     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6973     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6974     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6975     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6976     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6977     PL_pending_ident    = proto_perl->Ipending_ident;
6978     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
6979
6980     PL_expect           = proto_perl->Iexpect;
6981
6982     PL_multi_start      = proto_perl->Imulti_start;
6983     PL_multi_end        = proto_perl->Imulti_end;
6984     PL_multi_open       = proto_perl->Imulti_open;
6985     PL_multi_close      = proto_perl->Imulti_close;
6986
6987     PL_error_count      = proto_perl->Ierror_count;
6988     PL_subline          = proto_perl->Isubline;
6989     PL_subname          = sv_dup_inc(proto_perl->Isubname);
6990
6991     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
6992     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
6993     PL_padix                    = proto_perl->Ipadix;
6994     PL_padix_floor              = proto_perl->Ipadix_floor;
6995     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
6996
6997     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6998     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6999     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7000     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7001     PL_last_lop_op      = proto_perl->Ilast_lop_op;
7002     PL_in_my            = proto_perl->Iin_my;
7003     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
7004 #ifdef FCRYPT
7005     PL_cryptseen        = proto_perl->Icryptseen;
7006 #endif
7007
7008     PL_hints            = proto_perl->Ihints;
7009
7010     PL_amagic_generation        = proto_perl->Iamagic_generation;
7011
7012 #ifdef USE_LOCALE_COLLATE
7013     PL_collation_ix     = proto_perl->Icollation_ix;
7014     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
7015     PL_collation_standard       = proto_perl->Icollation_standard;
7016     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
7017     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
7018 #endif /* USE_LOCALE_COLLATE */
7019
7020 #ifdef USE_LOCALE_NUMERIC
7021     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
7022     PL_numeric_standard = proto_perl->Inumeric_standard;
7023     PL_numeric_local    = proto_perl->Inumeric_local;
7024     PL_numeric_radix    = proto_perl->Inumeric_radix;
7025 #endif /* !USE_LOCALE_NUMERIC */
7026
7027     /* utf8 character classes */
7028     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
7029     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
7030     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
7031     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
7032     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
7033     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
7034     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
7035     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
7036     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
7037     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
7038     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
7039     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
7040     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
7041     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
7042     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
7043     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
7044     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
7045
7046     /* swatch cache */
7047     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
7048     PL_last_swash_klen  = 0;
7049     PL_last_swash_key[0]= '\0';
7050     PL_last_swash_tmps  = (U8*)NULL;
7051     PL_last_swash_slen  = 0;
7052
7053     /* perly.c globals */
7054     PL_yydebug          = proto_perl->Iyydebug;
7055     PL_yynerrs          = proto_perl->Iyynerrs;
7056     PL_yyerrflag        = proto_perl->Iyyerrflag;
7057     PL_yychar           = proto_perl->Iyychar;
7058     PL_yyval            = proto_perl->Iyyval;
7059     PL_yylval           = proto_perl->Iyylval;
7060
7061     PL_glob_index       = proto_perl->Iglob_index;
7062     PL_srand_called     = proto_perl->Isrand_called;
7063     PL_uudmap['M']      = 0;            /* reinits on demand */
7064     PL_bitcount         = Nullch;       /* reinits on demand */
7065
7066     if (proto_perl->Ipsig_ptr) {
7067         int sig_num[] = { SIG_NUM };
7068         Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7069         Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7070         for (i = 1; PL_sig_name[i]; i++) {
7071             PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7072             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7073         }
7074     }
7075     else {
7076         PL_psig_ptr     = (SV**)NULL;
7077         PL_psig_name    = (SV**)NULL;
7078     }
7079
7080     /* thrdvar.h stuff */
7081
7082     if (flags & 1) {
7083         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7084         PL_tmps_ix              = proto_perl->Ttmps_ix;
7085         PL_tmps_max             = proto_perl->Ttmps_max;
7086         PL_tmps_floor           = proto_perl->Ttmps_floor;
7087         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7088         i = 0;
7089         while (i <= PL_tmps_ix) {
7090             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7091             ++i;
7092         }
7093
7094         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7095         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7096         Newz(54, PL_markstack, i, I32);
7097         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
7098                                                   - proto_perl->Tmarkstack);
7099         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
7100                                                   - proto_perl->Tmarkstack);
7101         Copy(proto_perl->Tmarkstack, PL_markstack,
7102              PL_markstack_ptr - PL_markstack + 1, I32);
7103
7104         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7105          * NOTE: unlike the others! */
7106         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
7107         PL_scopestack_max       = proto_perl->Tscopestack_max;
7108         Newz(54, PL_scopestack, PL_scopestack_max, I32);
7109         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7110
7111         /* next push_return() sets PL_retstack[PL_retstack_ix]
7112          * NOTE: unlike the others! */
7113         PL_retstack_ix          = proto_perl->Tretstack_ix;
7114         PL_retstack_max         = proto_perl->Tretstack_max;
7115         Newz(54, PL_retstack, PL_retstack_max, OP*);
7116         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7117
7118         /* NOTE: si_dup() looks at PL_markstack */
7119         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
7120
7121         /* PL_curstack          = PL_curstackinfo->si_stack; */
7122         PL_curstack             = av_dup(proto_perl->Tcurstack);
7123         PL_mainstack            = av_dup(proto_perl->Tmainstack);
7124
7125         /* next PUSHs() etc. set *(PL_stack_sp+1) */
7126         PL_stack_base           = AvARRAY(PL_curstack);
7127         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
7128                                                    - proto_perl->Tstack_base);
7129         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
7130
7131         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7132          * NOTE: unlike the others! */
7133         PL_savestack_ix         = proto_perl->Tsavestack_ix;
7134         PL_savestack_max        = proto_perl->Tsavestack_max;
7135         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7136         PL_savestack            = ss_dup(proto_perl);
7137     }
7138     else {
7139         init_stacks();
7140     }
7141
7142     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
7143     PL_top_env          = &PL_start_env;
7144
7145     PL_op               = proto_perl->Top;
7146
7147     PL_Sv               = Nullsv;
7148     PL_Xpv              = (XPV*)NULL;
7149     PL_na               = proto_perl->Tna;
7150
7151     PL_statbuf          = proto_perl->Tstatbuf;
7152     PL_statcache        = proto_perl->Tstatcache;
7153     PL_statgv           = gv_dup(proto_perl->Tstatgv);
7154     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
7155 #ifdef HAS_TIMES
7156     PL_timesbuf         = proto_perl->Ttimesbuf;
7157 #endif
7158
7159     PL_tainted          = proto_perl->Ttainted;
7160     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
7161     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
7162     PL_rs               = sv_dup_inc(proto_perl->Trs);
7163     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
7164     PL_ofslen           = proto_perl->Tofslen;
7165     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7166     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
7167     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
7168     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
7169     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
7170     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
7171
7172     PL_restartop        = proto_perl->Trestartop;
7173     PL_in_eval          = proto_perl->Tin_eval;
7174     PL_delaymagic       = proto_perl->Tdelaymagic;
7175     PL_dirty            = proto_perl->Tdirty;
7176     PL_localizing       = proto_perl->Tlocalizing;
7177
7178     PL_protect          = proto_perl->Tprotect;
7179     PL_errors           = sv_dup_inc(proto_perl->Terrors);
7180     PL_av_fetch_sv      = Nullsv;
7181     PL_hv_fetch_sv      = Nullsv;
7182     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
7183     PL_modcount         = proto_perl->Tmodcount;
7184     PL_lastgotoprobe    = Nullop;
7185     PL_dumpindent       = proto_perl->Tdumpindent;
7186
7187     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7188     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
7189     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
7190     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
7191     PL_sortcxix         = proto_perl->Tsortcxix;
7192     PL_efloatbuf        = Nullch;               /* reinits on demand */
7193     PL_efloatsize       = 0;                    /* reinits on demand */
7194
7195     /* regex stuff */
7196
7197     PL_screamfirst      = NULL;
7198     PL_screamnext       = NULL;
7199     PL_maxscream        = -1;                   /* reinits on demand */
7200     PL_lastscream       = Nullsv;
7201
7202     PL_watchaddr        = NULL;
7203     PL_watchok          = Nullch;
7204
7205     PL_regdummy         = proto_perl->Tregdummy;
7206     PL_regcomp_parse    = Nullch;
7207     PL_regxend          = Nullch;
7208     PL_regcode          = (regnode*)NULL;
7209     PL_regnaughty       = 0;
7210     PL_regsawback       = 0;
7211     PL_regprecomp       = Nullch;
7212     PL_regnpar          = 0;
7213     PL_regsize          = 0;
7214     PL_regflags         = 0;
7215     PL_regseen          = 0;
7216     PL_seen_zerolen     = 0;
7217     PL_seen_evals       = 0;
7218     PL_regcomp_rx       = (regexp*)NULL;
7219     PL_extralen         = 0;
7220     PL_colorset         = 0;            /* reinits PL_colors[] */
7221     /*PL_colors[6]      = {0,0,0,0,0,0};*/
7222     PL_reg_whilem_seen  = 0;
7223     PL_reginput         = Nullch;
7224     PL_regbol           = Nullch;
7225     PL_regeol           = Nullch;
7226     PL_regstartp        = (I32*)NULL;
7227     PL_regendp          = (I32*)NULL;
7228     PL_reglastparen     = (U32*)NULL;
7229     PL_regtill          = Nullch;
7230     PL_regprev          = '\n';
7231     PL_reg_start_tmp    = (char**)NULL;
7232     PL_reg_start_tmpl   = 0;
7233     PL_regdata          = (struct reg_data*)NULL;
7234     PL_bostr            = Nullch;
7235     PL_reg_flags        = 0;
7236     PL_reg_eval_set     = 0;
7237     PL_regnarrate       = 0;
7238     PL_regprogram       = (regnode*)NULL;
7239     PL_regindent        = 0;
7240     PL_regcc            = (CURCUR*)NULL;
7241     PL_reg_call_cc      = (struct re_cc_state*)NULL;
7242     PL_reg_re           = (regexp*)NULL;
7243     PL_reg_ganch        = Nullch;
7244     PL_reg_sv           = Nullsv;
7245     PL_reg_magic        = (MAGIC*)NULL;
7246     PL_reg_oldpos       = 0;
7247     PL_reg_oldcurpm     = (PMOP*)NULL;
7248     PL_reg_curpm        = (PMOP*)NULL;
7249     PL_reg_oldsaved     = Nullch;
7250     PL_reg_oldsavedlen  = 0;
7251     PL_reg_maxiter      = 0;
7252     PL_reg_leftiter     = 0;
7253     PL_reg_poscache     = Nullch;
7254     PL_reg_poscache_size= 0;
7255
7256     /* RE engine - function pointers */
7257     PL_regcompp         = proto_perl->Tregcompp;
7258     PL_regexecp         = proto_perl->Tregexecp;
7259     PL_regint_start     = proto_perl->Tregint_start;
7260     PL_regint_string    = proto_perl->Tregint_string;
7261     PL_regfree          = proto_perl->Tregfree;
7262
7263     PL_reginterp_cnt    = 0;
7264     PL_reg_starttry     = 0;
7265
7266 #ifdef PERL_OBJECT
7267     return (PerlInterpreter*)pPerl;
7268 #else
7269     return my_perl;
7270 #endif
7271 }
7272
7273 #else   /* !USE_ITHREADS */
7274
7275 #ifdef PERL_OBJECT
7276 #include "XSUB.h"
7277 #endif
7278
7279 #endif /* USE_ITHREADS */
7280
7281 static void
7282 do_report_used(pTHXo_ SV *sv)
7283 {
7284     if (SvTYPE(sv) != SVTYPEMASK) {
7285         PerlIO_printf(Perl_debug_log, "****\n");
7286         sv_dump(sv);
7287     }
7288 }
7289
7290 static void
7291 do_clean_objs(pTHXo_ SV *sv)
7292 {
7293     SV* rv;
7294
7295     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7296         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7297         SvROK_off(sv);
7298         SvRV(sv) = 0;
7299         SvREFCNT_dec(rv);
7300     }
7301
7302     /* XXX Might want to check arrays, etc. */
7303 }
7304
7305 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7306 static void
7307 do_clean_named_objs(pTHXo_ SV *sv)
7308 {
7309     if (SvTYPE(sv) == SVt_PVGV) {
7310         if ( SvOBJECT(GvSV(sv)) ||
7311              GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7312              GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7313              GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7314              GvCV(sv) && SvOBJECT(GvCV(sv)) )
7315         {
7316             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7317             SvREFCNT_dec(sv);
7318         }
7319     }
7320 }
7321 #endif
7322
7323 static void
7324 do_clean_all(pTHXo_ SV *sv)
7325 {
7326     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
7327     SvFLAGS(sv) |= SVf_BREAK;
7328     SvREFCNT_dec(sv);
7329 }
7330