sv.c

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