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