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