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