sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (c) 1991-1999, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_SV_C
  16 #include "perl.h"
  17
  18 #define FCALL *f
  19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
  20
  21 static void do_report_used(pTHXo_ SV *sv);
  22 static void do_clean_objs(pTHXo_ SV *sv);
  23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
  24 static void do_clean_named_objs(pTHXo_ SV *sv);
  25 #endif
  26 static void do_clean_all(pTHXo_ SV *sv);
  27
  28
  29 #ifdef PURIFY
  30
  31 #define new_SV(p) \
  32     STMT_START {                                        \
  33         LOCK_SV_MUTEX;                                  \
  34         (p) = (SV*)safemalloc(sizeof(SV));              \
  35         reg_add(p);                                     \
  36         UNLOCK_SV_MUTEX;                                \
  37         SvANY(p) = 0;                                   \
  38         SvREFCNT(p) = 1;                                \
  39         SvFLAGS(p) = 0;                                 \
  40     } STMT_END
  41
  42 #define del_SV(p) \
  43     STMT_START {                                        \
  44         LOCK_SV_MUTEX;                                  \
  45         reg_remove(p);                                  \
  46         Safefree((char*)(p));                           \
  47         UNLOCK_SV_MUTEX;                                \
  48     } STMT_END
  49
  50 static SV **registry;
  51 static I32 registry_size;
  52
  53 #define REGHASH(sv,size)  ((((U32)(sv)) >> 2) % (size))
  54
  55 #define REG_REPLACE(sv,a,b) \
  56     STMT_START {                                        \
  57         void* p = sv->sv_any;                           \
  58         I32 h = REGHASH(sv, registry_size);             \
  59         I32 i = h;                                      \
  60         while (registry[i] != (a)) {                    \
  61             if (++i >= registry_size)                   \
  62                 i = 0;                                  \
  63             if (i == h)                                 \
  64                 Perl_die(aTHX_ "SV registry bug");                      \
  65         }                                               \
  66         registry[i] = (b);                              \
  67     } STMT_END
  68
  69 #define REG_ADD(sv)     REG_REPLACE(sv,Nullsv,sv)
  70 #define REG_REMOVE(sv)  REG_REPLACE(sv,sv,Nullsv)
  71
  72 STATIC void
  73 S_reg_add(pTHX_ SV *sv)
  74 {
  75     if (PL_sv_count >= (registry_size >> 1))
  76     {
  77         SV **oldreg = registry;
  78         I32 oldsize = registry_size;
  79
  80         registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
  81         Newz(707, registry, registry_size, SV*);
  82
  83         if (oldreg) {
  84             I32 i;
  85
  86             for (i = 0; i < oldsize; ++i) {
  87                 SV* oldsv = oldreg[i];
  88                 if (oldsv)
  89                     REG_ADD(oldsv);
  90             }
  91             Safefree(oldreg);
  92         }
  93     }
  94
  95     REG_ADD(sv);
  96     ++PL_sv_count;
  97 }
  98
  99 STATIC void
 100 S_reg_remove(pTHX_ SV *sv)
 101 {
 102     REG_REMOVE(sv);
 103     --PL_sv_count;
 104 }
 105
 106 STATIC void
 107 S_visit(pTHX_ SVFUNC_t f)
 108 {
 109     I32 i;
 110
 111     for (i = 0; i < registry_size; ++i) {
 112         SV* sv = registry[i];
 113         if (sv && SvTYPE(sv) != SVTYPEMASK)
 114             (*f)(sv);
 115     }
 116 }
 117
 118 void
 119 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
 120 {
 121     if (!(flags & SVf_FAKE))
 122         Safefree(ptr);
 123 }
 124
 125 #else /* ! PURIFY */
 126
 127 /*
 128  * "A time to plant, and a time to uproot what was planted..."
 129  */
 130
 131 #define plant_SV(p) \
 132     STMT_START {                                        \
 133         SvANY(p) = (void *)PL_sv_root;                  \
 134         SvFLAGS(p) = SVTYPEMASK;                        \
 135         PL_sv_root = (p);                               \
 136         --PL_sv_count;                                  \
 137     } STMT_END
 138
 139 /* sv_mutex must be held while calling uproot_SV() */
 140 #define uproot_SV(p) \
 141     STMT_START {                                        \
 142         (p) = PL_sv_root;                               \
 143         PL_sv_root = (SV*)SvANY(p);                     \
 144         ++PL_sv_count;                                  \
 145     } STMT_END
 146
 147 #define new_SV(p) \
 148     STMT_START {                                        \
 149         LOCK_SV_MUTEX;                                  \
 150         if (PL_sv_root)                                 \
 151             uproot_SV(p);                               \
 152         else                                            \
 153             (p) = more_sv();                            \
 154         UNLOCK_SV_MUTEX;                                \
 155         SvANY(p) = 0;                                   \
 156         SvREFCNT(p) = 1;                                \
 157         SvFLAGS(p) = 0;                                 \
 158     } STMT_END
 159
 160 #ifdef DEBUGGING
 161
 162 #define del_SV(p) \
 163     STMT_START {                                        \
 164         LOCK_SV_MUTEX;                                  \
 165         if (PL_debug & 32768)                           \
 166             del_sv(p);                                  \
 167         else                                            \
 168             plant_SV(p);                                \
 169         UNLOCK_SV_MUTEX;                                \
 170     } STMT_END
 171
 172 STATIC void
 173 S_del_sv(pTHX_ SV *p)
 174 {
 175     if (PL_debug & 32768) {
 176         SV* sva;
 177         SV* sv;
 178         SV* svend;
 179         int ok = 0;
 180         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
 181             sv = sva + 1;
 182             svend = &sva[SvREFCNT(sva)];
 183             if (p >= sv && p < svend)
 184                 ok = 1;
 185         }
 186         if (!ok) {
 187             if (ckWARN_d(WARN_INTERNAL))
 188                 Perl_warner(aTHX_ WARN_INTERNAL,
 189                             "Attempt to free non-arena SV: 0x%"UVxf,
 190                             PTR2UV(p));
 191             return;
 192         }
 193     }
 194     plant_SV(p);
 195 }
 196
 197 #else /* ! DEBUGGING */
 198
 199 #define del_SV(p)   plant_SV(p)
 200
 201 #endif /* DEBUGGING */
 202
 203 void
 204 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
 205 {
 206     SV* sva = (SV*)ptr;
 207     register SV* sv;
 208     register SV* svend;
 209     Zero(sva, size, char);
 210
 211     /* The first SV in an arena isn't an SV. */
 212     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 213     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 214     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 215
 216     PL_sv_arenaroot = sva;
 217     PL_sv_root = sva + 1;
 218
 219     svend = &sva[SvREFCNT(sva) - 1];
 220     sv = sva + 1;
 221     while (sv < svend) {
 222         SvANY(sv) = (void *)(SV*)(sv + 1);
 223         SvFLAGS(sv) = SVTYPEMASK;
 224         sv++;
 225     }
 226     SvANY(sv) = 0;
 227     SvFLAGS(sv) = SVTYPEMASK;
 228 }
 229
 230 /* sv_mutex must be held while calling more_sv() */
 231 STATIC SV*
 232 S_more_sv(pTHX)
 233 {
 234     register SV* sv;
 235
 236     if (PL_nice_chunk) {
 237         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 238         PL_nice_chunk = Nullch;
 239     }
 240     else {
 241         char *chunk;                /* must use New here to match call to */
 242         New(704,chunk,1008,char);   /* Safefree() in sv_free_arenas()     */
 243         sv_add_arena(chunk, 1008, 0);
 244     }
 245     uproot_SV(sv);
 246     return sv;
 247 }
 248
 249 STATIC void
 250 S_visit(pTHX_ SVFUNC_t f)
 251 {
 252     SV* sva;
 253     SV* sv;
 254     register SV* svend;
 255
 256     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 257         svend = &sva[SvREFCNT(sva)];
 258         for (sv = sva + 1; sv < svend; ++sv) {
 259             if (SvTYPE(sv) != SVTYPEMASK)
 260                 (FCALL)(aTHXo_ sv);
 261         }
 262     }
 263 }
 264
 265 #endif /* PURIFY */
 266
 267 void
 268 Perl_sv_report_used(pTHX)
 269 {
 270     visit(do_report_used);
 271 }
 272
 273 void
 274 Perl_sv_clean_objs(pTHX)
 275 {
 276     PL_in_clean_objs = TRUE;
 277     visit(do_clean_objs);
 278 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 279     /* some barnacles may yet remain, clinging to typeglobs */
 280     visit(do_clean_named_objs);
 281 #endif
 282     PL_in_clean_objs = FALSE;
 283 }
 284
 285 void
 286 Perl_sv_clean_all(pTHX)
 287 {
 288     PL_in_clean_all = TRUE;
 289     visit(do_clean_all);
 290     PL_in_clean_all = FALSE;
 291 }
 292
 293 void
 294 Perl_sv_free_arenas(pTHX)
 295 {
 296     SV* sva;
 297     SV* svanext;
 298
 299     /* Free arenas here, but be careful about fake ones.  (We assume
 300        contiguity of the fake ones with the corresponding real ones.) */
 301
 302     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 303         svanext = (SV*) SvANY(sva);
 304         while (svanext && SvFAKE(svanext))
 305             svanext = (SV*) SvANY(svanext);
 306
 307         if (!SvFAKE(sva))
 308             Safefree((void *)sva);
 309     }
 310
 311     if (PL_nice_chunk)
 312         Safefree(PL_nice_chunk);
 313     PL_nice_chunk = Nullch;
 314     PL_nice_chunk_size = 0;
 315     PL_sv_arenaroot = 0;
 316     PL_sv_root = 0;
 317 }
 318
 319 void
 320 Perl_report_uninit(pTHX)
 321 {
 322     if (PL_op)
 323         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
 324                     " in ", PL_op_desc[PL_op->op_type]);
 325     else
 326         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
 327 }
 328
 329 STATIC XPVIV*
 330 S_new_xiv(pTHX)
 331 {
 332     IV* xiv;
 333     LOCK_SV_MUTEX;
 334     if (!PL_xiv_root)
 335         more_xiv();
 336     xiv = PL_xiv_root;
 337     /*
 338      * See comment in more_xiv() -- RAM.
 339      */
 340     PL_xiv_root = *(IV**)xiv;
 341     UNLOCK_SV_MUTEX;
 342     return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
 343 }
 344
 345 STATIC void
 346 S_del_xiv(pTHX_ XPVIV *p)
 347 {
 348     IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
 349     LOCK_SV_MUTEX;
 350     *(IV**)xiv = PL_xiv_root;
 351     PL_xiv_root = xiv;
 352     UNLOCK_SV_MUTEX;
 353 }
 354
 355 STATIC void
 356 S_more_xiv(pTHX)
 357 {
 358     register IV* xiv;
 359     register IV* xivend;
 360     XPV* ptr;
 361     New(705, ptr, 1008/sizeof(XPV), XPV);
 362     ptr->xpv_pv = (char*)PL_xiv_arenaroot;              /* linked list of xiv arenas */
 363     PL_xiv_arenaroot = ptr;                     /* to keep Purify happy */
 364
 365     xiv = (IV*) ptr;
 366     xivend = &xiv[1008 / sizeof(IV) - 1];
 367     xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1;   /* fudge by size of XPV */
 368     PL_xiv_root = xiv;
 369     while (xiv < xivend) {
 370         *(IV**)xiv = (IV *)(xiv + 1);
 371         xiv++;
 372     }
 373     *(IV**)xiv = 0;
 374 }
 375
 376 STATIC XPVNV*
 377 S_new_xnv(pTHX)
 378 {
 379     NV* xnv;
 380     LOCK_SV_MUTEX;
 381     if (!PL_xnv_root)
 382         more_xnv();
 383     xnv = PL_xnv_root;
 384     PL_xnv_root = *(NV**)xnv;
 385     UNLOCK_SV_MUTEX;
 386     return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
 387 }
 388
 389 STATIC void
 390 S_del_xnv(pTHX_ XPVNV *p)
 391 {
 392     NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
 393     LOCK_SV_MUTEX;
 394     *(NV**)xnv = PL_xnv_root;
 395     PL_xnv_root = xnv;
 396     UNLOCK_SV_MUTEX;
 397 }
 398
 399 STATIC void
 400 S_more_xnv(pTHX)
 401 {
 402     register NV* xnv;
 403     register NV* xnvend;
 404     New(711, xnv, 1008/sizeof(NV), NV);
 405     xnvend = &xnv[1008 / sizeof(NV) - 1];
 406     xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
 407     PL_xnv_root = xnv;
 408     while (xnv < xnvend) {
 409         *(NV**)xnv = (NV*)(xnv + 1);
 410         xnv++;
 411     }
 412     *(NV**)xnv = 0;
 413 }
 414
 415 STATIC XRV*
 416 S_new_xrv(pTHX)
 417 {
 418     XRV* xrv;
 419     LOCK_SV_MUTEX;
 420     if (!PL_xrv_root)
 421         more_xrv();
 422     xrv = PL_xrv_root;
 423     PL_xrv_root = (XRV*)xrv->xrv_rv;
 424     UNLOCK_SV_MUTEX;
 425     return xrv;
 426 }
 427
 428 STATIC void
 429 S_del_xrv(pTHX_ XRV *p)
 430 {
 431     LOCK_SV_MUTEX;
 432     p->xrv_rv = (SV*)PL_xrv_root;
 433     PL_xrv_root = p;
 434     UNLOCK_SV_MUTEX;
 435 }
 436
 437 STATIC void
 438 S_more_xrv(pTHX)
 439 {
 440     register XRV* xrv;
 441     register XRV* xrvend;
 442     New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
 443     xrv = PL_xrv_root;
 444     xrvend = &xrv[1008 / sizeof(XRV) - 1];
 445     while (xrv < xrvend) {
 446         xrv->xrv_rv = (SV*)(xrv + 1);
 447         xrv++;
 448     }
 449     xrv->xrv_rv = 0;
 450 }
 451
 452 STATIC XPV*
 453 S_new_xpv(pTHX)
 454 {
 455     XPV* xpv;
 456     LOCK_SV_MUTEX;
 457     if (!PL_xpv_root)
 458         more_xpv();
 459     xpv = PL_xpv_root;
 460     PL_xpv_root = (XPV*)xpv->xpv_pv;
 461     UNLOCK_SV_MUTEX;
 462     return xpv;
 463 }
 464
 465 STATIC void
 466 S_del_xpv(pTHX_ XPV *p)
 467 {
 468     LOCK_SV_MUTEX;
 469     p->xpv_pv = (char*)PL_xpv_root;
 470     PL_xpv_root = p;
 471     UNLOCK_SV_MUTEX;
 472 }
 473
 474 STATIC void
 475 S_more_xpv(pTHX)
 476 {
 477     register XPV* xpv;
 478     register XPV* xpvend;
 479     New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
 480     xpv = PL_xpv_root;
 481     xpvend = &xpv[1008 / sizeof(XPV) - 1];
 482     while (xpv < xpvend) {
 483         xpv->xpv_pv = (char*)(xpv + 1);
 484         xpv++;
 485     }
 486     xpv->xpv_pv = 0;
 487 }
 488
 489 STATIC XPVIV*
 490 S_new_xpviv(pTHX)
 491 {
 492     XPVIV* xpviv;
 493     LOCK_SV_MUTEX;
 494     if (!PL_xpviv_root)
 495         more_xpviv();
 496     xpviv = PL_xpviv_root;
 497     PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
 498     UNLOCK_SV_MUTEX;
 499     return xpviv;
 500 }
 501
 502 STATIC void
 503 S_del_xpviv(pTHX_ XPVIV *p)
 504 {
 505     LOCK_SV_MUTEX;
 506     p->xpv_pv = (char*)PL_xpviv_root;
 507     PL_xpviv_root = p;
 508     UNLOCK_SV_MUTEX;
 509 }
 510
 511
 512 STATIC void
 513 S_more_xpviv(pTHX)
 514 {
 515     register XPVIV* xpviv;
 516     register XPVIV* xpvivend;
 517     New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
 518     xpviv = PL_xpviv_root;
 519     xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
 520     while (xpviv < xpvivend) {
 521         xpviv->xpv_pv = (char*)(xpviv + 1);
 522         xpviv++;
 523     }
 524     xpviv->xpv_pv = 0;
 525 }
 526
 527
 528 STATIC XPVNV*
 529 S_new_xpvnv(pTHX)
 530 {
 531     XPVNV* xpvnv;
 532     LOCK_SV_MUTEX;
 533     if (!PL_xpvnv_root)
 534         more_xpvnv();
 535     xpvnv = PL_xpvnv_root;
 536     PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
 537     UNLOCK_SV_MUTEX;
 538     return xpvnv;
 539 }
 540
 541 STATIC void
 542 S_del_xpvnv(pTHX_ XPVNV *p)
 543 {
 544     LOCK_SV_MUTEX;
 545     p->xpv_pv = (char*)PL_xpvnv_root;
 546     PL_xpvnv_root = p;
 547     UNLOCK_SV_MUTEX;
 548 }
 549
 550
 551 STATIC void
 552 S_more_xpvnv(pTHX)
 553 {
 554     register XPVNV* xpvnv;
 555     register XPVNV* xpvnvend;
 556     New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
 557     xpvnv = PL_xpvnv_root;
 558     xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
 559     while (xpvnv < xpvnvend) {
 560         xpvnv->xpv_pv = (char*)(xpvnv + 1);
 561         xpvnv++;
 562     }
 563     xpvnv->xpv_pv = 0;
 564 }
 565
 566
 567
 568 STATIC XPVCV*
 569 S_new_xpvcv(pTHX)
 570 {
 571     XPVCV* xpvcv;
 572     LOCK_SV_MUTEX;
 573     if (!PL_xpvcv_root)
 574         more_xpvcv();
 575     xpvcv = PL_xpvcv_root;
 576     PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
 577     UNLOCK_SV_MUTEX;
 578     return xpvcv;
 579 }
 580
 581 STATIC void
 582 S_del_xpvcv(pTHX_ XPVCV *p)
 583 {
 584     LOCK_SV_MUTEX;
 585     p->xpv_pv = (char*)PL_xpvcv_root;
 586     PL_xpvcv_root = p;
 587     UNLOCK_SV_MUTEX;
 588 }
 589
 590
 591 STATIC void
 592 S_more_xpvcv(pTHX)
 593 {
 594     register XPVCV* xpvcv;
 595     register XPVCV* xpvcvend;
 596     New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
 597     xpvcv = PL_xpvcv_root;
 598     xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
 599     while (xpvcv < xpvcvend) {
 600         xpvcv->xpv_pv = (char*)(xpvcv + 1);
 601         xpvcv++;
 602     }
 603     xpvcv->xpv_pv = 0;
 604 }
 605
 606
 607
 608 STATIC XPVAV*
 609 S_new_xpvav(pTHX)
 610 {
 611     XPVAV* xpvav;
 612     LOCK_SV_MUTEX;
 613     if (!PL_xpvav_root)
 614         more_xpvav();
 615     xpvav = PL_xpvav_root;
 616     PL_xpvav_root = (XPVAV*)xpvav->xav_array;
 617     UNLOCK_SV_MUTEX;
 618     return xpvav;
 619 }
 620
 621 STATIC void
 622 S_del_xpvav(pTHX_ XPVAV *p)
 623 {
 624     LOCK_SV_MUTEX;
 625     p->xav_array = (char*)PL_xpvav_root;
 626     PL_xpvav_root = p;
 627     UNLOCK_SV_MUTEX;
 628 }
 629
 630
 631 STATIC void
 632 S_more_xpvav(pTHX)
 633 {
 634     register XPVAV* xpvav;
 635     register XPVAV* xpvavend;
 636     New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
 637     xpvav = PL_xpvav_root;
 638     xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
 639     while (xpvav < xpvavend) {
 640         xpvav->xav_array = (char*)(xpvav + 1);
 641         xpvav++;
 642     }
 643     xpvav->xav_array = 0;
 644 }
 645
 646
 647
 648 STATIC XPVHV*
 649 S_new_xpvhv(pTHX)
 650 {
 651     XPVHV* xpvhv;
 652     LOCK_SV_MUTEX;
 653     if (!PL_xpvhv_root)
 654         more_xpvhv();
 655     xpvhv = PL_xpvhv_root;
 656     PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
 657     UNLOCK_SV_MUTEX;
 658     return xpvhv;
 659 }
 660
 661 STATIC void
 662 S_del_xpvhv(pTHX_ XPVHV *p)
 663 {
 664     LOCK_SV_MUTEX;
 665     p->xhv_array = (char*)PL_xpvhv_root;
 666     PL_xpvhv_root = p;
 667     UNLOCK_SV_MUTEX;
 668 }
 669
 670
 671 STATIC void
 672 S_more_xpvhv(pTHX)
 673 {
 674     register XPVHV* xpvhv;
 675     register XPVHV* xpvhvend;
 676     New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
 677     xpvhv = PL_xpvhv_root;
 678     xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
 679     while (xpvhv < xpvhvend) {
 680         xpvhv->xhv_array = (char*)(xpvhv + 1);
 681         xpvhv++;
 682     }
 683     xpvhv->xhv_array = 0;
 684 }
 685
 686
 687 STATIC XPVMG*
 688 S_new_xpvmg(pTHX)
 689 {
 690     XPVMG* xpvmg;
 691     LOCK_SV_MUTEX;
 692     if (!PL_xpvmg_root)
 693         more_xpvmg();
 694     xpvmg = PL_xpvmg_root;
 695     PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
 696     UNLOCK_SV_MUTEX;
 697     return xpvmg;
 698 }
 699
 700 STATIC void
 701 S_del_xpvmg(pTHX_ XPVMG *p)
 702 {
 703     LOCK_SV_MUTEX;
 704     p->xpv_pv = (char*)PL_xpvmg_root;
 705     PL_xpvmg_root = p;
 706     UNLOCK_SV_MUTEX;
 707 }
 708
 709
 710 STATIC void
 711 S_more_xpvmg(pTHX)
 712 {
 713     register XPVMG* xpvmg;
 714     register XPVMG* xpvmgend;
 715     New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
 716     xpvmg = PL_xpvmg_root;
 717     xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
 718     while (xpvmg < xpvmgend) {
 719         xpvmg->xpv_pv = (char*)(xpvmg + 1);
 720         xpvmg++;
 721     }
 722     xpvmg->xpv_pv = 0;
 723 }
 724
 725
 726
 727 STATIC XPVLV*
 728 S_new_xpvlv(pTHX)
 729 {
 730     XPVLV* xpvlv;
 731     LOCK_SV_MUTEX;
 732     if (!PL_xpvlv_root)
 733         more_xpvlv();
 734     xpvlv = PL_xpvlv_root;
 735     PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
 736     UNLOCK_SV_MUTEX;
 737     return xpvlv;
 738 }
 739
 740 STATIC void
 741 S_del_xpvlv(pTHX_ XPVLV *p)
 742 {
 743     LOCK_SV_MUTEX;
 744     p->xpv_pv = (char*)PL_xpvlv_root;
 745     PL_xpvlv_root = p;
 746     UNLOCK_SV_MUTEX;
 747 }
 748
 749
 750 STATIC void
 751 S_more_xpvlv(pTHX)
 752 {
 753     register XPVLV* xpvlv;
 754     register XPVLV* xpvlvend;
 755     New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
 756     xpvlv = PL_xpvlv_root;
 757     xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
 758     while (xpvlv < xpvlvend) {
 759         xpvlv->xpv_pv = (char*)(xpvlv + 1);
 760         xpvlv++;
 761     }
 762     xpvlv->xpv_pv = 0;
 763 }
 764
 765
 766 STATIC XPVBM*
 767 S_new_xpvbm(pTHX)
 768 {
 769     XPVBM* xpvbm;
 770     LOCK_SV_MUTEX;
 771     if (!PL_xpvbm_root)
 772         more_xpvbm();
 773     xpvbm = PL_xpvbm_root;
 774     PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
 775     UNLOCK_SV_MUTEX;
 776     return xpvbm;
 777 }
 778
 779 STATIC void
 780 S_del_xpvbm(pTHX_ XPVBM *p)
 781 {
 782     LOCK_SV_MUTEX;
 783     p->xpv_pv = (char*)PL_xpvbm_root;
 784     PL_xpvbm_root = p;
 785     UNLOCK_SV_MUTEX;
 786 }
 787
 788
 789 STATIC void
 790 S_more_xpvbm(pTHX)
 791 {
 792     register XPVBM* xpvbm;
 793     register XPVBM* xpvbmend;
 794     New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
 795     xpvbm = PL_xpvbm_root;
 796     xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
 797     while (xpvbm < xpvbmend) {
 798         xpvbm->xpv_pv = (char*)(xpvbm + 1);
 799         xpvbm++;
 800     }
 801     xpvbm->xpv_pv = 0;
 802 }
 803
 804 #ifdef PURIFY
 805 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
 806 #define del_XIV(p) Safefree((char*)p)
 807 #else
 808 #define new_XIV() (void*)new_xiv()
 809 #define del_XIV(p) del_xiv((XPVIV*) p)
 810 #endif
 811
 812 #ifdef PURIFY
 813 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
 814 #define del_XNV(p) Safefree((char*)p)
 815 #else
 816 #define new_XNV() (void*)new_xnv()
 817 #define del_XNV(p) del_xnv((XPVNV*) p)
 818 #endif
 819
 820 #ifdef PURIFY
 821 #define new_XRV() (void*)safemalloc(sizeof(XRV))
 822 #define del_XRV(p) Safefree((char*)p)
 823 #else
 824 #define new_XRV() (void*)new_xrv()
 825 #define del_XRV(p) del_xrv((XRV*) p)
 826 #endif
 827
 828 #ifdef PURIFY
 829 #define new_XPV() (void*)safemalloc(sizeof(XPV))
 830 #define del_XPV(p) Safefree((char*)p)
 831 #else
 832 #define new_XPV() (void*)new_xpv()
 833 #define del_XPV(p) del_xpv((XPV *)p)
 834 #endif
 835
 836 #ifdef PURIFY
 837 #  define my_safemalloc(s) safemalloc(s)
 838 #  define my_safefree(s) safefree(s)
 839 #else
 840 STATIC void*
 841 S_my_safemalloc(MEM_SIZE size)
 842 {
 843     char *p;
 844     New(717, p, size, char);
 845     return (void*)p;
 846 }
 847 #  define my_safefree(s) Safefree(s)
 848 #endif
 849
 850 #ifdef PURIFY
 851 #define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
 852 #define del_XPVIV(p) Safefree((char*)p)
 853 #else
 854 #define new_XPVIV() (void*)new_xpviv()
 855 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
 856 #endif
 857
 858 #ifdef PURIFY
 859 #define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
 860 #define del_XPVNV(p) Safefree((char*)p)
 861 #else
 862 #define new_XPVNV() (void*)new_xpvnv()
 863 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
 864 #endif
 865
 866
 867 #ifdef PURIFY
 868 #define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
 869 #define del_XPVCV(p) Safefree((char*)p)
 870 #else
 871 #define new_XPVCV() (void*)new_xpvcv()
 872 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
 873 #endif
 874
 875 #ifdef PURIFY
 876 #define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
 877 #define del_XPVAV(p) Safefree((char*)p)
 878 #else
 879 #define new_XPVAV() (void*)new_xpvav()
 880 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
 881 #endif
 882
 883 #ifdef PURIFY
 884 #define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
 885 #define del_XPVHV(p) Safefree((char*)p)
 886 #else
 887 #define new_XPVHV() (void*)new_xpvhv()
 888 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
 889 #endif
 890
 891 #ifdef PURIFY
 892 #define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
 893 #define del_XPVMG(p) Safefree((char*)p)
 894 #else
 895 #define new_XPVMG() (void*)new_xpvmg()
 896 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
 897 #endif
 898
 899 #ifdef PURIFY
 900 #define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
 901 #define del_XPVLV(p) Safefree((char*)p)
 902 #else
 903 #define new_XPVLV() (void*)new_xpvlv()
 904 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
 905 #endif
 906
 907 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
 908 #define del_XPVGV(p) my_safefree((char*)p)
 909
 910 #ifdef PURIFY
 911 #define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
 912 #define del_XPVBM(p) Safefree((char*)p)
 913 #else
 914 #define new_XPVBM() (void*)new_xpvbm()
 915 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
 916 #endif
 917
 918 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
 919 #define del_XPVFM(p) my_safefree((char*)p)
 920
 921 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
 922 #define del_XPVIO(p) my_safefree((char*)p)
 923
 924 bool
 925 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
 926 {
 927     char*       pv;
 928     U32         cur;
 929     U32         len;
 930     IV          iv;
 931     NV          nv;
 932     MAGIC*      magic;
 933     HV*         stash;
 934
 935     if (SvTYPE(sv) == mt)
 936         return TRUE;
 937
 938     if (mt < SVt_PVIV)
 939         (void)SvOOK_off(sv);
 940
 941     switch (SvTYPE(sv)) {
 942     case SVt_NULL:
 943         pv      = 0;
 944         cur     = 0;
 945         len     = 0;
 946         iv      = 0;
 947         nv      = 0.0;
 948         magic   = 0;
 949         stash   = 0;
 950         break;
 951     case SVt_IV:
 952         pv      = 0;
 953         cur     = 0;
 954         len     = 0;
 955         iv      = SvIVX(sv);
 956         nv      = (NV)SvIVX(sv);
 957         del_XIV(SvANY(sv));
 958         magic   = 0;
 959         stash   = 0;
 960         if (mt == SVt_NV)
 961             mt = SVt_PVNV;
 962         else if (mt < SVt_PVIV)
 963             mt = SVt_PVIV;
 964         break;
 965     case SVt_NV:
 966         pv      = 0;
 967         cur     = 0;
 968         len     = 0;
 969         nv      = SvNVX(sv);
 970         iv      = I_V(nv);
 971         magic   = 0;
 972         stash   = 0;
 973         del_XNV(SvANY(sv));
 974         SvANY(sv) = 0;
 975         if (mt < SVt_PVNV)
 976             mt = SVt_PVNV;
 977         break;
 978     case SVt_RV:
 979         pv      = (char*)SvRV(sv);
 980         cur     = 0;
 981         len     = 0;
 982         iv      = PTR2IV(pv);
 983         nv      = PTR2NV(pv);
 984         del_XRV(SvANY(sv));
 985         magic   = 0;
 986         stash   = 0;
 987         break;
 988     case SVt_PV:
 989         pv      = SvPVX(sv);
 990         cur     = SvCUR(sv);
 991         len     = SvLEN(sv);
 992         iv      = 0;
 993         nv      = 0.0;
 994         magic   = 0;
 995         stash   = 0;
 996         del_XPV(SvANY(sv));
 997         if (mt <= SVt_IV)
 998             mt = SVt_PVIV;
 999         else if (mt == SVt_NV)
1000             mt = SVt_PVNV;
1001         break;
1002     case SVt_PVIV:
1003         pv      = SvPVX(sv);
1004         cur     = SvCUR(sv);
1005         len     = SvLEN(sv);
1006         iv      = SvIVX(sv);
1007         nv      = 0.0;
1008         magic   = 0;
1009         stash   = 0;
1010         del_XPVIV(SvANY(sv));
1011         break;
1012     case SVt_PVNV:
1013         pv      = SvPVX(sv);
1014         cur     = SvCUR(sv);
1015         len     = SvLEN(sv);
1016         iv      = SvIVX(sv);
1017         nv      = SvNVX(sv);
1018         magic   = 0;
1019         stash   = 0;
1020         del_XPVNV(SvANY(sv));
1021         break;
1022     case SVt_PVMG:
1023         pv      = SvPVX(sv);
1024         cur     = SvCUR(sv);
1025         len     = SvLEN(sv);
1026         iv      = SvIVX(sv);
1027         nv      = SvNVX(sv);
1028         magic   = SvMAGIC(sv);
1029         stash   = SvSTASH(sv);
1030         del_XPVMG(SvANY(sv));
1031         break;
1032     default:
1033         Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1034     }
1035
1036     switch (mt) {
1037     case SVt_NULL:
1038         Perl_croak(aTHX_ "Can't upgrade to undef");
1039     case SVt_IV:
1040         SvANY(sv) = new_XIV();
1041         SvIVX(sv)       = iv;
1042         break;
1043     case SVt_NV:
1044         SvANY(sv) = new_XNV();
1045         SvNVX(sv)       = nv;
1046         break;
1047     case SVt_RV:
1048         SvANY(sv) = new_XRV();
1049         SvRV(sv) = (SV*)pv;
1050         break;
1051     case SVt_PV:
1052         SvANY(sv) = new_XPV();
1053         SvPVX(sv)       = pv;
1054         SvCUR(sv)       = cur;
1055         SvLEN(sv)       = len;
1056         break;
1057     case SVt_PVIV:
1058         SvANY(sv) = new_XPVIV();
1059         SvPVX(sv)       = pv;
1060         SvCUR(sv)       = cur;
1061         SvLEN(sv)       = len;
1062         SvIVX(sv)       = iv;
1063         if (SvNIOK(sv))
1064             (void)SvIOK_on(sv);
1065         SvNOK_off(sv);
1066         break;
1067     case SVt_PVNV:
1068         SvANY(sv) = new_XPVNV();
1069         SvPVX(sv)       = pv;
1070         SvCUR(sv)       = cur;
1071         SvLEN(sv)       = len;
1072         SvIVX(sv)       = iv;
1073         SvNVX(sv)       = nv;
1074         break;
1075     case SVt_PVMG:
1076         SvANY(sv) = new_XPVMG();
1077         SvPVX(sv)       = pv;
1078         SvCUR(sv)       = cur;
1079         SvLEN(sv)       = len;
1080         SvIVX(sv)       = iv;
1081         SvNVX(sv)       = nv;
1082         SvMAGIC(sv)     = magic;
1083         SvSTASH(sv)     = stash;
1084         break;
1085     case SVt_PVLV:
1086         SvANY(sv) = new_XPVLV();
1087         SvPVX(sv)       = pv;
1088         SvCUR(sv)       = cur;
1089         SvLEN(sv)       = len;
1090         SvIVX(sv)       = iv;
1091         SvNVX(sv)       = nv;
1092         SvMAGIC(sv)     = magic;
1093         SvSTASH(sv)     = stash;
1094         LvTARGOFF(sv)   = 0;
1095         LvTARGLEN(sv)   = 0;
1096         LvTARG(sv)      = 0;
1097         LvTYPE(sv)      = 0;
1098         break;
1099     case SVt_PVAV:
1100         SvANY(sv) = new_XPVAV();
1101         if (pv)
1102             Safefree(pv);
1103         SvPVX(sv)       = 0;
1104         AvMAX(sv)       = -1;
1105         AvFILLp(sv)     = -1;
1106         SvIVX(sv)       = 0;
1107         SvNVX(sv)       = 0.0;
1108         SvMAGIC(sv)     = magic;
1109         SvSTASH(sv)     = stash;
1110         AvALLOC(sv)     = 0;
1111         AvARYLEN(sv)    = 0;
1112         AvFLAGS(sv)     = 0;
1113         break;
1114     case SVt_PVHV:
1115         SvANY(sv) = new_XPVHV();
1116         if (pv)
1117             Safefree(pv);
1118         SvPVX(sv)       = 0;
1119         HvFILL(sv)      = 0;
1120         HvMAX(sv)       = 0;
1121         HvKEYS(sv)      = 0;
1122         SvNVX(sv)       = 0.0;
1123         SvMAGIC(sv)     = magic;
1124         SvSTASH(sv)     = stash;
1125         HvRITER(sv)     = 0;
1126         HvEITER(sv)     = 0;
1127         HvPMROOT(sv)    = 0;
1128         HvNAME(sv)      = 0;
1129         break;
1130     case SVt_PVCV:
1131         SvANY(sv) = new_XPVCV();
1132         Zero(SvANY(sv), 1, XPVCV);
1133         SvPVX(sv)       = pv;
1134         SvCUR(sv)       = cur;
1135         SvLEN(sv)       = len;
1136         SvIVX(sv)       = iv;
1137         SvNVX(sv)       = nv;
1138         SvMAGIC(sv)     = magic;
1139         SvSTASH(sv)     = stash;
1140         break;
1141     case SVt_PVGV:
1142         SvANY(sv) = new_XPVGV();
1143         SvPVX(sv)       = pv;
1144         SvCUR(sv)       = cur;
1145         SvLEN(sv)       = len;
1146         SvIVX(sv)       = iv;
1147         SvNVX(sv)       = nv;
1148         SvMAGIC(sv)     = magic;
1149         SvSTASH(sv)     = stash;
1150         GvGP(sv)        = 0;
1151         GvNAME(sv)      = 0;
1152         GvNAMELEN(sv)   = 0;
1153         GvSTASH(sv)     = 0;
1154         GvFLAGS(sv)     = 0;
1155         break;
1156     case SVt_PVBM:
1157         SvANY(sv) = new_XPVBM();
1158         SvPVX(sv)       = pv;
1159         SvCUR(sv)       = cur;
1160         SvLEN(sv)       = len;
1161         SvIVX(sv)       = iv;
1162         SvNVX(sv)       = nv;
1163         SvMAGIC(sv)     = magic;
1164         SvSTASH(sv)     = stash;
1165         BmRARE(sv)      = 0;
1166         BmUSEFUL(sv)    = 0;
1167         BmPREVIOUS(sv)  = 0;
1168         break;
1169     case SVt_PVFM:
1170         SvANY(sv) = new_XPVFM();
1171         Zero(SvANY(sv), 1, XPVFM);
1172         SvPVX(sv)       = pv;
1173         SvCUR(sv)       = cur;
1174         SvLEN(sv)       = len;
1175         SvIVX(sv)       = iv;
1176         SvNVX(sv)       = nv;
1177         SvMAGIC(sv)     = magic;
1178         SvSTASH(sv)     = stash;
1179         break;
1180     case SVt_PVIO:
1181         SvANY(sv) = new_XPVIO();
1182         Zero(SvANY(sv), 1, XPVIO);
1183         SvPVX(sv)       = pv;
1184         SvCUR(sv)       = cur;
1185         SvLEN(sv)       = len;
1186         SvIVX(sv)       = iv;
1187         SvNVX(sv)       = nv;
1188         SvMAGIC(sv)     = magic;
1189         SvSTASH(sv)     = stash;
1190         IoPAGE_LEN(sv)  = 60;
1191         break;
1192     }
1193     SvFLAGS(sv) &= ~SVTYPEMASK;
1194     SvFLAGS(sv) |= mt;
1195     return TRUE;
1196 }
1197
1198 int
1199 Perl_sv_backoff(pTHX_ register SV *sv)
1200 {
1201     assert(SvOOK(sv));
1202     if (SvIVX(sv)) {
1203         char *s = SvPVX(sv);
1204         SvLEN(sv) += SvIVX(sv);
1205         SvPVX(sv) -= SvIVX(sv);
1206         SvIV_set(sv, 0);
1207         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1208     }
1209     SvFLAGS(sv) &= ~SVf_OOK;
1210     return 0;
1211 }
1212
1213 char *
1214 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1215 {
1216     register char *s;
1217
1218 #ifdef HAS_64K_LIMIT
1219     if (newlen >= 0x10000) {
1220         PerlIO_printf(Perl_debug_log,
1221                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1222         my_exit(1);
1223     }
1224 #endif /* HAS_64K_LIMIT */
1225     if (SvROK(sv))
1226         sv_unref(sv);
1227     if (SvTYPE(sv) < SVt_PV) {
1228         sv_upgrade(sv, SVt_PV);
1229         s = SvPVX(sv);
1230     }
1231     else if (SvOOK(sv)) {       /* pv is offset? */
1232         sv_backoff(sv);
1233         s = SvPVX(sv);
1234         if (newlen > SvLEN(sv))
1235             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1236 #ifdef HAS_64K_LIMIT
1237         if (newlen >= 0x10000)
1238             newlen = 0xFFFF;
1239 #endif
1240     }
1241     else
1242         s = SvPVX(sv);
1243     if (newlen > SvLEN(sv)) {           /* need more room? */
1244         if (SvLEN(sv) && s) {
1245 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
1246             STRLEN l = malloced_size((void*)SvPVX(sv));
1247             if (newlen <= l) {
1248                 SvLEN_set(sv, l);
1249                 return s;
1250             } else
1251 #endif
1252             Renew(s,newlen,char);
1253         }
1254         else
1255             New(703,s,newlen,char);
1256         SvPV_set(sv, s);
1257         SvLEN_set(sv, newlen);
1258     }
1259     return s;
1260 }
1261
1262 void
1263 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1264 {
1265     SV_CHECK_THINKFIRST(sv);
1266     switch (SvTYPE(sv)) {
1267     case SVt_NULL:
1268         sv_upgrade(sv, SVt_IV);
1269         break;
1270     case SVt_NV:
1271         sv_upgrade(sv, SVt_PVNV);
1272         break;
1273     case SVt_RV:
1274     case SVt_PV:
1275         sv_upgrade(sv, SVt_PVIV);
1276         break;
1277
1278     case SVt_PVGV:
1279     case SVt_PVAV:
1280     case SVt_PVHV:
1281     case SVt_PVCV:
1282     case SVt_PVFM:
1283     case SVt_PVIO:
1284         {
1285             dTHR;
1286             Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1287                   PL_op_desc[PL_op->op_type]);
1288         }
1289     }
1290     (void)SvIOK_only(sv);                       /* validate number */
1291     SvIVX(sv) = i;
1292     SvTAINT(sv);
1293 }
1294
1295 void
1296 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1297 {
1298     sv_setiv(sv,i);
1299     SvSETMAGIC(sv);
1300 }
1301
1302 void
1303 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1304 {
1305     sv_setiv(sv, 0);
1306     SvIsUV_on(sv);
1307     SvUVX(sv) = u;
1308 }
1309
1310 void
1311 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1312 {
1313     sv_setuv(sv,u);
1314     SvSETMAGIC(sv);
1315 }
1316
1317 void
1318 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1319 {
1320     SV_CHECK_THINKFIRST(sv);
1321     switch (SvTYPE(sv)) {
1322     case SVt_NULL:
1323     case SVt_IV:
1324         sv_upgrade(sv, SVt_NV);
1325         break;
1326     case SVt_RV:
1327     case SVt_PV:
1328     case SVt_PVIV:
1329         sv_upgrade(sv, SVt_PVNV);
1330         break;
1331
1332     case SVt_PVGV:
1333     case SVt_PVAV:
1334     case SVt_PVHV:
1335     case SVt_PVCV:
1336     case SVt_PVFM:
1337     case SVt_PVIO:
1338         {
1339             dTHR;
1340             Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1341                   PL_op_name[PL_op->op_type]);
1342         }
1343     }
1344     SvNVX(sv) = num;
1345     (void)SvNOK_only(sv);                       /* validate number */
1346     SvTAINT(sv);
1347 }
1348
1349 void
1350 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1351 {
1352     sv_setnv(sv,num);
1353     SvSETMAGIC(sv);
1354 }
1355
1356 STATIC void
1357 S_not_a_number(pTHX_ SV *sv)
1358 {
1359     dTHR;
1360     char tmpbuf[64];
1361     char *d = tmpbuf;
1362     char *s;
1363     char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1364                   /* each *s can expand to 4 chars + "...\0",
1365                      i.e. need room for 8 chars */
1366
1367     for (s = SvPVX(sv); *s && d < limit; s++) {
1368         int ch = *s & 0xFF;
1369         if (ch & 128 && !isPRINT_LC(ch)) {
1370             *d++ = 'M';
1371             *d++ = '-';
1372             ch &= 127;
1373         }
1374         if (ch == '\n') {
1375             *d++ = '\\';
1376             *d++ = 'n';
1377         }
1378         else if (ch == '\r') {
1379             *d++ = '\\';
1380             *d++ = 'r';
1381         }
1382         else if (ch == '\f') {
1383             *d++ = '\\';
1384             *d++ = 'f';
1385         }
1386         else if (ch == '\\') {
1387             *d++ = '\\';
1388             *d++ = '\\';
1389         }
1390         else if (isPRINT_LC(ch))
1391             *d++ = ch;
1392         else {
1393             *d++ = '^';
1394             *d++ = toCTRL(ch);
1395         }
1396     }
1397     if (*s) {
1398         *d++ = '.';
1399         *d++ = '.';
1400         *d++ = '.';
1401     }
1402     *d = '\0';
1403
1404     if (PL_op)
1405         Perl_warner(aTHX_ WARN_NUMERIC,
1406                     "Argument \"%s\" isn't numeric in %s", tmpbuf,
1407                 PL_op_desc[PL_op->op_type]);
1408     else
1409         Perl_warner(aTHX_ WARN_NUMERIC,
1410                     "Argument \"%s\" isn't numeric", tmpbuf);
1411 }
1412
1413 /* the number can be converted to integer with atol() or atoll() */
1414 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1415 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1416 #define IS_NUMBER_NOT_IV         0x04 /* (IV)atof() may be != atof() */
1417 #define IS_NUMBER_NEG            0x08 /* not good to cache UV */
1418
1419 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1420    until proven guilty, assume that things are not that bad... */
1421
1422 IV
1423 Perl_sv_2iv(pTHX_ register SV *sv)
1424 {
1425     if (!sv)
1426         return 0;
1427     if (SvGMAGICAL(sv)) {
1428         mg_get(sv);
1429         if (SvIOKp(sv))
1430             return SvIVX(sv);
1431         if (SvNOKp(sv)) {
1432             return I_V(SvNVX(sv));
1433         }
1434         if (SvPOKp(sv) && SvLEN(sv))
1435             return asIV(sv);
1436         if (!SvROK(sv)) {
1437             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1438                 dTHR;
1439                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1440                     report_uninit();
1441             }
1442             return 0;
1443         }
1444     }
1445     if (SvTHINKFIRST(sv)) {
1446         if (SvROK(sv)) {
1447           SV* tmpstr;
1448           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1449               return SvIV(tmpstr);
1450           return PTR2IV(SvRV(sv));
1451         }
1452         if (SvREADONLY(sv) && !SvOK(sv)) {
1453             dTHR;
1454             if (ckWARN(WARN_UNINITIALIZED))
1455                 report_uninit();
1456             return 0;
1457         }
1458     }
1459     if (SvIOKp(sv)) {
1460         if (SvIsUV(sv)) {
1461             return (IV)(SvUVX(sv));
1462         }
1463         else {
1464             return SvIVX(sv);
1465         }
1466     }
1467     if (SvNOKp(sv)) {
1468         /* We can cache the IV/UV value even if it not good enough
1469          * to reconstruct NV, since the conversion to PV will prefer
1470          * NV over IV/UV.
1471          */
1472
1473         if (SvTYPE(sv) == SVt_NV)
1474             sv_upgrade(sv, SVt_PVNV);
1475
1476         (void)SvIOK_on(sv);
1477         if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1478             SvIVX(sv) = I_V(SvNVX(sv));
1479         else {
1480             SvUVX(sv) = U_V(SvNVX(sv));
1481             SvIsUV_on(sv);
1482           ret_iv_max:
1483             DEBUG_c(PerlIO_printf(Perl_debug_log,
1484                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1485                                   PTR2UV(sv),
1486                                   SvUVX(sv),
1487                                   SvUVX(sv)));
1488             return (IV)SvUVX(sv);
1489         }
1490     }
1491     else if (SvPOKp(sv) && SvLEN(sv)) {
1492         I32 numtype = looks_like_number(sv);
1493
1494         /* We want to avoid a possible problem when we cache an IV which
1495            may be later translated to an NV, and the resulting NV is not
1496            the translation of the initial data.
1497
1498            This means that if we cache such an IV, we need to cache the
1499            NV as well.  Moreover, we trade speed for space, and do not
1500            cache the NV if not needed.
1501          */
1502         if (numtype & IS_NUMBER_NOT_IV) {
1503             /* May be not an integer.  Need to cache NV if we cache IV
1504              * - otherwise future conversion to NV will be wrong.  */
1505             NV d;
1506
1507             d = Atof(SvPVX(sv));
1508
1509             if (SvTYPE(sv) < SVt_PVNV)
1510                 sv_upgrade(sv, SVt_PVNV);
1511             SvNVX(sv) = d;
1512             (void)SvNOK_on(sv);
1513             (void)SvIOK_on(sv);
1514 #if defined(USE_LONG_DOUBLE)
1515             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1516                                   PTR2UV(sv), SvNVX(sv)));
1517 #else
1518             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1519                                   PTR2UV(sv), SvNVX(sv)));
1520 #endif
1521             if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1522                 SvIVX(sv) = I_V(SvNVX(sv));
1523             else {
1524                 SvUVX(sv) = U_V(SvNVX(sv));
1525                 SvIsUV_on(sv);
1526                 goto ret_iv_max;
1527             }
1528         }
1529         else if (numtype) {
1530             /* The NV may be reconstructed from IV - safe to cache IV,
1531                which may be calculated by atol(). */
1532             if (SvTYPE(sv) == SVt_PV)
1533                 sv_upgrade(sv, SVt_PVIV);
1534             (void)SvIOK_on(sv);
1535             SvIVX(sv) = Atol(SvPVX(sv));
1536         }
1537         else {                          /* Not a number.  Cache 0. */
1538             dTHR;
1539
1540             if (SvTYPE(sv) < SVt_PVIV)
1541                 sv_upgrade(sv, SVt_PVIV);
1542             SvIVX(sv) = 0;
1543             (void)SvIOK_on(sv);
1544             if (ckWARN(WARN_NUMERIC))
1545                 not_a_number(sv);
1546         }
1547     }
1548     else  {
1549         dTHR;
1550         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1551             report_uninit();
1552         if (SvTYPE(sv) < SVt_IV)
1553             /* Typically the caller expects that sv_any is not NULL now.  */
1554             sv_upgrade(sv, SVt_IV);
1555         return 0;
1556     }
1557     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1558         PTR2UV(sv),SvIVX(sv)));
1559     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1560 }
1561
1562 UV
1563 Perl_sv_2uv(pTHX_ register SV *sv)
1564 {
1565     if (!sv)
1566         return 0;
1567     if (SvGMAGICAL(sv)) {
1568         mg_get(sv);
1569         if (SvIOKp(sv))
1570             return SvUVX(sv);
1571         if (SvNOKp(sv))
1572             return U_V(SvNVX(sv));
1573         if (SvPOKp(sv) && SvLEN(sv))
1574             return asUV(sv);
1575         if (!SvROK(sv)) {
1576             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1577                 dTHR;
1578                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1579                     report_uninit();
1580             }
1581             return 0;
1582         }
1583     }
1584     if (SvTHINKFIRST(sv)) {
1585         if (SvROK(sv)) {
1586           SV* tmpstr;
1587           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1588               return SvUV(tmpstr);
1589           return PTR2UV(SvRV(sv));
1590         }
1591         if (SvREADONLY(sv) && !SvOK(sv)) {
1592             dTHR;
1593             if (ckWARN(WARN_UNINITIALIZED))
1594                 report_uninit();
1595             return 0;
1596         }
1597     }
1598     if (SvIOKp(sv)) {
1599         if (SvIsUV(sv)) {
1600             return SvUVX(sv);
1601         }
1602         else {
1603             return (UV)SvIVX(sv);
1604         }
1605     }
1606     if (SvNOKp(sv)) {
1607         /* We can cache the IV/UV value even if it not good enough
1608          * to reconstruct NV, since the conversion to PV will prefer
1609          * NV over IV/UV.
1610          */
1611         if (SvTYPE(sv) == SVt_NV)
1612             sv_upgrade(sv, SVt_PVNV);
1613         (void)SvIOK_on(sv);
1614         if (SvNVX(sv) >= -0.5) {
1615             SvIsUV_on(sv);
1616             SvUVX(sv) = U_V(SvNVX(sv));
1617         }
1618         else {
1619             SvIVX(sv) = I_V(SvNVX(sv));
1620           ret_zero:
1621             DEBUG_c(PerlIO_printf(Perl_debug_log,
1622                                   "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1623                                   PTR2UV(sv),
1624                                   SvIVX(sv),
1625                                   (IV)(UV)SvIVX(sv)));
1626             return (UV)SvIVX(sv);
1627         }
1628     }
1629     else if (SvPOKp(sv) && SvLEN(sv)) {
1630         I32 numtype = looks_like_number(sv);
1631
1632         /* We want to avoid a possible problem when we cache a UV which
1633            may be later translated to an NV, and the resulting NV is not
1634            the translation of the initial data.
1635
1636            This means that if we cache such a UV, we need to cache the
1637            NV as well.  Moreover, we trade speed for space, and do not
1638            cache the NV if not needed.
1639          */
1640         if (numtype & IS_NUMBER_NOT_IV) {
1641             /* May be not an integer.  Need to cache NV if we cache IV
1642              * - otherwise future conversion to NV will be wrong.  */
1643             NV d;
1644
1645             d = Atof(SvPVX(sv));
1646
1647             if (SvTYPE(sv) < SVt_PVNV)
1648                 sv_upgrade(sv, SVt_PVNV);
1649             SvNVX(sv) = d;
1650             (void)SvNOK_on(sv);
1651             (void)SvIOK_on(sv);
1652 #if defined(USE_LONG_DOUBLE)
1653             DEBUG_c(PerlIO_printf(Perl_debug_log,
1654                                   "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1655                                   PTR2UV(sv), SvNVX(sv)));
1656 #else
1657             DEBUG_c(PerlIO_printf(Perl_debug_log,
1658                                   "0x%"UVxf" 2nv(%g)\n",
1659                                   PTR2UV(sv), SvNVX(sv)));
1660 #endif
1661             if (SvNVX(sv) < -0.5) {
1662                 SvIVX(sv) = I_V(SvNVX(sv));
1663                 goto ret_zero;
1664             } else {
1665                 SvUVX(sv) = U_V(SvNVX(sv));
1666                 SvIsUV_on(sv);
1667             }
1668         }
1669         else if (numtype & IS_NUMBER_NEG) {
1670             /* The NV may be reconstructed from IV - safe to cache IV,
1671                which may be calculated by atol(). */
1672             if (SvTYPE(sv) == SVt_PV)
1673                 sv_upgrade(sv, SVt_PVIV);
1674             (void)SvIOK_on(sv);
1675             SvIVX(sv) = (IV)Atol(SvPVX(sv));
1676         }
1677         else if (numtype) {             /* Non-negative */
1678             /* The NV may be reconstructed from UV - safe to cache UV,
1679                which may be calculated by strtoul()/atol. */
1680             if (SvTYPE(sv) == SVt_PV)
1681                 sv_upgrade(sv, SVt_PVIV);
1682             (void)SvIOK_on(sv);
1683             (void)SvIsUV_on(sv);
1684 #ifdef HAS_STRTOUL
1685             SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1686 #else                   /* no atou(), but we know the number fits into IV... */
1687                         /* The only problem may be if it is negative... */
1688             SvUVX(sv) = (UV)Atol(SvPVX(sv));
1689 #endif
1690         }
1691         else {                          /* Not a number.  Cache 0. */
1692             dTHR;
1693
1694             if (SvTYPE(sv) < SVt_PVIV)
1695                 sv_upgrade(sv, SVt_PVIV);
1696             SvUVX(sv) = 0;              /* We assume that 0s have the
1697                                            same bitmap in IV and UV. */
1698             (void)SvIOK_on(sv);
1699             (void)SvIsUV_on(sv);
1700             if (ckWARN(WARN_NUMERIC))
1701                 not_a_number(sv);
1702         }
1703     }
1704     else  {
1705         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1706             dTHR;
1707             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1708                 report_uninit();
1709         }
1710         if (SvTYPE(sv) < SVt_IV)
1711             /* Typically the caller expects that sv_any is not NULL now.  */
1712             sv_upgrade(sv, SVt_IV);
1713         return 0;
1714     }
1715
1716     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1717                           PTR2UV(sv),SvUVX(sv)));
1718     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1719 }
1720
1721 NV
1722 Perl_sv_2nv(pTHX_ register SV *sv)
1723 {
1724     if (!sv)
1725         return 0.0;
1726     if (SvGMAGICAL(sv)) {
1727         mg_get(sv);
1728         if (SvNOKp(sv))
1729             return SvNVX(sv);
1730         if (SvPOKp(sv) && SvLEN(sv)) {
1731             dTHR;
1732             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1733                 not_a_number(sv);
1734             return Atof(SvPVX(sv));
1735         }
1736         if (SvIOKp(sv)) {
1737             if (SvIsUV(sv))
1738                 return (NV)SvUVX(sv);
1739             else
1740                 return (NV)SvIVX(sv);
1741         }
1742         if (!SvROK(sv)) {
1743             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1744                 dTHR;
1745                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1746                     report_uninit();
1747             }
1748             return 0;
1749         }
1750     }
1751     if (SvTHINKFIRST(sv)) {
1752         if (SvROK(sv)) {
1753           SV* tmpstr;
1754           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1755               return SvNV(tmpstr);
1756           return PTR2NV(SvRV(sv));
1757         }
1758         if (SvREADONLY(sv) && !SvOK(sv)) {
1759             dTHR;
1760             if (ckWARN(WARN_UNINITIALIZED))
1761                 report_uninit();
1762             return 0.0;
1763         }
1764     }
1765     if (SvTYPE(sv) < SVt_NV) {
1766         if (SvTYPE(sv) == SVt_IV)
1767             sv_upgrade(sv, SVt_PVNV);
1768         else
1769             sv_upgrade(sv, SVt_NV);
1770 #if defined(USE_LONG_DOUBLE)
1771         DEBUG_c({
1772             RESTORE_NUMERIC_STANDARD();
1773             PerlIO_printf(Perl_debug_log,
1774                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1775                           PTR2UV(sv), SvNVX(sv));
1776             RESTORE_NUMERIC_LOCAL();
1777         });
1778 #else
1779         DEBUG_c({
1780             RESTORE_NUMERIC_STANDARD();
1781             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1782                           PTR2UV(sv), SvNVX(sv));
1783             RESTORE_NUMERIC_LOCAL();
1784         });
1785 #endif
1786     }
1787     else if (SvTYPE(sv) < SVt_PVNV)
1788         sv_upgrade(sv, SVt_PVNV);
1789     if (SvIOKp(sv) &&
1790             (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1791     {
1792         SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1793     }
1794     else if (SvPOKp(sv) && SvLEN(sv)) {
1795         dTHR;
1796         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1797             not_a_number(sv);
1798         SvNVX(sv) = Atof(SvPVX(sv));
1799     }
1800     else  {
1801         dTHR;
1802         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1803             report_uninit();
1804         if (SvTYPE(sv) < SVt_NV)
1805             /* Typically the caller expects that sv_any is not NULL now.  */
1806             sv_upgrade(sv, SVt_NV);
1807         return 0.0;
1808     }
1809     SvNOK_on(sv);
1810 #if defined(USE_LONG_DOUBLE)
1811     DEBUG_c({
1812         RESTORE_NUMERIC_STANDARD();
1813         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1814                       PTR2UV(sv), SvNVX(sv));
1815         RESTORE_NUMERIC_LOCAL();
1816     });
1817 #else
1818     DEBUG_c({
1819         RESTORE_NUMERIC_STANDARD();
1820         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1821                       PTR2UV(sv), SvNVX(sv));
1822         RESTORE_NUMERIC_LOCAL();
1823     });
1824 #endif
1825     return SvNVX(sv);
1826 }
1827
1828 STATIC IV
1829 S_asIV(pTHX_ SV *sv)
1830 {
1831     I32 numtype = looks_like_number(sv);
1832     NV d;
1833
1834     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1835         return Atol(SvPVX(sv));
1836     if (!numtype) {
1837         dTHR;
1838         if (ckWARN(WARN_NUMERIC))
1839             not_a_number(sv);
1840     }
1841     d = Atof(SvPVX(sv));
1842     return I_V(d);
1843 }
1844
1845 STATIC UV
1846 S_asUV(pTHX_ SV *sv)
1847 {
1848     I32 numtype = looks_like_number(sv);
1849
1850 #ifdef HAS_STRTOUL
1851     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1852         return Strtoul(SvPVX(sv), Null(char**), 10);
1853 #endif
1854     if (!numtype) {
1855         dTHR;
1856         if (ckWARN(WARN_NUMERIC))
1857             not_a_number(sv);
1858     }
1859     return U_V(Atof(SvPVX(sv)));
1860 }
1861
1862 /*
1863  * Returns a combination of (advisory only - can get false negatives)
1864  *      IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1865  *      IS_NUMBER_NEG
1866  * 0 if does not look like number.
1867  *
1868  * In fact possible values are 0 and
1869  * IS_NUMBER_TO_INT_BY_ATOL                             123
1870  * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV          123.1
1871  * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV          123e0
1872  * with a possible addition of IS_NUMBER_NEG.
1873  */
1874
1875 I32
1876 Perl_looks_like_number(pTHX_ SV *sv)
1877 {
1878     register char *s;
1879     register char *send;
1880     register char *sbegin;
1881     register char *nbegin;
1882     I32 numtype = 0;
1883     STRLEN len;
1884
1885     if (SvPOK(sv)) {
1886         sbegin = SvPVX(sv);
1887         len = SvCUR(sv);
1888     }
1889     else if (SvPOKp(sv))
1890         sbegin = SvPV(sv, len);
1891     else
1892         return 1;
1893     send = sbegin + len;
1894
1895     s = sbegin;
1896     while (isSPACE(*s))
1897         s++;
1898     if (*s == '-') {
1899         s++;
1900         numtype = IS_NUMBER_NEG;
1901     }
1902     else if (*s == '+')
1903         s++;
1904
1905     nbegin = s;
1906     /*
1907      * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1908      * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1909      * (int)atof().
1910      */
1911
1912     /* next must be digit or the radix separator */
1913     if (isDIGIT(*s)) {
1914         do {
1915             s++;
1916         } while (isDIGIT(*s));
1917
1918         if (s - nbegin >= TYPE_DIGITS(IV))      /* Cannot cache ato[ul]() */
1919             numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1920         else
1921             numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1922
1923         if (*s == '.'
1924 #ifdef USE_LOCALE_NUMERIC
1925             || IS_NUMERIC_RADIX(*s)
1926 #endif
1927             ) {
1928             s++;
1929             numtype |= IS_NUMBER_NOT_IV;
1930             while (isDIGIT(*s))  /* optional digits after the radix */
1931                 s++;
1932         }
1933     }
1934     else if (*s == '.'
1935 #ifdef USE_LOCALE_NUMERIC
1936             || IS_NUMERIC_RADIX(*s)
1937 #endif
1938             ) {
1939         s++;
1940         numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1941         /* no digits before the radix means we need digits after it */
1942         if (isDIGIT(*s)) {
1943             do {
1944                 s++;
1945             } while (isDIGIT(*s));
1946         }
1947         else
1948             return 0;
1949     }
1950     else
1951         return 0;
1952
1953     /* we can have an optional exponent part */
1954     if (*s == 'e' || *s == 'E') {
1955         numtype &= ~IS_NUMBER_NEG;
1956         numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1957         s++;
1958         if (*s == '+' || *s == '-')
1959             s++;
1960         if (isDIGIT(*s)) {
1961             do {
1962                 s++;
1963             } while (isDIGIT(*s));
1964         }
1965         else
1966             return 0;
1967     }
1968     while (isSPACE(*s))
1969         s++;
1970     if (s >= send)
1971         return numtype;
1972     if (len == 10 && memEQ(sbegin, "0 but true", 10))
1973         return IS_NUMBER_TO_INT_BY_ATOL;
1974     return 0;
1975 }
1976
1977 char *
1978 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1979 {
1980     STRLEN n_a;
1981     return sv_2pv(sv, &n_a);
1982 }
1983
1984 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1985 static char *
1986 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1987 {
1988     STRLEN len;
1989     char *ptr = buf + TYPE_CHARS(UV);
1990     char *ebuf = ptr;
1991     int sign;
1992     char *p;
1993
1994     if (is_uv)
1995         sign = 0;
1996     else if (iv >= 0) {
1997         uv = iv;
1998         sign = 0;
1999     } else {
2000         uv = -iv;
2001         sign = 1;
2002     }
2003     do {
2004         *--ptr = '0' + (uv % 10);
2005     } while (uv /= 10);
2006     if (sign)
2007         *--ptr = '-';
2008     *peob = ebuf;
2009     return ptr;
2010 }
2011
2012 char *
2013 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2014 {
2015     register char *s;
2016     int olderrno;
2017     SV *tsv;
2018     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2019     char *tmpbuf = tbuf;
2020
2021     if (!sv) {
2022         *lp = 0;
2023         return "";
2024     }
2025     if (SvGMAGICAL(sv)) {
2026         mg_get(sv);
2027         if (SvPOKp(sv)) {
2028             *lp = SvCUR(sv);
2029             return SvPVX(sv);
2030         }
2031         if (SvIOKp(sv)) {
2032             if (SvIsUV(sv))
2033                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2034             else
2035                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2036             tsv = Nullsv;
2037             goto tokensave;
2038         }
2039         if (SvNOKp(sv)) {
2040             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2041             tsv = Nullsv;
2042             goto tokensave;
2043         }
2044         if (!SvROK(sv)) {
2045             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2046                 dTHR;
2047                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2048                     report_uninit();
2049             }
2050             *lp = 0;
2051             return "";
2052         }
2053     }
2054     if (SvTHINKFIRST(sv)) {
2055         if (SvROK(sv)) {
2056             SV* tmpstr;
2057             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2058                 return SvPV(tmpstr,*lp);
2059             sv = (SV*)SvRV(sv);
2060             if (!sv)
2061                 s = "NULLREF";
2062             else {
2063                 MAGIC *mg;
2064
2065                 switch (SvTYPE(sv)) {
2066                 case SVt_PVMG:
2067                     if ( ((SvFLAGS(sv) &
2068                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2069                           == (SVs_OBJECT|SVs_RMG))
2070                          && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2071                          && (mg = mg_find(sv, 'r'))) {
2072                         dTHR;
2073                         regexp *re = (regexp *)mg->mg_obj;
2074
2075                         if (!mg->mg_ptr) {
2076                             char *fptr = "msix";
2077                             char reflags[6];
2078                             char ch;
2079                             int left = 0;
2080                             int right = 4;
2081                             U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2082
2083                             while(ch = *fptr++) {
2084                                 if(reganch & 1) {
2085                                     reflags[left++] = ch;
2086                                 }
2087                                 else {
2088                                     reflags[right--] = ch;
2089                                 }
2090                                 reganch >>= 1;
2091                             }
2092                             if(left != 4) {
2093                                 reflags[left] = '-';
2094                                 left = 5;
2095                             }
2096
2097                             mg->mg_len = re->prelen + 4 + left;
2098                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2099                             Copy("(?", mg->mg_ptr, 2, char);
2100                             Copy(reflags, mg->mg_ptr+2, left, char);
2101                             Copy(":", mg->mg_ptr+left+2, 1, char);
2102                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2103                             mg->mg_ptr[mg->mg_len - 1] = ')';
2104                             mg->mg_ptr[mg->mg_len] = 0;
2105                         }
2106                         PL_reginterp_cnt += re->program[0].next_off;
2107                         *lp = mg->mg_len;
2108                         return mg->mg_ptr;
2109                     }
2110                                         /* Fall through */
2111                 case SVt_NULL:
2112                 case SVt_IV:
2113                 case SVt_NV:
2114                 case SVt_RV:
2115                 case SVt_PV:
2116                 case SVt_PVIV:
2117                 case SVt_PVNV:
2118                 case SVt_PVBM:  s = "SCALAR";                   break;
2119                 case SVt_PVLV:  s = "LVALUE";                   break;
2120                 case SVt_PVAV:  s = "ARRAY";                    break;
2121                 case SVt_PVHV:  s = "HASH";                     break;
2122                 case SVt_PVCV:  s = "CODE";                     break;
2123                 case SVt_PVGV:  s = "GLOB";                     break;
2124                 case SVt_PVFM:  s = "FORMAT";                   break;
2125                 case SVt_PVIO:  s = "IO";                       break;
2126                 default:        s = "UNKNOWN";                  break;
2127                 }
2128                 tsv = NEWSV(0,0);
2129                 if (SvOBJECT(sv))
2130                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2131                 else
2132                     sv_setpv(tsv, s);
2133                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2134                 goto tokensaveref;
2135             }
2136             *lp = strlen(s);
2137             return s;
2138         }
2139         if (SvREADONLY(sv) && !SvOK(sv)) {
2140             dTHR;
2141             if (ckWARN(WARN_UNINITIALIZED))
2142                 report_uninit();
2143             *lp = 0;
2144             return "";
2145         }
2146     }
2147     if (SvNOKp(sv)) {                   /* See note in sv_2uv() */
2148         /* XXXX 64-bit?  IV may have better precision... */
2149         /* I tried changing this for to be 64-bit-aware and
2150          * the t/op/numconvert.t became very, very, angry.
2151          * --jhi Sep 1999 */
2152         if (SvTYPE(sv) < SVt_PVNV)
2153             sv_upgrade(sv, SVt_PVNV);
2154         SvGROW(sv, 28);
2155         s = SvPVX(sv);
2156         olderrno = errno;       /* some Xenix systems wipe out errno here */
2157 #ifdef apollo
2158         if (SvNVX(sv) == 0.0)
2159             (void)strcpy(s,"0");
2160         else
2161 #endif /*apollo*/
2162         {
2163             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2164         }
2165         errno = olderrno;
2166 #ifdef FIXNEGATIVEZERO
2167         if (*s == '-' && s[1] == '0' && !s[2])
2168             strcpy(s,"0");
2169 #endif
2170         while (*s) s++;
2171 #ifdef hcx
2172         if (s[-1] == '.')
2173             *--s = '\0';
2174 #endif
2175     }
2176     else if (SvIOKp(sv)) {
2177         U32 isIOK = SvIOK(sv);
2178         U32 isUIOK = SvIsUV(sv);
2179         char buf[TYPE_CHARS(UV)];
2180         char *ebuf, *ptr;
2181
2182         if (SvTYPE(sv) < SVt_PVIV)
2183             sv_upgrade(sv, SVt_PVIV);
2184         if (isUIOK)
2185             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2186         else
2187             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2188         SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
2189         Move(ptr,SvPVX(sv),ebuf - ptr,char);
2190         SvCUR_set(sv, ebuf - ptr);
2191         s = SvEND(sv);
2192         *s = '\0';
2193         if (isIOK)
2194             SvIOK_on(sv);
2195         else
2196             SvIOKp_on(sv);
2197         if (isUIOK)
2198             SvIsUV_on(sv);
2199         SvPOK_on(sv);
2200     }
2201     else {
2202         dTHR;
2203         if (ckWARN(WARN_UNINITIALIZED)
2204             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2205         {
2206             report_uninit();
2207         }
2208         *lp = 0;
2209         if (SvTYPE(sv) < SVt_PV)
2210             /* Typically the caller expects that sv_any is not NULL now.  */
2211             sv_upgrade(sv, SVt_PV);
2212         return "";
2213     }
2214     *lp = s - SvPVX(sv);
2215     SvCUR_set(sv, *lp);
2216     SvPOK_on(sv);
2217     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2218                           PTR2UV(sv),SvPVX(sv)));
2219     return SvPVX(sv);
2220
2221   tokensave:
2222     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
2223         /* Sneaky stuff here */
2224
2225       tokensaveref:
2226         if (!tsv)
2227             tsv = newSVpv(tmpbuf, 0);
2228         sv_2mortal(tsv);
2229         *lp = SvCUR(tsv);
2230         return SvPVX(tsv);
2231     }
2232     else {
2233         STRLEN len;
2234         char *t;
2235
2236         if (tsv) {
2237             sv_2mortal(tsv);
2238             t = SvPVX(tsv);
2239             len = SvCUR(tsv);
2240         }
2241         else {
2242             t = tmpbuf;
2243             len = strlen(tmpbuf);
2244         }
2245 #ifdef FIXNEGATIVEZERO
2246         if (len == 2 && t[0] == '-' && t[1] == '0') {
2247             t = "0";
2248             len = 1;
2249         }
2250 #endif
2251         (void)SvUPGRADE(sv, SVt_PV);
2252         *lp = len;
2253         s = SvGROW(sv, len + 1);
2254         SvCUR_set(sv, len);
2255         (void)strcpy(s, t);
2256         SvPOKp_on(sv);
2257         return s;
2258     }
2259 }
2260
2261 char *
2262 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2263 {
2264     return sv_2pv_nolen(sv);
2265 }
2266
2267 char *
2268 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2269 {
2270     return sv_2pv(sv,lp);
2271 }
2272
2273 char *
2274 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2275 {
2276     return sv_2pv_nolen(sv);
2277 }
2278
2279 char *
2280 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2281 {
2282     return sv_2pv(sv,lp);
2283 }
2284
2285 /* This function is only called on magical items */
2286 bool
2287 Perl_sv_2bool(pTHX_ register SV *sv)
2288 {
2289     if (SvGMAGICAL(sv))
2290         mg_get(sv);
2291
2292     if (!SvOK(sv))
2293         return 0;
2294     if (SvROK(sv)) {
2295         dTHR;
2296         SV* tmpsv;
2297         if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2298             return SvTRUE(tmpsv);
2299       return SvRV(sv) != 0;
2300     }
2301     if (SvPOKp(sv)) {
2302         register XPV* Xpvtmp;
2303         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2304                 (*Xpvtmp->xpv_pv > '0' ||
2305                 Xpvtmp->xpv_cur > 1 ||
2306                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2307             return 1;
2308         else
2309             return 0;
2310     }
2311     else {
2312         if (SvIOKp(sv))
2313             return SvIVX(sv) != 0;
2314         else {
2315             if (SvNOKp(sv))
2316                 return SvNVX(sv) != 0.0;
2317             else
2318                 return FALSE;
2319         }
2320     }
2321 }
2322
2323 /* Note: sv_setsv() should not be called with a source string that needs
2324  * to be reused, since it may destroy the source string if it is marked
2325  * as temporary.
2326  */
2327
2328 void
2329 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2330 {
2331     dTHR;
2332     register U32 sflags;
2333     register int dtype;
2334     register int stype;
2335
2336     if (sstr == dstr)
2337         return;
2338     SV_CHECK_THINKFIRST(dstr);
2339     if (!sstr)
2340         sstr = &PL_sv_undef;
2341     stype = SvTYPE(sstr);
2342     dtype = SvTYPE(dstr);
2343
2344     SvAMAGIC_off(dstr);
2345
2346     /* There's a lot of redundancy below but we're going for speed here */
2347
2348     switch (stype) {
2349     case SVt_NULL:
2350       undef_sstr:
2351         if (dtype != SVt_PVGV) {
2352             (void)SvOK_off(dstr);
2353             return;
2354         }
2355         break;
2356     case SVt_IV:
2357         if (SvIOK(sstr)) {
2358             switch (dtype) {
2359             case SVt_NULL:
2360                 sv_upgrade(dstr, SVt_IV);
2361                 break;
2362             case SVt_NV:
2363                 sv_upgrade(dstr, SVt_PVNV);
2364                 break;
2365             case SVt_RV:
2366             case SVt_PV:
2367                 sv_upgrade(dstr, SVt_PVIV);
2368                 break;
2369             }
2370             (void)SvIOK_only(dstr);
2371             SvIVX(dstr) = SvIVX(sstr);
2372             if (SvIsUV(sstr))
2373                 SvIsUV_on(dstr);
2374             SvTAINT(dstr);
2375             return;
2376         }
2377         goto undef_sstr;
2378
2379     case SVt_NV:
2380         if (SvNOK(sstr)) {
2381             switch (dtype) {
2382             case SVt_NULL:
2383             case SVt_IV:
2384                 sv_upgrade(dstr, SVt_NV);
2385                 break;
2386             case SVt_RV:
2387             case SVt_PV:
2388             case SVt_PVIV:
2389                 sv_upgrade(dstr, SVt_PVNV);
2390                 break;
2391             }
2392             SvNVX(dstr) = SvNVX(sstr);
2393             (void)SvNOK_only(dstr);
2394             SvTAINT(dstr);
2395             return;
2396         }
2397         goto undef_sstr;
2398
2399     case SVt_RV:
2400         if (dtype < SVt_RV)
2401             sv_upgrade(dstr, SVt_RV);
2402         else if (dtype == SVt_PVGV &&
2403                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2404             sstr = SvRV(sstr);
2405             if (sstr == dstr) {
2406                 if (GvIMPORTED(dstr) != GVf_IMPORTED
2407                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2408                 {
2409                     GvIMPORTED_on(dstr);
2410                 }
2411                 GvMULTI_on(dstr);
2412                 return;
2413             }
2414             goto glob_assign;
2415         }
2416         break;
2417     case SVt_PV:
2418     case SVt_PVFM:
2419         if (dtype < SVt_PV)
2420             sv_upgrade(dstr, SVt_PV);
2421         break;
2422     case SVt_PVIV:
2423         if (dtype < SVt_PVIV)
2424             sv_upgrade(dstr, SVt_PVIV);
2425         break;
2426     case SVt_PVNV:
2427         if (dtype < SVt_PVNV)
2428             sv_upgrade(dstr, SVt_PVNV);
2429         break;
2430     case SVt_PVAV:
2431     case SVt_PVHV:
2432     case SVt_PVCV:
2433     case SVt_PVIO:
2434         if (PL_op)
2435             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2436                 PL_op_name[PL_op->op_type]);
2437         else
2438             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2439         break;
2440
2441     case SVt_PVGV:
2442         if (dtype <= SVt_PVGV) {
2443   glob_assign:
2444             if (dtype != SVt_PVGV) {
2445                 char *name = GvNAME(sstr);
2446                 STRLEN len = GvNAMELEN(sstr);
2447                 sv_upgrade(dstr, SVt_PVGV);
2448                 sv_magic(dstr, dstr, '*', name, len);
2449                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2450                 GvNAME(dstr) = savepvn(name, len);
2451                 GvNAMELEN(dstr) = len;
2452                 SvFAKE_on(dstr);        /* can coerce to non-glob */
2453             }
2454             /* ahem, death to those who redefine active sort subs */
2455             else if (PL_curstackinfo->si_type == PERLSI_SORT
2456                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2457                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2458                       GvNAME(dstr));
2459             (void)SvOK_off(dstr);
2460             GvINTRO_off(dstr);          /* one-shot flag */
2461             gp_free((GV*)dstr);
2462             GvGP(dstr) = gp_ref(GvGP(sstr));
2463             SvTAINT(dstr);
2464             if (GvIMPORTED(dstr) != GVf_IMPORTED
2465                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2466             {
2467                 GvIMPORTED_on(dstr);
2468             }
2469             GvMULTI_on(dstr);
2470             return;
2471         }
2472         /* FALL THROUGH */
2473
2474     default:
2475         if (SvGMAGICAL(sstr)) {
2476             mg_get(sstr);
2477             if (SvTYPE(sstr) != stype) {
2478                 stype = SvTYPE(sstr);
2479                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2480                     goto glob_assign;
2481             }
2482         }
2483         if (stype == SVt_PVLV)
2484             (void)SvUPGRADE(dstr, SVt_PVNV);
2485         else
2486             (void)SvUPGRADE(dstr, stype);
2487     }
2488
2489     sflags = SvFLAGS(sstr);
2490
2491     if (sflags & SVf_ROK) {
2492         if (dtype >= SVt_PV) {
2493             if (dtype == SVt_PVGV) {
2494                 SV *sref = SvREFCNT_inc(SvRV(sstr));
2495                 SV *dref = 0;
2496                 int intro = GvINTRO(dstr);
2497
2498                 if (intro) {
2499                     GP *gp;
2500                     gp_free((GV*)dstr);
2501                     GvINTRO_off(dstr);  /* one-shot flag */
2502                     Newz(602,gp, 1, GP);
2503                     GvGP(dstr) = gp_ref(gp);
2504                     GvSV(dstr) = NEWSV(72,0);
2505                     GvLINE(dstr) = CopLINE(PL_curcop);
2506                     GvEGV(dstr) = (GV*)dstr;
2507                 }
2508                 GvMULTI_on(dstr);
2509                 switch (SvTYPE(sref)) {
2510                 case SVt_PVAV:
2511                     if (intro)
2512                         SAVESPTR(GvAV(dstr));
2513                     else
2514                         dref = (SV*)GvAV(dstr);
2515                     GvAV(dstr) = (AV*)sref;
2516                     if (GvIMPORTED_AV_off(dstr)
2517                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2518                     {
2519                         GvIMPORTED_AV_on(dstr);
2520                     }
2521                     break;
2522                 case SVt_PVHV:
2523                     if (intro)
2524                         SAVESPTR(GvHV(dstr));
2525                     else
2526                         dref = (SV*)GvHV(dstr);
2527                     GvHV(dstr) = (HV*)sref;
2528                     if (GvIMPORTED_HV_off(dstr)
2529                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2530                     {
2531                         GvIMPORTED_HV_on(dstr);
2532                     }
2533                     break;
2534                 case SVt_PVCV:
2535                     if (intro) {
2536                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2537                             SvREFCNT_dec(GvCV(dstr));
2538                             GvCV(dstr) = Nullcv;
2539                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2540                             PL_sub_generation++;
2541                         }
2542                         SAVESPTR(GvCV(dstr));
2543                     }
2544                     else
2545                         dref = (SV*)GvCV(dstr);
2546                     if (GvCV(dstr) != (CV*)sref) {
2547                         CV* cv = GvCV(dstr);
2548                         if (cv) {
2549                             if (!GvCVGEN((GV*)dstr) &&
2550                                 (CvROOT(cv) || CvXSUB(cv)))
2551                             {
2552                                 SV *const_sv = cv_const_sv(cv);
2553                                 bool const_changed = TRUE;
2554                                 if(const_sv)
2555                                     const_changed = sv_cmp(const_sv,
2556                                            op_const_sv(CvSTART((CV*)sref),
2557                                                        Nullcv));
2558                                 /* ahem, death to those who redefine
2559                                  * active sort subs */
2560                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2561                                       PL_sortcop == CvSTART(cv))
2562                                     Perl_croak(aTHX_
2563                                     "Can't redefine active sort subroutine %s",
2564                                           GvENAME((GV*)dstr));
2565                                 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2566                                     if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2567                                           && HvNAME(GvSTASH(CvGV(cv)))
2568                                           && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2569                                                    "autouse")))
2570                                         Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2571                                              "Constant subroutine %s redefined"
2572                                              : "Subroutine %s redefined",
2573                                              GvENAME((GV*)dstr));
2574                                 }
2575                             }
2576                             cv_ckproto(cv, (GV*)dstr,
2577                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
2578                         }
2579                         GvCV(dstr) = (CV*)sref;
2580                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2581                         GvASSUMECV_on(dstr);
2582                         PL_sub_generation++;
2583                     }
2584                     if (GvIMPORTED_CV_off(dstr)
2585                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2586                     {
2587                         GvIMPORTED_CV_on(dstr);
2588                     }
2589                     break;
2590                 case SVt_PVIO:
2591                     if (intro)
2592                         SAVESPTR(GvIOp(dstr));
2593                     else
2594                         dref = (SV*)GvIOp(dstr);
2595                     GvIOp(dstr) = (IO*)sref;
2596                     break;
2597                 default:
2598                     if (intro)
2599                         SAVESPTR(GvSV(dstr));
2600                     else
2601                         dref = (SV*)GvSV(dstr);
2602                     GvSV(dstr) = sref;
2603                     if (GvIMPORTED_SV_off(dstr)
2604                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2605                     {
2606                         GvIMPORTED_SV_on(dstr);
2607                     }
2608                     break;
2609                 }
2610                 if (dref)
2611                     SvREFCNT_dec(dref);
2612                 if (intro)
2613                     SAVEFREESV(sref);
2614                 SvTAINT(dstr);
2615                 return;
2616             }
2617             if (SvPVX(dstr)) {
2618                 (void)SvOOK_off(dstr);          /* backoff */
2619                 if (SvLEN(dstr))
2620                     Safefree(SvPVX(dstr));
2621                 SvLEN(dstr)=SvCUR(dstr)=0;
2622             }
2623         }
2624         (void)SvOK_off(dstr);
2625         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2626         SvROK_on(dstr);
2627         if (sflags & SVp_NOK) {
2628             SvNOK_on(dstr);
2629             SvNVX(dstr) = SvNVX(sstr);
2630         }
2631         if (sflags & SVp_IOK) {
2632             (void)SvIOK_on(dstr);
2633             SvIVX(dstr) = SvIVX(sstr);
2634             if (SvIsUV(sstr))
2635                 SvIsUV_on(dstr);
2636         }
2637         if (SvAMAGIC(sstr)) {
2638             SvAMAGIC_on(dstr);
2639         }
2640     }
2641     else if (sflags & SVp_POK) {
2642
2643         /*
2644          * Check to see if we can just swipe the string.  If so, it's a
2645          * possible small lose on short strings, but a big win on long ones.
2646          * It might even be a win on short strings if SvPVX(dstr)
2647          * has to be allocated and SvPVX(sstr) has to be freed.
2648          */
2649
2650         if (SvTEMP(sstr) &&             /* slated for free anyway? */
2651             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
2652             !(sflags & SVf_OOK))        /* and not involved in OOK hack? */
2653         {
2654             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
2655                 if (SvOOK(dstr)) {
2656                     SvFLAGS(dstr) &= ~SVf_OOK;
2657                     Safefree(SvPVX(dstr) - SvIVX(dstr));
2658                 }
2659                 else if (SvLEN(dstr))
2660                     Safefree(SvPVX(dstr));
2661             }
2662             (void)SvPOK_only(dstr);
2663             SvPV_set(dstr, SvPVX(sstr));
2664             SvLEN_set(dstr, SvLEN(sstr));
2665             SvCUR_set(dstr, SvCUR(sstr));
2666             SvTEMP_off(dstr);
2667             (void)SvOK_off(sstr);
2668             SvPV_set(sstr, Nullch);
2669             SvLEN_set(sstr, 0);
2670             SvCUR_set(sstr, 0);
2671             SvTEMP_off(sstr);
2672         }
2673         else {                                  /* have to copy actual string */
2674             STRLEN len = SvCUR(sstr);
2675
2676             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
2677             Move(SvPVX(sstr),SvPVX(dstr),len,char);
2678             SvCUR_set(dstr, len);
2679             *SvEND(dstr) = '\0';
2680             (void)SvPOK_only(dstr);
2681         }
2682         if (SvUTF8(sstr))
2683             SvUTF8_on(dstr);
2684         /*SUPPRESS 560*/
2685         if (sflags & SVp_NOK) {
2686             SvNOK_on(dstr);
2687             SvNVX(dstr) = SvNVX(sstr);
2688         }
2689         if (sflags & SVp_IOK) {
2690             (void)SvIOK_on(dstr);
2691             SvIVX(dstr) = SvIVX(sstr);
2692             if (SvIsUV(sstr))
2693                 SvIsUV_on(dstr);
2694         }
2695     }
2696     else if (sflags & SVp_NOK) {
2697         SvNVX(dstr) = SvNVX(sstr);
2698         (void)SvNOK_only(dstr);
2699         if (SvIOK(sstr)) {
2700             (void)SvIOK_on(dstr);
2701             SvIVX(dstr) = SvIVX(sstr);
2702             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
2703             if (SvIsUV(sstr))
2704                 SvIsUV_on(dstr);
2705         }
2706     }
2707     else if (sflags & SVp_IOK) {
2708         (void)SvIOK_only(dstr);
2709         SvIVX(dstr) = SvIVX(sstr);
2710         if (SvIsUV(sstr))
2711             SvIsUV_on(dstr);
2712     }
2713     else {
2714         if (dtype == SVt_PVGV) {
2715             if (ckWARN(WARN_UNSAFE))
2716                 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2717         }
2718         else
2719             (void)SvOK_off(dstr);
2720     }
2721     SvTAINT(dstr);
2722 }
2723
2724 void
2725 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2726 {
2727     sv_setsv(dstr,sstr);
2728     SvSETMAGIC(dstr);
2729 }
2730
2731 void
2732 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2733 {
2734     register char *dptr;
2735     assert(len >= 0);  /* STRLEN is probably unsigned, so this may
2736                           elicit a warning, but it won't hurt. */
2737     SV_CHECK_THINKFIRST(sv);
2738     if (!ptr) {
2739         (void)SvOK_off(sv);
2740         return;
2741     }
2742     (void)SvUPGRADE(sv, SVt_PV);
2743
2744     SvGROW(sv, len + 1);
2745     dptr = SvPVX(sv);
2746     Move(ptr,dptr,len,char);
2747     dptr[len] = '\0';
2748     SvCUR_set(sv, len);
2749     (void)SvPOK_only(sv);               /* validate pointer */
2750     SvTAINT(sv);
2751 }
2752
2753 void
2754 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2755 {
2756     sv_setpvn(sv,ptr,len);
2757     SvSETMAGIC(sv);
2758 }
2759
2760 void
2761 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2762 {
2763     register STRLEN len;
2764
2765     SV_CHECK_THINKFIRST(sv);
2766     if (!ptr) {
2767         (void)SvOK_off(sv);
2768         return;
2769     }
2770     len = strlen(ptr);
2771     (void)SvUPGRADE(sv, SVt_PV);
2772
2773     SvGROW(sv, len + 1);
2774     Move(ptr,SvPVX(sv),len+1,char);
2775     SvCUR_set(sv, len);
2776     (void)SvPOK_only(sv);               /* validate pointer */
2777     SvTAINT(sv);
2778 }
2779
2780 void
2781 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2782 {
2783     sv_setpv(sv,ptr);
2784     SvSETMAGIC(sv);
2785 }
2786
2787 void
2788 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2789 {
2790     SV_CHECK_THINKFIRST(sv);
2791     (void)SvUPGRADE(sv, SVt_PV);
2792     if (!ptr) {
2793         (void)SvOK_off(sv);
2794         return;
2795     }
2796     (void)SvOOK_off(sv);
2797     if (SvPVX(sv) && SvLEN(sv))
2798         Safefree(SvPVX(sv));
2799     Renew(ptr, len+1, char);
2800     SvPVX(sv) = ptr;
2801     SvCUR_set(sv, len);
2802     SvLEN_set(sv, len+1);
2803     *SvEND(sv) = '\0';
2804     (void)SvPOK_only(sv);               /* validate pointer */
2805     SvTAINT(sv);
2806 }
2807
2808 void
2809 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2810 {
2811     sv_usepvn(sv,ptr,len);
2812     SvSETMAGIC(sv);
2813 }
2814
2815 void
2816 Perl_sv_force_normal(pTHX_ register SV *sv)
2817 {
2818     if (SvREADONLY(sv)) {
2819         dTHR;
2820         if (PL_curcop != &PL_compiling)
2821             Perl_croak(aTHX_ PL_no_modify);
2822     }
2823     if (SvROK(sv))
2824         sv_unref(sv);
2825     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2826         sv_unglob(sv);
2827 }
2828
2829 void
2830 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2831
2832
2833 {
2834     register STRLEN delta;
2835
2836     if (!ptr || !SvPOKp(sv))
2837         return;
2838     SV_CHECK_THINKFIRST(sv);
2839     if (SvTYPE(sv) < SVt_PVIV)
2840         sv_upgrade(sv,SVt_PVIV);
2841
2842     if (!SvOOK(sv)) {
2843         if (!SvLEN(sv)) { /* make copy of shared string */
2844             char *pvx = SvPVX(sv);
2845             STRLEN len = SvCUR(sv);
2846             SvGROW(sv, len + 1);
2847             Move(pvx,SvPVX(sv),len,char);
2848             *SvEND(sv) = '\0';
2849         }
2850         SvIVX(sv) = 0;
2851         SvFLAGS(sv) |= SVf_OOK;
2852     }
2853     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2854     delta = ptr - SvPVX(sv);
2855     SvLEN(sv) -= delta;
2856     SvCUR(sv) -= delta;
2857     SvPVX(sv) += delta;
2858     SvIVX(sv) += delta;
2859 }
2860
2861 void
2862 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2863 {
2864     STRLEN tlen;
2865     char *junk;
2866
2867     junk = SvPV_force(sv, tlen);
2868     SvGROW(sv, tlen + len + 1);
2869     if (ptr == junk)
2870         ptr = SvPVX(sv);
2871     Move(ptr,SvPVX(sv)+tlen,len,char);
2872     SvCUR(sv) += len;
2873     *SvEND(sv) = '\0';
2874     (void)SvPOK_only(sv);               /* validate pointer */
2875     SvTAINT(sv);
2876 }
2877
2878 void
2879 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2880 {
2881     sv_catpvn(sv,ptr,len);
2882     SvSETMAGIC(sv);
2883 }
2884
2885 void
2886 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2887 {
2888     char *s;
2889     STRLEN len;
2890     if (!sstr)
2891         return;
2892     if (s = SvPV(sstr, len))
2893         sv_catpvn(dstr,s,len);
2894 }
2895
2896 void
2897 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2898 {
2899     sv_catsv(dstr,sstr);
2900     SvSETMAGIC(dstr);
2901 }
2902
2903 void
2904 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2905 {
2906     register STRLEN len;
2907     STRLEN tlen;
2908     char *junk;
2909
2910     if (!ptr)
2911         return;
2912     junk = SvPV_force(sv, tlen);
2913     len = strlen(ptr);
2914     SvGROW(sv, tlen + len + 1);
2915     if (ptr == junk)
2916         ptr = SvPVX(sv);
2917     Move(ptr,SvPVX(sv)+tlen,len+1,char);
2918     SvCUR(sv) += len;
2919     (void)SvPOK_only(sv);               /* validate pointer */
2920     SvTAINT(sv);
2921 }
2922
2923 void
2924 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2925 {
2926     sv_catpv(sv,ptr);
2927     SvSETMAGIC(sv);
2928 }
2929
2930 SV *
2931 Perl_newSV(pTHX_ STRLEN len)
2932 {
2933     register SV *sv;
2934
2935     new_SV(sv);
2936     if (len) {
2937         sv_upgrade(sv, SVt_PV);
2938         SvGROW(sv, len + 1);
2939     }
2940     return sv;
2941 }
2942
2943 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2944
2945 void
2946 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2947 {
2948     MAGIC* mg;
2949
2950     if (SvREADONLY(sv)) {
2951         dTHR;
2952         if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2953             Perl_croak(aTHX_ PL_no_modify);
2954     }
2955     if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2956         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2957             if (how == 't')
2958                 mg->mg_len |= 1;
2959             return;
2960         }
2961     }
2962     else {
2963         (void)SvUPGRADE(sv, SVt_PVMG);
2964     }
2965     Newz(702,mg, 1, MAGIC);
2966     mg->mg_moremagic = SvMAGIC(sv);
2967
2968     SvMAGIC(sv) = mg;
2969     if (!obj || obj == sv || how == '#' || how == 'r')
2970         mg->mg_obj = obj;
2971     else {
2972         dTHR;
2973         mg->mg_obj = SvREFCNT_inc(obj);
2974         mg->mg_flags |= MGf_REFCOUNTED;
2975     }
2976     mg->mg_type = how;
2977     mg->mg_len = namlen;
2978     if (name)
2979         if (namlen >= 0)
2980             mg->mg_ptr = savepvn(name, namlen);
2981         else if (namlen == HEf_SVKEY)
2982             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2983
2984     switch (how) {
2985     case 0:
2986         mg->mg_virtual = &PL_vtbl_sv;
2987         break;
2988     case 'A':
2989         mg->mg_virtual = &PL_vtbl_amagic;
2990         break;
2991     case 'a':
2992         mg->mg_virtual = &PL_vtbl_amagicelem;
2993         break;
2994     case 'c':
2995         mg->mg_virtual = 0;
2996         break;
2997     case 'B':
2998         mg->mg_virtual = &PL_vtbl_bm;
2999         break;
3000     case 'D':
3001         mg->mg_virtual = &PL_vtbl_regdata;
3002         break;
3003     case 'd':
3004         mg->mg_virtual = &PL_vtbl_regdatum;
3005         break;
3006     case 'E':
3007         mg->mg_virtual = &PL_vtbl_env;
3008         break;
3009     case 'f':
3010         mg->mg_virtual = &PL_vtbl_fm;
3011         break;
3012     case 'e':
3013         mg->mg_virtual = &PL_vtbl_envelem;
3014         break;
3015     case 'g':
3016         mg->mg_virtual = &PL_vtbl_mglob;
3017         break;
3018     case 'I':
3019         mg->mg_virtual = &PL_vtbl_isa;
3020         break;
3021     case 'i':
3022         mg->mg_virtual = &PL_vtbl_isaelem;
3023         break;
3024     case 'k':
3025         mg->mg_virtual = &PL_vtbl_nkeys;
3026         break;
3027     case 'L':
3028         SvRMAGICAL_on(sv);
3029         mg->mg_virtual = 0;
3030         break;
3031     case 'l':
3032         mg->mg_virtual = &PL_vtbl_dbline;
3033         break;
3034 #ifdef USE_THREADS
3035     case 'm':
3036         mg->mg_virtual = &PL_vtbl_mutex;
3037         break;
3038 #endif /* USE_THREADS */
3039 #ifdef USE_LOCALE_COLLATE
3040     case 'o':
3041         mg->mg_virtual = &PL_vtbl_collxfrm;
3042         break;
3043 #endif /* USE_LOCALE_COLLATE */
3044     case 'P':
3045         mg->mg_virtual = &PL_vtbl_pack;
3046         break;
3047     case 'p':
3048     case 'q':
3049         mg->mg_virtual = &PL_vtbl_packelem;
3050         break;
3051     case 'r':
3052         mg->mg_virtual = &PL_vtbl_regexp;
3053         break;
3054     case 'S':
3055         mg->mg_virtual = &PL_vtbl_sig;
3056         break;
3057     case 's':
3058         mg->mg_virtual = &PL_vtbl_sigelem;
3059         break;
3060     case 't':
3061         mg->mg_virtual = &PL_vtbl_taint;
3062         mg->mg_len = 1;
3063         break;
3064     case 'U':
3065         mg->mg_virtual = &PL_vtbl_uvar;
3066         break;
3067     case 'v':
3068         mg->mg_virtual = &PL_vtbl_vec;
3069         break;
3070     case 'x':
3071         mg->mg_virtual = &PL_vtbl_substr;
3072         break;
3073     case 'y':
3074         mg->mg_virtual = &PL_vtbl_defelem;
3075         break;
3076     case '*':
3077         mg->mg_virtual = &PL_vtbl_glob;
3078         break;
3079     case '#':
3080         mg->mg_virtual = &PL_vtbl_arylen;
3081         break;
3082     case '.':
3083         mg->mg_virtual = &PL_vtbl_pos;
3084         break;
3085     case '<':
3086         mg->mg_virtual = &PL_vtbl_backref;
3087         break;
3088     case '~':   /* Reserved for use by extensions not perl internals.   */
3089         /* Useful for attaching extension internal data to perl vars.   */
3090         /* Note that multiple extensions may clash if magical scalars   */
3091         /* etc holding private data from one are passed to another.     */
3092         SvRMAGICAL_on(sv);
3093         break;
3094     default:
3095         Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3096     }
3097     mg_magical(sv);
3098     if (SvGMAGICAL(sv))
3099         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3100 }
3101
3102 int
3103 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3104 {
3105     MAGIC* mg;
3106     MAGIC** mgp;
3107     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3108         return 0;
3109     mgp = &SvMAGIC(sv);
3110     for (mg = *mgp; mg; mg = *mgp) {
3111         if (mg->mg_type == type) {
3112             MGVTBL* vtbl = mg->mg_virtual;
3113             *mgp = mg->mg_moremagic;
3114             if (vtbl && vtbl->svt_free)
3115                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3116             if (mg->mg_ptr && mg->mg_type != 'g')
3117                 if (mg->mg_len >= 0)
3118                     Safefree(mg->mg_ptr);
3119                 else if (mg->mg_len == HEf_SVKEY)
3120                     SvREFCNT_dec((SV*)mg->mg_ptr);
3121             if (mg->mg_flags & MGf_REFCOUNTED)
3122                 SvREFCNT_dec(mg->mg_obj);
3123             Safefree(mg);
3124         }
3125         else
3126             mgp = &mg->mg_moremagic;
3127     }
3128     if (!SvMAGIC(sv)) {
3129         SvMAGICAL_off(sv);
3130         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3131     }
3132
3133     return 0;
3134 }
3135
3136 SV *
3137 Perl_sv_rvweaken(pTHX_ SV *sv)
3138 {
3139     SV *tsv;
3140     if (!SvOK(sv))  /* let undefs pass */
3141         return sv;
3142     if (!SvROK(sv))
3143         Perl_croak(aTHX_ "Can't weaken a nonreference");
3144     else if (SvWEAKREF(sv)) {
3145         dTHR;
3146         if (ckWARN(WARN_MISC))
3147             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3148         return sv;
3149     }
3150     tsv = SvRV(sv);
3151     sv_add_backref(tsv, sv);
3152     SvWEAKREF_on(sv);
3153     SvREFCNT_dec(tsv);
3154     return sv;
3155 }
3156
3157 STATIC void
3158 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3159 {
3160     AV *av;
3161     MAGIC *mg;
3162     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3163         av = (AV*)mg->mg_obj;
3164     else {
3165         av = newAV();
3166         sv_magic(tsv, (SV*)av, '<', NULL, 0);
3167         SvREFCNT_dec(av);           /* for sv_magic */
3168     }
3169     av_push(av,sv);
3170 }
3171
3172 STATIC void
3173 S_sv_del_backref(pTHX_ SV *sv)
3174 {
3175     AV *av;
3176     SV **svp;
3177     I32 i;
3178     SV *tsv = SvRV(sv);
3179     MAGIC *mg;
3180     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3181         Perl_croak(aTHX_ "panic: del_backref");
3182     av = (AV *)mg->mg_obj;
3183     svp = AvARRAY(av);
3184     i = AvFILLp(av);
3185     while (i >= 0) {
3186         if (svp[i] == sv) {
3187             svp[i] = &PL_sv_undef; /* XXX */
3188         }
3189         i--;
3190     }
3191 }
3192
3193 void
3194 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3195 {
3196     register char *big;
3197     register char *mid;
3198     register char *midend;
3199     register char *bigend;
3200     register I32 i;
3201     STRLEN curlen;
3202
3203
3204     if (!bigstr)
3205         Perl_croak(aTHX_ "Can't modify non-existent substring");
3206     SvPV_force(bigstr, curlen);
3207     if (offset + len > curlen) {
3208         SvGROW(bigstr, offset+len+1);
3209         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3210         SvCUR_set(bigstr, offset+len);
3211     }
3212
3213     SvTAINT(bigstr);
3214     i = littlelen - len;
3215     if (i > 0) {                        /* string might grow */
3216         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3217         mid = big + offset + len;
3218         midend = bigend = big + SvCUR(bigstr);
3219         bigend += i;
3220         *bigend = '\0';
3221         while (midend > mid)            /* shove everything down */
3222             *--bigend = *--midend;
3223         Move(little,big+offset,littlelen,char);
3224         SvCUR(bigstr) += i;
3225         SvSETMAGIC(bigstr);
3226         return;
3227     }
3228     else if (i == 0) {
3229         Move(little,SvPVX(bigstr)+offset,len,char);
3230         SvSETMAGIC(bigstr);
3231         return;
3232     }
3233
3234     big = SvPVX(bigstr);
3235     mid = big + offset;
3236     midend = mid + len;
3237     bigend = big + SvCUR(bigstr);
3238
3239     if (midend > bigend)
3240         Perl_croak(aTHX_ "panic: sv_insert");
3241
3242     if (mid - big > bigend - midend) {  /* faster to shorten from end */
3243         if (littlelen) {
3244             Move(little, mid, littlelen,char);
3245             mid += littlelen;
3246         }
3247         i = bigend - midend;
3248         if (i > 0) {
3249             Move(midend, mid, i,char);
3250             mid += i;
3251         }
3252         *mid = '\0';
3253         SvCUR_set(bigstr, mid - big);
3254     }
3255     /*SUPPRESS 560*/
3256     else if (i = mid - big) {   /* faster from front */
3257         midend -= littlelen;
3258         mid = midend;
3259         sv_chop(bigstr,midend-i);
3260         big += i;
3261         while (i--)
3262             *--midend = *--big;
3263         if (littlelen)
3264             Move(little, mid, littlelen,char);
3265     }
3266     else if (littlelen) {
3267         midend -= littlelen;
3268         sv_chop(bigstr,midend);
3269         Move(little,midend,littlelen,char);
3270     }
3271     else {
3272         sv_chop(bigstr,midend);
3273     }
3274     SvSETMAGIC(bigstr);
3275 }
3276
3277 /* make sv point to what nstr did */
3278
3279 void
3280 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3281 {
3282     dTHR;
3283     U32 refcnt = SvREFCNT(sv);
3284     SV_CHECK_THINKFIRST(sv);
3285     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3286         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3287     if (SvMAGICAL(sv)) {
3288         if (SvMAGICAL(nsv))
3289             mg_free(nsv);
3290         else
3291             sv_upgrade(nsv, SVt_PVMG);
3292         SvMAGIC(nsv) = SvMAGIC(sv);
3293         SvFLAGS(nsv) |= SvMAGICAL(sv);
3294         SvMAGICAL_off(sv);
3295         SvMAGIC(sv) = 0;
3296     }
3297     SvREFCNT(sv) = 0;
3298     sv_clear(sv);
3299     assert(!SvREFCNT(sv));
3300     StructCopy(nsv,sv,SV);
3301     SvREFCNT(sv) = refcnt;
3302     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
3303     del_SV(nsv);
3304 }
3305
3306 void
3307 Perl_sv_clear(pTHX_ register SV *sv)
3308 {
3309     HV* stash;
3310     assert(sv);
3311     assert(SvREFCNT(sv) == 0);
3312
3313     if (SvOBJECT(sv)) {
3314         dTHR;
3315         if (PL_defstash) {              /* Still have a symbol table? */
3316             djSP;
3317             GV* destructor;
3318             SV tmpref;
3319
3320             Zero(&tmpref, 1, SV);
3321             sv_upgrade(&tmpref, SVt_RV);
3322             SvROK_on(&tmpref);
3323             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
3324             SvREFCNT(&tmpref) = 1;
3325
3326             do {
3327                 stash = SvSTASH(sv);
3328                 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3329                 if (destructor) {
3330                     ENTER;
3331                     PUSHSTACKi(PERLSI_DESTROY);
3332                     SvRV(&tmpref) = SvREFCNT_inc(sv);
3333                     EXTEND(SP, 2);
3334                     PUSHMARK(SP);
3335                     PUSHs(&tmpref);
3336                     PUTBACK;
3337                     call_sv((SV*)GvCV(destructor),
3338                             G_DISCARD|G_EVAL|G_KEEPERR);
3339                     SvREFCNT(sv)--;
3340                     POPSTACK;
3341                     SPAGAIN;
3342                     LEAVE;
3343                 }
3344             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3345
3346             del_XRV(SvANY(&tmpref));
3347
3348             if (SvREFCNT(sv)) {
3349                 if (PL_in_clean_objs)
3350                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3351                           HvNAME(stash));
3352                 /* DESTROY gave object new lease on life */
3353                 return;
3354             }
3355         }
3356
3357         if (SvOBJECT(sv)) {
3358             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
3359             SvOBJECT_off(sv);   /* Curse the object. */
3360             if (SvTYPE(sv) != SVt_PVIO)
3361                 --PL_sv_objcount;       /* XXX Might want something more general */
3362         }
3363     }
3364     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3365         mg_free(sv);
3366     stash = NULL;
3367     switch (SvTYPE(sv)) {
3368     case SVt_PVIO:
3369         if (IoIFP(sv) &&
3370             IoIFP(sv) != PerlIO_stdin() &&
3371             IoIFP(sv) != PerlIO_stdout() &&
3372             IoIFP(sv) != PerlIO_stderr())
3373         {
3374             io_close((IO*)sv, FALSE);
3375         }
3376         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3377             PerlDir_close(IoDIRP(sv));
3378         IoDIRP(sv) = (DIR*)NULL;
3379         Safefree(IoTOP_NAME(sv));
3380         Safefree(IoFMT_NAME(sv));
3381         Safefree(IoBOTTOM_NAME(sv));
3382         /* FALL THROUGH */
3383     case SVt_PVBM:
3384         goto freescalar;
3385     case SVt_PVCV:
3386     case SVt_PVFM:
3387         cv_undef((CV*)sv);
3388         goto freescalar;
3389     case SVt_PVHV:
3390         hv_undef((HV*)sv);
3391         break;
3392     case SVt_PVAV:
3393         av_undef((AV*)sv);
3394         break;
3395     case SVt_PVLV:
3396         SvREFCNT_dec(LvTARG(sv));
3397         goto freescalar;
3398     case SVt_PVGV:
3399         gp_free((GV*)sv);
3400         Safefree(GvNAME(sv));
3401         /* cannot decrease stash refcount yet, as we might recursively delete
3402            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3403            of stash until current sv is completely gone.
3404            -- JohnPC, 27 Mar 1998 */
3405         stash = GvSTASH(sv);
3406         /* FALL THROUGH */
3407     case SVt_PVMG:
3408     case SVt_PVNV:
3409     case SVt_PVIV:
3410       freescalar:
3411         (void)SvOOK_off(sv);
3412         /* FALL THROUGH */
3413     case SVt_PV:
3414     case SVt_RV:
3415         if (SvROK(sv)) {
3416             if (SvWEAKREF(sv))
3417                 sv_del_backref(sv);
3418             else
3419                 SvREFCNT_dec(SvRV(sv));
3420         }
3421         else if (SvPVX(sv) && SvLEN(sv))
3422             Safefree(SvPVX(sv));
3423         break;
3424 /*
3425     case SVt_NV:
3426     case SVt_IV:
3427     case SVt_NULL:
3428         break;
3429 */
3430     }
3431
3432     switch (SvTYPE(sv)) {
3433     case SVt_NULL:
3434         break;
3435     case SVt_IV:
3436         del_XIV(SvANY(sv));
3437         break;
3438     case SVt_NV:
3439         del_XNV(SvANY(sv));
3440         break;
3441     case SVt_RV:
3442         del_XRV(SvANY(sv));
3443         break;
3444     case SVt_PV:
3445         del_XPV(SvANY(sv));
3446         break;
3447     case SVt_PVIV:
3448         del_XPVIV(SvANY(sv));
3449         break;
3450     case SVt_PVNV:
3451         del_XPVNV(SvANY(sv));
3452         break;
3453     case SVt_PVMG:
3454         del_XPVMG(SvANY(sv));
3455         break;
3456     case SVt_PVLV:
3457         del_XPVLV(SvANY(sv));
3458         break;
3459     case SVt_PVAV:
3460         del_XPVAV(SvANY(sv));
3461         break;
3462     case SVt_PVHV:
3463         del_XPVHV(SvANY(sv));
3464         break;
3465     case SVt_PVCV:
3466         del_XPVCV(SvANY(sv));
3467         break;
3468     case SVt_PVGV:
3469         del_XPVGV(SvANY(sv));
3470         /* code duplication for increased performance. */
3471         SvFLAGS(sv) &= SVf_BREAK;
3472         SvFLAGS(sv) |= SVTYPEMASK;
3473         /* decrease refcount of the stash that owns this GV, if any */
3474         if (stash)
3475             SvREFCNT_dec(stash);
3476         return; /* not break, SvFLAGS reset already happened */
3477     case SVt_PVBM:
3478         del_XPVBM(SvANY(sv));
3479         break;
3480     case SVt_PVFM:
3481         del_XPVFM(SvANY(sv));
3482         break;
3483     case SVt_PVIO:
3484         del_XPVIO(SvANY(sv));
3485         break;
3486     }
3487     SvFLAGS(sv) &= SVf_BREAK;
3488     SvFLAGS(sv) |= SVTYPEMASK;
3489 }
3490
3491 SV *
3492 Perl_sv_newref(pTHX_ SV *sv)
3493 {
3494     if (sv)
3495         ATOMIC_INC(SvREFCNT(sv));
3496     return sv;
3497 }
3498
3499 void
3500 Perl_sv_free(pTHX_ SV *sv)
3501 {
3502     dTHR;
3503     int refcount_is_zero;
3504
3505     if (!sv)
3506         return;
3507     if (SvREFCNT(sv) == 0) {
3508         if (SvFLAGS(sv) & SVf_BREAK)
3509             return;
3510         if (PL_in_clean_all) /* All is fair */
3511             return;
3512         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3513             /* make sure SvREFCNT(sv)==0 happens very seldom */
3514             SvREFCNT(sv) = (~(U32)0)/2;
3515             return;
3516         }
3517         if (ckWARN_d(WARN_INTERNAL))
3518             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3519         return;
3520     }
3521     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3522     if (!refcount_is_zero)
3523         return;
3524 #ifdef DEBUGGING
3525     if (SvTEMP(sv)) {
3526         if (ckWARN_d(WARN_DEBUGGING))
3527             Perl_warner(aTHX_ WARN_DEBUGGING,
3528                         "Attempt to free temp prematurely: SV 0x%"UVxf,
3529                         PTR2UV(sv));
3530         return;
3531     }
3532 #endif
3533     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3534         /* make sure SvREFCNT(sv)==0 happens very seldom */
3535         SvREFCNT(sv) = (~(U32)0)/2;
3536         return;
3537     }
3538     sv_clear(sv);
3539     if (! SvREFCNT(sv))
3540         del_SV(sv);
3541 }
3542
3543 STRLEN
3544 Perl_sv_len(pTHX_ register SV *sv)
3545 {
3546     char *junk;
3547     STRLEN len;
3548
3549     if (!sv)
3550         return 0;
3551
3552     if (SvGMAGICAL(sv))
3553         len = mg_length(sv);
3554     else
3555         junk = SvPV(sv, len);
3556     return len;
3557 }
3558
3559 STRLEN
3560 Perl_sv_len_utf8(pTHX_ register SV *sv)
3561 {
3562     U8 *s;
3563     U8 *send;
3564     STRLEN len;
3565
3566     if (!sv)
3567         return 0;
3568
3569 #ifdef NOTYET
3570     if (SvGMAGICAL(sv))
3571         len = mg_length(sv);
3572     else
3573 #endif
3574         s = (U8*)SvPV(sv, len);
3575     send = s + len;
3576     len = 0;
3577     while (s < send) {
3578         s += UTF8SKIP(s);
3579         len++;
3580     }
3581     return len;
3582 }
3583
3584 void
3585 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3586 {
3587     U8 *start;
3588     U8 *s;
3589     U8 *send;
3590     I32 uoffset = *offsetp;
3591     STRLEN len;
3592
3593     if (!sv)
3594         return;
3595
3596     start = s = (U8*)SvPV(sv, len);
3597     send = s + len;
3598     while (s < send && uoffset--)
3599         s += UTF8SKIP(s);
3600     if (s >= send)
3601         s = send;
3602     *offsetp = s - start;
3603     if (lenp) {
3604         I32 ulen = *lenp;
3605         start = s;
3606         while (s < send && ulen--)
3607             s += UTF8SKIP(s);
3608         if (s >= send)
3609             s = send;
3610         *lenp = s - start;
3611     }
3612     return;
3613 }
3614
3615 void
3616 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3617 {
3618     U8 *s;
3619     U8 *send;
3620     STRLEN len;
3621
3622     if (!sv)
3623         return;
3624
3625     s = (U8*)SvPV(sv, len);
3626     if (len < *offsetp)
3627         Perl_croak(aTHX_ "panic: bad byte offset");
3628     send = s + *offsetp;
3629     len = 0;
3630     while (s < send) {
3631         s += UTF8SKIP(s);
3632         ++len;
3633     }
3634     if (s != send) {
3635         dTHR;
3636         if (ckWARN_d(WARN_UTF8))
3637             Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3638         --len;
3639     }
3640     *offsetp = len;
3641     return;
3642 }
3643
3644 I32
3645 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3646 {
3647     char *pv1;
3648     STRLEN cur1;
3649     char *pv2;
3650     STRLEN cur2;
3651
3652     if (!str1) {
3653         pv1 = "";
3654         cur1 = 0;
3655     }
3656     else
3657         pv1 = SvPV(str1, cur1);
3658
3659     if (!str2)
3660         return !cur1;
3661     else
3662         pv2 = SvPV(str2, cur2);
3663
3664     if (cur1 != cur2)
3665         return 0;
3666
3667     return memEQ(pv1, pv2, cur1);
3668 }
3669
3670 I32
3671 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3672 {
3673     STRLEN cur1 = 0;
3674     char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3675     STRLEN cur2 = 0;
3676     char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3677     I32 retval;
3678
3679     if (!cur1)
3680         return cur2 ? -1 : 0;
3681
3682     if (!cur2)
3683         return 1;
3684
3685     retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3686
3687     if (retval)
3688         return retval < 0 ? -1 : 1;
3689
3690     if (cur1 == cur2)
3691         return 0;
3692     else
3693         return cur1 < cur2 ? -1 : 1;
3694 }
3695
3696 I32
3697 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3698 {
3699 #ifdef USE_LOCALE_COLLATE
3700
3701     char *pv1, *pv2;
3702     STRLEN len1, len2;
3703     I32 retval;
3704
3705     if (PL_collation_standard)
3706         goto raw_compare;
3707
3708     len1 = 0;
3709     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3710     len2 = 0;
3711     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3712
3713     if (!pv1 || !len1) {
3714         if (pv2 && len2)
3715             return -1;
3716         else
3717             goto raw_compare;
3718     }
3719     else {
3720         if (!pv2 || !len2)
3721             return 1;
3722     }
3723
3724     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3725
3726     if (retval)
3727         return retval < 0 ? -1 : 1;
3728
3729     /*
3730      * When the result of collation is equality, that doesn't mean
3731      * that there are no differences -- some locales exclude some
3732      * characters from consideration.  So to avoid false equalities,
3733      * we use the raw string as a tiebreaker.
3734      */
3735
3736   raw_compare:
3737     /* FALL THROUGH */
3738
3739 #endif /* USE_LOCALE_COLLATE */
3740
3741     return sv_cmp(sv1, sv2);
3742 }
3743
3744 #ifdef USE_LOCALE_COLLATE
3745 /*
3746  * Any scalar variable may carry an 'o' magic that contains the
3747  * scalar data of the variable transformed to such a format that
3748  * a normal memory comparison can be used to compare the data
3749  * according to the locale settings.
3750  */
3751 char *
3752 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3753 {
3754     MAGIC *mg;
3755
3756     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3757     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3758         char *s, *xf;
3759         STRLEN len, xlen;
3760
3761         if (mg)
3762             Safefree(mg->mg_ptr);
3763         s = SvPV(sv, len);
3764         if ((xf = mem_collxfrm(s, len, &xlen))) {
3765             if (SvREADONLY(sv)) {
3766                 SAVEFREEPV(xf);
3767                 *nxp = xlen;
3768                 return xf + sizeof(PL_collation_ix);
3769             }
3770             if (! mg) {
3771                 sv_magic(sv, 0, 'o', 0, 0);
3772                 mg = mg_find(sv, 'o');
3773                 assert(mg);
3774             }
3775             mg->mg_ptr = xf;
3776             mg->mg_len = xlen;
3777         }
3778         else {
3779             if (mg) {
3780                 mg->mg_ptr = NULL;
3781                 mg->mg_len = -1;
3782             }
3783         }
3784     }
3785     if (mg && mg->mg_ptr) {
3786         *nxp = mg->mg_len;
3787         return mg->mg_ptr + sizeof(PL_collation_ix);
3788     }
3789     else {
3790         *nxp = 0;
3791         return NULL;
3792     }
3793 }
3794
3795 #endif /* USE_LOCALE_COLLATE */
3796
3797 char *
3798 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3799 {
3800     dTHR;
3801     char *rsptr;
3802     STRLEN rslen;
3803     register STDCHAR rslast;
3804     register STDCHAR *bp;
3805     register I32 cnt;
3806     I32 i;
3807
3808     SV_CHECK_THINKFIRST(sv);
3809     (void)SvUPGRADE(sv, SVt_PV);
3810
3811     SvSCREAM_off(sv);
3812
3813     if (RsSNARF(PL_rs)) {
3814         rsptr = NULL;
3815         rslen = 0;
3816     }
3817     else if (RsRECORD(PL_rs)) {
3818       I32 recsize, bytesread;
3819       char *buffer;
3820
3821       /* Grab the size of the record we're getting */
3822       recsize = SvIV(SvRV(PL_rs));
3823       (void)SvPOK_only(sv);    /* Validate pointer */
3824       buffer = SvGROW(sv, recsize + 1);
3825       /* Go yank in */
3826 #ifdef VMS
3827       /* VMS wants read instead of fread, because fread doesn't respect */
3828       /* RMS record boundaries. This is not necessarily a good thing to be */
3829       /* doing, but we've got no other real choice */
3830       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3831 #else
3832       bytesread = PerlIO_read(fp, buffer, recsize);
3833 #endif
3834       SvCUR_set(sv, bytesread);
3835       buffer[bytesread] = '\0';
3836       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3837     }
3838     else if (RsPARA(PL_rs)) {
3839         rsptr = "\n\n";
3840         rslen = 2;
3841     }
3842     else
3843         rsptr = SvPV(PL_rs, rslen);
3844     rslast = rslen ? rsptr[rslen - 1] : '\0';
3845
3846     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
3847         do {                    /* to make sure file boundaries work right */
3848             if (PerlIO_eof(fp))
3849                 return 0;
3850             i = PerlIO_getc(fp);
3851             if (i != '\n') {
3852                 if (i == -1)
3853                     return 0;
3854                 PerlIO_ungetc(fp,i);
3855                 break;
3856             }
3857         } while (i != EOF);
3858     }
3859
3860     /* See if we know enough about I/O mechanism to cheat it ! */
3861
3862     /* This used to be #ifdef test - it is made run-time test for ease
3863        of abstracting out stdio interface. One call should be cheap
3864        enough here - and may even be a macro allowing compile
3865        time optimization.
3866      */
3867
3868     if (PerlIO_fast_gets(fp)) {
3869
3870     /*
3871      * We're going to steal some values from the stdio struct
3872      * and put EVERYTHING in the innermost loop into registers.
3873      */
3874     register STDCHAR *ptr;
3875     STRLEN bpx;
3876     I32 shortbuffered;
3877
3878 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3879     /* An ungetc()d char is handled separately from the regular
3880      * buffer, so we getc() it back out and stuff it in the buffer.
3881      */
3882     i = PerlIO_getc(fp);
3883     if (i == EOF) return 0;
3884     *(--((*fp)->_ptr)) = (unsigned char) i;
3885     (*fp)->_cnt++;
3886 #endif
3887
3888     /* Here is some breathtakingly efficient cheating */
3889
3890     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
3891     (void)SvPOK_only(sv);               /* validate pointer */
3892     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3893         if (cnt > 80 && SvLEN(sv) > append) {
3894             shortbuffered = cnt - SvLEN(sv) + append + 1;
3895             cnt -= shortbuffered;
3896         }
3897         else {
3898             shortbuffered = 0;
3899             /* remember that cnt can be negative */
3900             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3901         }
3902     }
3903     else
3904         shortbuffered = 0;
3905     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
3906     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3907     DEBUG_P(PerlIO_printf(Perl_debug_log,
3908         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3909     DEBUG_P(PerlIO_printf(Perl_debug_log,
3910         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3911                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3912                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3913     for (;;) {
3914       screamer:
3915         if (cnt > 0) {
3916             if (rslen) {
3917                 while (cnt > 0) {                    /* this     |  eat */
3918                     cnt--;
3919                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
3920                         goto thats_all_folks;        /* screams  |  sed :-) */
3921                 }
3922             }
3923             else {
3924                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
3925                 bp += cnt;                           /* screams  |  dust */
3926                 ptr += cnt;                          /* louder   |  sed :-) */
3927                 cnt = 0;
3928             }
3929         }
3930
3931         if (shortbuffered) {            /* oh well, must extend */
3932             cnt = shortbuffered;
3933             shortbuffered = 0;
3934             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3935             SvCUR_set(sv, bpx);
3936             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3937             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3938             continue;
3939         }
3940
3941         DEBUG_P(PerlIO_printf(Perl_debug_log,
3942                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3943                               PTR2UV(ptr),(long)cnt));
3944         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3945         DEBUG_P(PerlIO_printf(Perl_debug_log,
3946             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3947             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3948             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3949         /* This used to call 'filbuf' in stdio form, but as that behaves like
3950            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3951            another abstraction.  */
3952         i   = PerlIO_getc(fp);          /* get more characters */
3953         DEBUG_P(PerlIO_printf(Perl_debug_log,
3954             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3955             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3956             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3957         cnt = PerlIO_get_cnt(fp);
3958         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
3959         DEBUG_P(PerlIO_printf(Perl_debug_log,
3960             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3961
3962         if (i == EOF)                   /* all done for ever? */
3963             goto thats_really_all_folks;
3964
3965         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3966         SvCUR_set(sv, bpx);
3967         SvGROW(sv, bpx + cnt + 2);
3968         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3969
3970         *bp++ = i;                      /* store character from PerlIO_getc */
3971
3972         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
3973             goto thats_all_folks;
3974     }
3975
3976 thats_all_folks:
3977     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3978           memNE((char*)bp - rslen, rsptr, rslen))
3979         goto screamer;                          /* go back to the fray */
3980 thats_really_all_folks:
3981     if (shortbuffered)
3982         cnt += shortbuffered;
3983         DEBUG_P(PerlIO_printf(Perl_debug_log,
3984             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3985     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
3986     DEBUG_P(PerlIO_printf(Perl_debug_log,
3987         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3988         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3989         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3990     *bp = '\0';
3991     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
3992     DEBUG_P(PerlIO_printf(Perl_debug_log,
3993         "Screamer: done, len=%ld, string=|%.*s|\n",
3994         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3995     }
3996    else
3997     {
3998 #ifndef EPOC
3999        /*The big, slow, and stupid way */
4000         STDCHAR buf[8192];
4001 #else
4002         /* Need to work around EPOC SDK features          */
4003         /* On WINS: MS VC5 generates calls to _chkstk,    */
4004         /* if a `large' stack frame is allocated          */
4005         /* gcc on MARM does not generate calls like these */
4006         STDCHAR buf[1024];
4007 #endif
4008
4009 screamer2:
4010         if (rslen) {
4011             register STDCHAR *bpe = buf + sizeof(buf);
4012             bp = buf;
4013             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4014                 ; /* keep reading */
4015             cnt = bp - buf;
4016         }
4017         else {
4018             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4019             /* Accomodate broken VAXC compiler, which applies U8 cast to
4020              * both args of ?: operator, causing EOF to change into 255
4021              */
4022             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4023         }
4024
4025         if (append)
4026             sv_catpvn(sv, (char *) buf, cnt);
4027         else
4028             sv_setpvn(sv, (char *) buf, cnt);
4029
4030         if (i != EOF &&                 /* joy */
4031             (!rslen ||
4032              SvCUR(sv) < rslen ||
4033              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4034         {
4035             append = -1;
4036             /*
4037              * If we're reading from a TTY and we get a short read,
4038              * indicating that the user hit his EOF character, we need
4039              * to notice it now, because if we try to read from the TTY
4040              * again, the EOF condition will disappear.
4041              *
4042              * The comparison of cnt to sizeof(buf) is an optimization
4043              * that prevents unnecessary calls to feof().
4044              *
4045              * - jik 9/25/96
4046              */
4047             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4048                 goto screamer2;
4049         }
4050     }
4051
4052     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4053         while (i != EOF) {      /* to make sure file boundaries work right */
4054             i = PerlIO_getc(fp);
4055             if (i != '\n') {
4056                 PerlIO_ungetc(fp,i);
4057                 break;
4058             }
4059         }
4060     }
4061
4062     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4063 }
4064
4065
4066 void
4067 Perl_sv_inc(pTHX_ register SV *sv)
4068 {
4069     register char *d;
4070     int flags;
4071
4072     if (!sv)
4073         return;
4074     if (SvGMAGICAL(sv))
4075         mg_get(sv);
4076     if (SvTHINKFIRST(sv)) {
4077         if (SvREADONLY(sv)) {
4078             dTHR;
4079             if (PL_curcop != &PL_compiling)
4080                 Perl_croak(aTHX_ PL_no_modify);
4081         }
4082         if (SvROK(sv)) {
4083             IV i;
4084             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4085                 return;
4086             i = PTR2IV(SvRV(sv));
4087             sv_unref(sv);
4088             sv_setiv(sv, i);
4089         }
4090     }
4091     flags = SvFLAGS(sv);
4092     if (flags & SVp_NOK) {
4093         (void)SvNOK_only(sv);
4094         SvNVX(sv) += 1.0;
4095         return;
4096     }
4097     if (flags & SVp_IOK) {
4098         if (SvIsUV(sv)) {
4099             if (SvUVX(sv) == UV_MAX)
4100                 sv_setnv(sv, (NV)UV_MAX + 1.0);
4101             else
4102                 (void)SvIOK_only_UV(sv);
4103                 ++SvUVX(sv);
4104         } else {
4105             if (SvIVX(sv) == IV_MAX)
4106                 sv_setnv(sv, (NV)IV_MAX + 1.0);
4107             else {
4108                 (void)SvIOK_only(sv);
4109                 ++SvIVX(sv);
4110             }
4111         }
4112         return;
4113     }
4114     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4115         if ((flags & SVTYPEMASK) < SVt_PVNV)
4116             sv_upgrade(sv, SVt_NV);
4117         SvNVX(sv) = 1.0;
4118         (void)SvNOK_only(sv);
4119         return;
4120     }
4121     d = SvPVX(sv);
4122     while (isALPHA(*d)) d++;
4123     while (isDIGIT(*d)) d++;
4124     if (*d) {
4125         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
4126         return;
4127     }
4128     d--;
4129     while (d >= SvPVX(sv)) {
4130         if (isDIGIT(*d)) {
4131             if (++*d <= '9')
4132                 return;
4133             *(d--) = '0';
4134         }
4135         else {
4136 #ifdef EBCDIC
4137             /* MKS: The original code here died if letters weren't consecutive.
4138              * at least it didn't have to worry about non-C locales.  The
4139              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4140              * arranged in order (although not consecutively) and that only
4141              * [A-Za-z] are accepted by isALPHA in the C locale.
4142              */
4143             if (*d != 'z' && *d != 'Z') {
4144                 do { ++*d; } while (!isALPHA(*d));
4145                 return;
4146             }
4147             *(d--) -= 'z' - 'a';
4148 #else
4149             ++*d;
4150             if (isALPHA(*d))
4151                 return;
4152             *(d--) -= 'z' - 'a' + 1;
4153 #endif
4154         }
4155     }
4156     /* oh,oh, the number grew */
4157     SvGROW(sv, SvCUR(sv) + 2);
4158     SvCUR(sv)++;
4159     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4160         *d = d[-1];
4161     if (isDIGIT(d[1]))
4162         *d = '1';
4163     else
4164         *d = d[1];
4165 }
4166
4167 void
4168 Perl_sv_dec(pTHX_ register SV *sv)
4169 {
4170     int flags;
4171
4172     if (!sv)
4173         return;
4174     if (SvGMAGICAL(sv))
4175         mg_get(sv);
4176     if (SvTHINKFIRST(sv)) {
4177         if (SvREADONLY(sv)) {
4178             dTHR;
4179             if (PL_curcop != &PL_compiling)
4180                 Perl_croak(aTHX_ PL_no_modify);
4181         }
4182         if (SvROK(sv)) {
4183             IV i;
4184             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4185                 return;
4186             i = PTR2IV(SvRV(sv));
4187             sv_unref(sv);
4188             sv_setiv(sv, i);
4189         }
4190     }
4191     flags = SvFLAGS(sv);
4192     if (flags & SVp_NOK) {
4193         SvNVX(sv) -= 1.0;
4194         (void)SvNOK_only(sv);
4195         return;
4196     }
4197     if (flags & SVp_IOK) {
4198         if (SvIsUV(sv)) {
4199             if (SvUVX(sv) == 0) {
4200                 (void)SvIOK_only(sv);
4201                 SvIVX(sv) = -1;
4202             }
4203             else {
4204                 (void)SvIOK_only_UV(sv);
4205                 --SvUVX(sv);
4206             }
4207         } else {
4208             if (SvIVX(sv) == IV_MIN)
4209                 sv_setnv(sv, (NV)IV_MIN - 1.0);
4210             else {
4211                 (void)SvIOK_only(sv);
4212                 --SvIVX(sv);
4213             }
4214         }
4215         return;
4216     }
4217     if (!(flags & SVp_POK)) {
4218         if ((flags & SVTYPEMASK) < SVt_PVNV)
4219             sv_upgrade(sv, SVt_NV);
4220         SvNVX(sv) = -1.0;
4221         (void)SvNOK_only(sv);
4222         return;
4223     }
4224     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4225 }
4226
4227 /* Make a string that will exist for the duration of the expression
4228  * evaluation.  Actually, it may have to last longer than that, but
4229  * hopefully we won't free it until it has been assigned to a
4230  * permanent location. */
4231
4232 SV *
4233 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4234 {
4235     dTHR;
4236     register SV *sv;
4237
4238     new_SV(sv);
4239     sv_setsv(sv,oldstr);
4240     EXTEND_MORTAL(1);
4241     PL_tmps_stack[++PL_tmps_ix] = sv;
4242     SvTEMP_on(sv);
4243     return sv;
4244 }
4245
4246 SV *
4247 Perl_sv_newmortal(pTHX)
4248 {
4249     dTHR;
4250     register SV *sv;
4251
4252     new_SV(sv);
4253     SvFLAGS(sv) = SVs_TEMP;
4254     EXTEND_MORTAL(1);
4255     PL_tmps_stack[++PL_tmps_ix] = sv;
4256     return sv;
4257 }
4258
4259 /* same thing without the copying */
4260
4261 SV *
4262 Perl_sv_2mortal(pTHX_ register SV *sv)
4263 {
4264     dTHR;
4265     if (!sv)
4266         return sv;
4267     if (SvREADONLY(sv) && SvIMMORTAL(sv))
4268         return sv;
4269     EXTEND_MORTAL(1);
4270     PL_tmps_stack[++PL_tmps_ix] = sv;
4271     SvTEMP_on(sv);
4272     return sv;
4273 }
4274
4275 SV *
4276 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4277 {
4278     register SV *sv;
4279
4280     new_SV(sv);
4281     if (!len)
4282         len = strlen(s);
4283     sv_setpvn(sv,s,len);
4284     return sv;
4285 }
4286
4287 SV *
4288 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4289 {
4290     register SV *sv;
4291
4292     new_SV(sv);
4293     sv_setpvn(sv,s,len);
4294     return sv;
4295 }
4296
4297 #if defined(PERL_IMPLICIT_CONTEXT)
4298 SV *
4299 Perl_newSVpvf_nocontext(const char* pat, ...)
4300 {
4301     dTHX;
4302     register SV *sv;
4303     va_list args;
4304     va_start(args, pat);
4305     sv = vnewSVpvf(pat, &args);
4306     va_end(args);
4307     return sv;
4308 }
4309 #endif
4310
4311 SV *
4312 Perl_newSVpvf(pTHX_ const char* pat, ...)
4313 {
4314     register SV *sv;
4315     va_list args;
4316     va_start(args, pat);
4317     sv = vnewSVpvf(pat, &args);
4318     va_end(args);
4319     return sv;
4320 }
4321
4322 SV *
4323 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4324 {
4325     register SV *sv;
4326     new_SV(sv);
4327     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4328     return sv;
4329 }
4330
4331 SV *
4332 Perl_newSVnv(pTHX_ NV n)
4333 {
4334     register SV *sv;
4335
4336     new_SV(sv);
4337     sv_setnv(sv,n);
4338     return sv;
4339 }
4340
4341 SV *
4342 Perl_newSViv(pTHX_ IV i)
4343 {
4344     register SV *sv;
4345
4346     new_SV(sv);
4347     sv_setiv(sv,i);
4348     return sv;
4349 }
4350
4351 SV *
4352 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4353 {
4354     dTHR;
4355     register SV *sv;
4356
4357     new_SV(sv);
4358     sv_upgrade(sv, SVt_RV);
4359     SvTEMP_off(tmpRef);
4360     SvRV(sv) = tmpRef;
4361     SvROK_on(sv);
4362     return sv;
4363 }
4364
4365 SV *
4366 Perl_newRV(pTHX_ SV *tmpRef)
4367 {
4368     return newRV_noinc(SvREFCNT_inc(tmpRef));
4369 }
4370
4371 /* make an exact duplicate of old */
4372
4373 SV *
4374 Perl_newSVsv(pTHX_ register SV *old)
4375 {
4376     dTHR;
4377     register SV *sv;
4378
4379     if (!old)
4380         return Nullsv;
4381     if (SvTYPE(old) == SVTYPEMASK) {
4382         if (ckWARN_d(WARN_INTERNAL))
4383             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4384         return Nullsv;
4385     }
4386     new_SV(sv);
4387     if (SvTEMP(old)) {
4388         SvTEMP_off(old);
4389         sv_setsv(sv,old);
4390         SvTEMP_on(old);
4391     }
4392     else
4393         sv_setsv(sv,old);
4394     return sv;
4395 }
4396
4397 void
4398 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4399 {
4400     register HE *entry;
4401     register GV *gv;
4402     register SV *sv;
4403     register I32 i;
4404     register PMOP *pm;
4405     register I32 max;
4406     char todo[PERL_UCHAR_MAX+1];
4407
4408     if (!stash)
4409         return;
4410
4411     if (!*s) {          /* reset ?? searches */
4412         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4413             pm->op_pmdynflags &= ~PMdf_USED;
4414         }
4415         return;
4416     }
4417
4418     /* reset variables */
4419
4420     if (!HvARRAY(stash))
4421         return;
4422
4423     Zero(todo, 256, char);
4424     while (*s) {
4425         i = (unsigned char)*s;
4426         if (s[1] == '-') {
4427             s += 2;
4428         }
4429         max = (unsigned char)*s++;
4430         for ( ; i <= max; i++) {
4431             todo[i] = 1;
4432         }
4433         for (i = 0; i <= (I32) HvMAX(stash); i++) {
4434             for (entry = HvARRAY(stash)[i];
4435                  entry;
4436                  entry = HeNEXT(entry))
4437             {
4438                 if (!todo[(U8)*HeKEY(entry)])
4439                     continue;
4440                 gv = (GV*)HeVAL(entry);
4441                 sv = GvSV(gv);
4442                 if (SvTHINKFIRST(sv)) {
4443                     if (!SvREADONLY(sv) && SvROK(sv))
4444                         sv_unref(sv);
4445                     continue;
4446                 }
4447                 (void)SvOK_off(sv);
4448                 if (SvTYPE(sv) >= SVt_PV) {
4449                     SvCUR_set(sv, 0);
4450                     if (SvPVX(sv) != Nullch)
4451                         *SvPVX(sv) = '\0';
4452                     SvTAINT(sv);
4453                 }
4454                 if (GvAV(gv)) {
4455                     av_clear(GvAV(gv));
4456                 }
4457                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4458                     hv_clear(GvHV(gv));
4459 #ifndef VMS  /* VMS has no environ array */
4460                     if (gv == PL_envgv)
4461                         environ[0] = Nullch;
4462 #endif
4463                 }
4464             }
4465         }
4466     }
4467 }
4468
4469 IO*
4470 Perl_sv_2io(pTHX_ SV *sv)
4471 {
4472     IO* io;
4473     GV* gv;
4474     STRLEN n_a;
4475
4476     switch (SvTYPE(sv)) {
4477     case SVt_PVIO:
4478         io = (IO*)sv;
4479         break;
4480     case SVt_PVGV:
4481         gv = (GV*)sv;
4482         io = GvIO(gv);
4483         if (!io)
4484             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4485         break;
4486     default:
4487         if (!SvOK(sv))
4488             Perl_croak(aTHX_ PL_no_usym, "filehandle");
4489         if (SvROK(sv))
4490             return sv_2io(SvRV(sv));
4491         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4492         if (gv)
4493             io = GvIO(gv);
4494         else
4495             io = 0;
4496         if (!io)
4497             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4498         break;
4499     }
4500     return io;
4501 }
4502
4503 CV *
4504 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4505 {
4506     GV *gv;
4507     CV *cv;
4508     STRLEN n_a;
4509
4510     if (!sv)
4511         return *gvp = Nullgv, Nullcv;
4512     switch (SvTYPE(sv)) {
4513     case SVt_PVCV:
4514         *st = CvSTASH(sv);
4515         *gvp = Nullgv;
4516         return (CV*)sv;
4517     case SVt_PVHV:
4518     case SVt_PVAV:
4519         *gvp = Nullgv;
4520         return Nullcv;
4521     case SVt_PVGV:
4522         gv = (GV*)sv;
4523         *gvp = gv;
4524         *st = GvESTASH(gv);
4525         goto fix_gv;
4526
4527     default:
4528         if (SvGMAGICAL(sv))
4529             mg_get(sv);
4530         if (SvROK(sv)) {
4531             dTHR;
4532             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
4533             tryAMAGICunDEREF(to_cv);
4534
4535             sv = SvRV(sv);
4536             if (SvTYPE(sv) == SVt_PVCV) {
4537                 cv = (CV*)sv;
4538                 *gvp = Nullgv;
4539                 *st = CvSTASH(cv);
4540                 return cv;
4541             }
4542             else if(isGV(sv))
4543                 gv = (GV*)sv;
4544             else
4545                 Perl_croak(aTHX_ "Not a subroutine reference");
4546         }
4547         else if (isGV(sv))
4548             gv = (GV*)sv;
4549         else
4550             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4551         *gvp = gv;
4552         if (!gv)
4553             return Nullcv;
4554         *st = GvESTASH(gv);
4555     fix_gv:
4556         if (lref && !GvCVu(gv)) {
4557             SV *tmpsv;
4558             ENTER;
4559             tmpsv = NEWSV(704,0);
4560             gv_efullname3(tmpsv, gv, Nullch);
4561             /* XXX this is probably not what they think they're getting.
4562              * It has the same effect as "sub name;", i.e. just a forward
4563              * declaration! */
4564             newSUB(start_subparse(FALSE, 0),
4565                    newSVOP(OP_CONST, 0, tmpsv),
4566                    Nullop,
4567                    Nullop);
4568             LEAVE;
4569             if (!GvCVu(gv))
4570                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4571         }
4572         return GvCVu(gv);
4573     }
4574 }
4575
4576 I32
4577 Perl_sv_true(pTHX_ register SV *sv)
4578 {
4579     dTHR;
4580     if (!sv)
4581         return 0;
4582     if (SvPOK(sv)) {
4583         register XPV* tXpv;
4584         if ((tXpv = (XPV*)SvANY(sv)) &&
4585                 (tXpv->xpv_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, "%"SVf, 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 && GvGP(sv)) {
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