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 (SvUTF8(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
5642     /* no matter what, this is a string now */
5643     (void)SvPV_force(sv, origlen);
5644
5645     /* special-case "", "%s", and "%_" */
5646     if (patlen == 0)
5647         return;
5648     if (patlen == 2 && pat[0] == '%') {
5649         switch (pat[1]) {
5650         case 's':
5651             if (args) {
5652                 char *s = va_arg(*args, char*);
5653                 sv_catpv(sv, s ? s : nullstr);
5654             }
5655             else if (svix < svmax)
5656                 sv_catsv(sv, *svargs);
5657             return;
5658         case '_':
5659             if (args) {
5660                 sv_catsv(sv, va_arg(*args, SV*));
5661                 return;
5662             }
5663             /* See comment on '_' below */
5664             break;
5665         }
5666     }
5667
5668     patend = (char*)pat + patlen;
5669     for (p = (char*)pat; p < patend; p = q) {
5670         bool alt = FALSE;
5671         bool left = FALSE;
5672         char fill = ' ';
5673         char plus = 0;
5674         char intsize = 0;
5675         STRLEN width = 0;
5676         STRLEN zeros = 0;
5677         bool has_precis = FALSE;
5678         STRLEN precis = 0;
5679
5680         char esignbuf[4];
5681         U8 utf8buf[10];
5682         STRLEN esignlen = 0;
5683
5684         char *eptr = Nullch;
5685         STRLEN elen = 0;
5686         /* Times 4: a decimal digit takes more than 3 binary digits.
5687          * NV_DIG: mantissa takes than many decimal digits.
5688          * Plus 32: Playing safe. */
5689         char ebuf[IV_DIG * 4 + NV_DIG + 32];
5690         /* large enough for "%#.#f" --chip */
5691         /* what about long double NVs? --jhi */
5692         char c;
5693         int i;
5694         unsigned base;
5695         IV iv;
5696         UV uv;
5697         NV nv;
5698         STRLEN have;
5699         STRLEN need;
5700         STRLEN gap;
5701
5702         for (q = p; q < patend && *q != '%'; ++q) ;
5703         if (q > p) {
5704             sv_catpvn(sv, p, q - p);
5705             p = q;
5706         }
5707         if (q++ >= patend)
5708             break;
5709
5710         /* FLAGS */
5711
5712         while (*q) {
5713             switch (*q) {
5714             case ' ':
5715             case '+':
5716                 plus = *q++;
5717                 continue;
5718
5719             case '-':
5720                 left = TRUE;
5721                 q++;
5722                 continue;
5723
5724             case '0':
5725                 fill = *q++;
5726                 continue;
5727
5728             case '#':
5729                 alt = TRUE;
5730                 q++;
5731                 continue;
5732
5733             default:
5734                 break;
5735             }
5736             break;
5737         }
5738
5739         /* WIDTH */
5740
5741         switch (*q) {
5742         case '1': case '2': case '3':
5743         case '4': case '5': case '6':
5744         case '7': case '8': case '9':
5745             width = 0;
5746             while (isDIGIT(*q))
5747                 width = width * 10 + (*q++ - '0');
5748             break;
5749
5750         case '*':
5751             if (args)
5752                 i = va_arg(*args, int);
5753             else
5754                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5755             left |= (i < 0);
5756             width = (i < 0) ? -i : i;
5757             q++;
5758             break;
5759         }
5760
5761         /* PRECISION */
5762
5763         if (*q == '.') {
5764             q++;
5765             if (*q == '*') {
5766                 if (args)
5767                     i = va_arg(*args, int);
5768                 else
5769                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5770                 precis = (i < 0) ? 0 : i;
5771                 q++;
5772             }
5773             else {
5774                 precis = 0;
5775                 while (isDIGIT(*q))
5776                     precis = precis * 10 + (*q++ - '0');
5777             }
5778             has_precis = TRUE;
5779         }
5780
5781         /* SIZE */
5782
5783         switch (*q) {
5784 #ifdef HAS_QUAD
5785         case 'L':                       /* Ld */
5786         case 'q':                       /* qd */
5787             intsize = 'q';
5788             q++;
5789             break;
5790 #endif
5791         case 'l':
5792 #ifdef HAS_QUAD
5793              if (*(q + 1) == 'l') {     /* lld */
5794                 intsize = 'q';
5795                 q += 2;
5796                 break;
5797              }
5798 #endif
5799             /* FALL THROUGH */
5800         case 'h':
5801             /* FALL THROUGH */
5802         case 'V':
5803             intsize = *q++;
5804             break;
5805         }
5806
5807         /* CONVERSION */
5808
5809         switch (c = *q++) {
5810
5811             /* STRINGS */
5812
5813         case '%':
5814             eptr = q - 1;
5815             elen = 1;
5816             goto string;
5817
5818         case 'c':
5819             if (IN_UTF8) {
5820                 if (args)
5821                     uv = va_arg(*args, int);
5822                 else
5823                     uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5824
5825                 eptr = (char*)utf8buf;
5826                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5827                 goto string;
5828             }
5829             if (args)
5830                 c = va_arg(*args, int);
5831             else
5832                 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5833             eptr = &c;
5834             elen = 1;
5835             goto string;
5836
5837         case 's':
5838             if (args) {
5839                 eptr = va_arg(*args, char*);
5840                 if (eptr)
5841 #ifdef MACOS_TRADITIONAL
5842                   /* On MacOS, %#s format is used for Pascal strings */
5843                   if (alt)
5844                     elen = *eptr++;
5845                   else
5846 #endif
5847                     elen = strlen(eptr);
5848                 else {
5849                     eptr = nullstr;
5850                     elen = sizeof nullstr - 1;
5851                 }
5852             }
5853             else if (svix < svmax) {
5854                 eptr = SvPVx(svargs[svix++], elen);
5855                 if (IN_UTF8) {
5856                     if (has_precis && precis < elen) {
5857                         I32 p = precis;
5858                         sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5859                         precis = p;
5860                     }
5861                     if (width) { /* fudge width (can't fudge elen) */
5862                         width += elen - sv_len_utf8(svargs[svix - 1]);
5863                     }
5864                 }
5865             }
5866             goto string;
5867
5868         case '_':
5869             /*
5870              * The "%_" hack might have to be changed someday,
5871              * if ISO or ANSI decide to use '_' for something.
5872              * So we keep it hidden from users' code.
5873              */
5874             if (!args)
5875                 goto unknown;
5876             eptr = SvPVx(va_arg(*args, SV*), elen);
5877
5878         string:
5879             if (has_precis && elen > precis)
5880                 elen = precis;
5881             break;
5882
5883             /* INTEGERS */
5884
5885         case 'p':
5886             if (args)
5887                 uv = PTR2UV(va_arg(*args, void*));
5888             else
5889                 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5890             base = 16;
5891             goto integer;
5892
5893         case 'D':
5894 #ifdef IV_IS_QUAD
5895             intsize = 'q';
5896 #else
5897             intsize = 'l';
5898 #endif
5899             /* FALL THROUGH */
5900         case 'd':
5901         case 'i':
5902             if (args) {
5903                 switch (intsize) {
5904                 case 'h':       iv = (short)va_arg(*args, int); break;
5905                 default:        iv = va_arg(*args, int); break;
5906                 case 'l':       iv = va_arg(*args, long); break;
5907                 case 'V':       iv = va_arg(*args, IV); break;
5908 #ifdef HAS_QUAD
5909                 case 'q':       iv = va_arg(*args, Quad_t); break;
5910 #endif
5911                 }
5912             }
5913             else {
5914                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5915                 switch (intsize) {
5916                 case 'h':       iv = (short)iv; break;
5917                 default:        iv = (int)iv; break;
5918                 case 'l':       iv = (long)iv; break;
5919                 case 'V':       break;
5920 #ifdef HAS_QUAD
5921                 case 'q':       iv = (Quad_t)iv; break;
5922 #endif
5923                 }
5924             }
5925             if (iv >= 0) {
5926                 uv = iv;
5927                 if (plus)
5928                     esignbuf[esignlen++] = plus;
5929             }
5930             else {
5931                 uv = -iv;
5932                 esignbuf[esignlen++] = '-';
5933             }
5934             base = 10;
5935             goto integer;
5936
5937         case 'U':
5938 #ifdef IV_IS_QUAD
5939             intsize = 'q';
5940 #else
5941             intsize = 'l';
5942 #endif
5943             /* FALL THROUGH */
5944         case 'u':
5945             base = 10;
5946             goto uns_integer;
5947
5948         case 'b':
5949             base = 2;
5950             goto uns_integer;
5951
5952         case 'O':
5953 #ifdef IV_IS_QUAD
5954             intsize = 'q';
5955 #else
5956             intsize = 'l';
5957 #endif
5958             /* FALL THROUGH */
5959         case 'o':
5960             base = 8;
5961             goto uns_integer;
5962
5963         case 'X':
5964         case 'x':
5965             base = 16;
5966
5967         uns_integer:
5968             if (args) {
5969                 switch (intsize) {
5970                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
5971                 default:   uv = va_arg(*args, unsigned); break;
5972                 case 'l':  uv = va_arg(*args, unsigned long); break;
5973                 case 'V':  uv = va_arg(*args, UV); break;
5974 #ifdef HAS_QUAD
5975                 case 'q':  uv = va_arg(*args, Quad_t); break;
5976 #endif
5977                 }
5978             }
5979             else {
5980                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5981                 switch (intsize) {
5982                 case 'h':       uv = (unsigned short)uv; break;
5983                 default:        uv = (unsigned)uv; break;
5984                 case 'l':       uv = (unsigned long)uv; break;
5985                 case 'V':       break;
5986 #ifdef HAS_QUAD
5987                 case 'q':       uv = (Quad_t)uv; break;
5988 #endif
5989                 }
5990             }
5991
5992         integer:
5993             eptr = ebuf + sizeof ebuf;
5994             switch (base) {
5995                 unsigned dig;
5996             case 16:
5997                 if (!uv)
5998                     alt = FALSE;
5999                 p = (char*)((c == 'X')
6000                             ? "0123456789ABCDEF" : "0123456789abcdef");
6001                 do {
6002                     dig = uv & 15;
6003                     *--eptr = p[dig];
6004                 } while (uv >>= 4);
6005                 if (alt) {
6006                     esignbuf[esignlen++] = '0';
6007                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
6008                 }
6009                 break;
6010             case 8:
6011                 do {
6012                     dig = uv & 7;
6013                     *--eptr = '0' + dig;
6014                 } while (uv >>= 3);
6015                 if (alt && *eptr != '0')
6016                     *--eptr = '0';
6017                 break;
6018             case 2:
6019                 do {
6020                     dig = uv & 1;
6021                     *--eptr = '0' + dig;
6022                 } while (uv >>= 1);
6023                 if (alt) {
6024                     esignbuf[esignlen++] = '0';
6025                     esignbuf[esignlen++] = 'b';
6026                 }
6027                 break;
6028             default:            /* it had better be ten or less */
6029 #if defined(PERL_Y2KWARN)
6030                 if (ckWARN(WARN_MISC)) {
6031                     STRLEN n;
6032                     char *s = SvPV(sv,n);
6033                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6034                         && (n == 2 || !isDIGIT(s[n-3])))
6035                     {
6036                         Perl_warner(aTHX_ WARN_MISC,
6037                                     "Possible Y2K bug: %%%c %s",
6038                                     c, "format string following '19'");
6039                     }
6040                 }
6041 #endif
6042                 do {
6043                     dig = uv % base;
6044                     *--eptr = '0' + dig;
6045                 } while (uv /= base);
6046                 break;
6047             }
6048             elen = (ebuf + sizeof ebuf) - eptr;
6049             if (has_precis) {
6050                 if (precis > elen)
6051                     zeros = precis - elen;
6052                 else if (precis == 0 && elen == 1 && *eptr == '0')
6053                     elen = 0;
6054             }
6055             break;
6056
6057             /* FLOATING POINT */
6058
6059         case 'F':
6060             c = 'f';            /* maybe %F isn't supported here */
6061             /* FALL THROUGH */
6062         case 'e': case 'E':
6063         case 'f':
6064         case 'g': case 'G':
6065
6066             /* This is evil, but floating point is even more evil */
6067
6068             if (args)
6069                 nv = va_arg(*args, NV);
6070             else
6071                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6072
6073             need = 0;
6074             if (c != 'e' && c != 'E') {
6075                 i = PERL_INT_MIN;
6076                 (void)frexp(nv, &i);
6077                 if (i == PERL_INT_MIN)
6078                     Perl_die(aTHX_ "panic: frexp");
6079                 if (i > 0)
6080                     need = BIT_DIGITS(i);
6081             }
6082             need += has_precis ? precis : 6; /* known default */
6083             if (need < width)
6084                 need = width;
6085
6086             need += 20; /* fudge factor */
6087             if (PL_efloatsize < need) {
6088                 Safefree(PL_efloatbuf);
6089                 PL_efloatsize = need + 20; /* more fudge */
6090                 New(906, PL_efloatbuf, PL_efloatsize, char);
6091                 PL_efloatbuf[0] = '\0';
6092             }
6093
6094             eptr = ebuf + sizeof ebuf;
6095             *--eptr = '\0';
6096             *--eptr = c;
6097 #ifdef USE_LONG_DOUBLE
6098             {
6099                 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
6100                 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
6101             }
6102 #endif
6103             if (has_precis) {
6104                 base = precis;
6105                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6106                 *--eptr = '.';
6107             }
6108             if (width) {
6109                 base = width;
6110                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6111             }
6112             if (fill == '0')
6113                 *--eptr = fill;
6114             if (left)
6115                 *--eptr = '-';
6116             if (plus)
6117                 *--eptr = plus;
6118             if (alt)
6119                 *--eptr = '#';
6120             *--eptr = '%';
6121
6122             {
6123                 RESTORE_NUMERIC_STANDARD();
6124                 (void)sprintf(PL_efloatbuf, eptr, nv);
6125                 RESTORE_NUMERIC_LOCAL();
6126             }
6127
6128             eptr = PL_efloatbuf;
6129             elen = strlen(PL_efloatbuf);
6130             break;
6131
6132             /* SPECIAL */
6133
6134         case 'n':
6135             i = SvCUR(sv) - origlen;
6136             if (args) {
6137                 switch (intsize) {
6138                 case 'h':       *(va_arg(*args, short*)) = i; break;
6139                 default:        *(va_arg(*args, int*)) = i; break;
6140                 case 'l':       *(va_arg(*args, long*)) = i; break;
6141                 case 'V':       *(va_arg(*args, IV*)) = i; break;
6142 #ifdef HAS_QUAD
6143                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
6144 #endif
6145                 }
6146             }
6147             else if (svix < svmax)
6148                 sv_setuv(svargs[svix++], (UV)i);
6149             continue;   /* not "break" */
6150
6151             /* UNKNOWN */
6152
6153         default:
6154       unknown:
6155             if (!args && ckWARN(WARN_PRINTF) &&
6156                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6157                 SV *msg = sv_newmortal();
6158                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6159                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6160                 if (c) {
6161                     if (isPRINT(c))
6162                         Perl_sv_catpvf(aTHX_ msg,
6163                                        "\"%%%c\"", c & 0xFF);
6164                     else
6165                         Perl_sv_catpvf(aTHX_ msg,
6166                                        "\"%%\\%03"UVof"\"",
6167                                        (UV)c & 0xFF);
6168                 } else
6169                     sv_catpv(msg, "end of string");
6170                 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6171             }
6172
6173             /* output mangled stuff ... */
6174             if (c == '\0')
6175                 --q;
6176             eptr = p;
6177             elen = q - p;
6178
6179             /* ... right here, because formatting flags should not apply */
6180             SvGROW(sv, SvCUR(sv) + elen + 1);
6181             p = SvEND(sv);
6182             memcpy(p, eptr, elen);
6183             p += elen;
6184             *p = '\0';
6185             SvCUR(sv) = p - SvPVX(sv);
6186             continue;   /* not "break" */
6187         }
6188
6189         have = esignlen + zeros + elen;
6190         need = (have > width ? have : width);
6191         gap = need - have;
6192
6193         SvGROW(sv, SvCUR(sv) + need + 1);
6194         p = SvEND(sv);
6195         if (esignlen && fill == '0') {
6196             for (i = 0; i < esignlen; i++)
6197                 *p++ = esignbuf[i];
6198         }
6199         if (gap && !left) {
6200             memset(p, fill, gap);
6201             p += gap;
6202         }
6203         if (esignlen && fill != '0') {
6204             for (i = 0; i < esignlen; i++)
6205                 *p++ = esignbuf[i];
6206         }
6207         if (zeros) {
6208             for (i = zeros; i; i--)
6209                 *p++ = '0';
6210         }
6211         if (elen) {
6212             memcpy(p, eptr, elen);
6213             p += elen;
6214         }
6215         if (gap && left) {
6216             memset(p, ' ', gap);
6217             p += gap;
6218         }
6219         *p = '\0';
6220         SvCUR(sv) = p - SvPVX(sv);
6221     }
6222 }
6223
6224 #if defined(USE_ITHREADS)
6225
6226 #if defined(USE_THREADS)
6227 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
6228 #endif
6229
6230 #ifndef OpREFCNT_inc
6231 #  define OpREFCNT_inc(o)       ((o) ? (++(o)->op_targ, (o)) : Nullop)
6232 #endif
6233
6234 #ifndef GpREFCNT_inc
6235 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6236 #endif
6237
6238
6239 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
6240 #define av_dup(s)       (AV*)sv_dup((SV*)s)
6241 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6242 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
6243 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6244 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
6245 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6246 #define io_dup(s)       (IO*)sv_dup((SV*)s)
6247 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6248 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
6249 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6250 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
6251 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
6252
6253 REGEXP *
6254 Perl_re_dup(pTHX_ REGEXP *r)
6255 {
6256     /* XXX fix when pmop->op_pmregexp becomes shared */
6257     return ReREFCNT_inc(r);
6258 }
6259
6260 PerlIO *
6261 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6262 {
6263     PerlIO *ret;
6264     if (!fp)
6265         return (PerlIO*)NULL;
6266
6267     /* look for it in the table first */
6268     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6269     if (ret)
6270         return ret;
6271
6272     /* create anew and remember what it is */
6273     ret = PerlIO_fdupopen(fp);
6274     ptr_table_store(PL_ptr_table, fp, ret);
6275     return ret;
6276 }
6277
6278 DIR *
6279 Perl_dirp_dup(pTHX_ DIR *dp)
6280 {
6281     if (!dp)
6282         return (DIR*)NULL;
6283     /* XXX TODO */
6284     return dp;
6285 }
6286
6287 GP *
6288 Perl_gp_dup(pTHX_ GP *gp)
6289 {
6290     GP *ret;
6291     if (!gp)
6292         return (GP*)NULL;
6293     /* look for it in the table first */
6294     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6295     if (ret)
6296         return ret;
6297
6298     /* create anew and remember what it is */
6299     Newz(0, ret, 1, GP);
6300     ptr_table_store(PL_ptr_table, gp, ret);
6301
6302     /* clone */
6303     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
6304     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
6305     ret->gp_io          = io_dup_inc(gp->gp_io);
6306     ret->gp_form        = cv_dup_inc(gp->gp_form);
6307     ret->gp_av          = av_dup_inc(gp->gp_av);
6308     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
6309     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
6310     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
6311     ret->gp_cvgen       = gp->gp_cvgen;
6312     ret->gp_flags       = gp->gp_flags;
6313     ret->gp_line        = gp->gp_line;
6314     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
6315     return ret;
6316 }
6317
6318 MAGIC *
6319 Perl_mg_dup(pTHX_ MAGIC *mg)
6320 {
6321     MAGIC *mgret = (MAGIC*)NULL;
6322     MAGIC *mgprev;
6323     if (!mg)
6324         return (MAGIC*)NULL;
6325     /* look for it in the table first */
6326     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6327     if (mgret)
6328         return mgret;
6329
6330     for (; mg; mg = mg->mg_moremagic) {
6331         MAGIC *nmg;
6332         Newz(0, nmg, 1, MAGIC);
6333         if (!mgret)
6334             mgret = nmg;
6335         else
6336             mgprev->mg_moremagic = nmg;
6337         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
6338         nmg->mg_private = mg->mg_private;
6339         nmg->mg_type    = mg->mg_type;
6340         nmg->mg_flags   = mg->mg_flags;
6341         if (mg->mg_type == 'r') {
6342             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6343         }
6344         else {
6345             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6346                               ? sv_dup_inc(mg->mg_obj)
6347                               : sv_dup(mg->mg_obj);
6348         }
6349         nmg->mg_len     = mg->mg_len;
6350         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
6351         if (mg->mg_ptr && mg->mg_type != 'g') {
6352             if (mg->mg_len >= 0) {
6353                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
6354                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6355                     AMT *amtp = (AMT*)mg->mg_ptr;
6356                     AMT *namtp = (AMT*)nmg->mg_ptr;
6357                     I32 i;
6358                     for (i = 1; i < NofAMmeth; i++) {
6359                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
6360                     }
6361                 }
6362             }
6363             else if (mg->mg_len == HEf_SVKEY)
6364                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6365         }
6366         mgprev = nmg;
6367     }
6368     return mgret;
6369 }
6370
6371 PTR_TBL_t *
6372 Perl_ptr_table_new(pTHX)
6373 {
6374     PTR_TBL_t *tbl;
6375     Newz(0, tbl, 1, PTR_TBL_t);
6376     tbl->tbl_max        = 511;
6377     tbl->tbl_items      = 0;
6378     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6379     return tbl;
6380 }
6381
6382 void *
6383 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6384 {
6385     PTR_TBL_ENT_t *tblent;
6386     UV hash = (UV)sv;
6387     assert(tbl);
6388     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6389     for (; tblent; tblent = tblent->next) {
6390         if (tblent->oldval == sv)
6391             return tblent->newval;
6392     }
6393     return (void*)NULL;
6394 }
6395
6396 void
6397 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6398 {
6399     PTR_TBL_ENT_t *tblent, **otblent;
6400     /* XXX this may be pessimal on platforms where pointers aren't good
6401      * hash values e.g. if they grow faster in the most significant
6402      * bits */
6403     UV hash = (UV)oldv;
6404     bool i = 1;
6405
6406     assert(tbl);
6407     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6408     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6409         if (tblent->oldval == oldv) {
6410             tblent->newval = newv;
6411             tbl->tbl_items++;
6412             return;
6413         }
6414     }
6415     Newz(0, tblent, 1, PTR_TBL_ENT_t);
6416     tblent->oldval = oldv;
6417     tblent->newval = newv;
6418     tblent->next = *otblent;
6419     *otblent = tblent;
6420     tbl->tbl_items++;
6421     if (i && tbl->tbl_items > tbl->tbl_max)
6422         ptr_table_split(tbl);
6423 }
6424
6425 void
6426 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6427 {
6428     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6429     UV oldsize = tbl->tbl_max + 1;
6430     UV newsize = oldsize * 2;
6431     UV i;
6432
6433     Renew(ary, newsize, PTR_TBL_ENT_t*);
6434     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6435     tbl->tbl_max = --newsize;
6436     tbl->tbl_ary = ary;
6437     for (i=0; i < oldsize; i++, ary++) {
6438         PTR_TBL_ENT_t **curentp, **entp, *ent;
6439         if (!*ary)
6440             continue;
6441         curentp = ary + oldsize;
6442         for (entp = ary, ent = *ary; ent; ent = *entp) {
6443             if ((newsize & (UV)ent->oldval) != i) {
6444                 *entp = ent->next;
6445                 ent->next = *curentp;
6446                 *curentp = ent;
6447                 continue;
6448             }
6449             else
6450                 entp = &ent->next;
6451         }
6452     }
6453 }
6454
6455 #ifdef DEBUGGING
6456 char *PL_watch_pvx;
6457 #endif
6458
6459 SV *
6460 Perl_sv_dup(pTHX_ SV *sstr)
6461 {
6462     U32 sflags;
6463     int dtype;
6464     int stype;
6465     SV *dstr;
6466
6467     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6468         return Nullsv;
6469     /* look for it in the table first */
6470     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6471     if (dstr)
6472         return dstr;
6473
6474     /* create anew and remember what it is */
6475     new_SV(dstr);
6476     ptr_table_store(PL_ptr_table, sstr, dstr);
6477
6478     /* clone */
6479     SvFLAGS(dstr)       = SvFLAGS(sstr);
6480     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
6481     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
6482
6483 #ifdef DEBUGGING
6484     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6485         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6486                       PL_watch_pvx, SvPVX(sstr));
6487 #endif
6488
6489     switch (SvTYPE(sstr)) {
6490     case SVt_NULL:
6491         SvANY(dstr)     = NULL;
6492         break;
6493     case SVt_IV:
6494         SvANY(dstr)     = new_XIV();
6495         SvIVX(dstr)     = SvIVX(sstr);
6496         break;
6497     case SVt_NV:
6498         SvANY(dstr)     = new_XNV();
6499         SvNVX(dstr)     = SvNVX(sstr);
6500         break;
6501     case SVt_RV:
6502         SvANY(dstr)     = new_XRV();
6503         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
6504         break;
6505     case SVt_PV:
6506         SvANY(dstr)     = new_XPV();
6507         SvCUR(dstr)     = SvCUR(sstr);
6508         SvLEN(dstr)     = SvLEN(sstr);
6509         if (SvROK(sstr))
6510             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6511         else if (SvPVX(sstr) && SvLEN(sstr))
6512             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6513         else
6514             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6515         break;
6516     case SVt_PVIV:
6517         SvANY(dstr)     = new_XPVIV();
6518         SvCUR(dstr)     = SvCUR(sstr);
6519         SvLEN(dstr)     = SvLEN(sstr);
6520         SvIVX(dstr)     = SvIVX(sstr);
6521         if (SvROK(sstr))
6522             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6523         else if (SvPVX(sstr) && SvLEN(sstr))
6524             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6525         else
6526             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6527         break;
6528     case SVt_PVNV:
6529         SvANY(dstr)     = new_XPVNV();
6530         SvCUR(dstr)     = SvCUR(sstr);
6531         SvLEN(dstr)     = SvLEN(sstr);
6532         SvIVX(dstr)     = SvIVX(sstr);
6533         SvNVX(dstr)     = SvNVX(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_PVMG:
6542         SvANY(dstr)     = new_XPVMG();
6543         SvCUR(dstr)     = SvCUR(sstr);
6544         SvLEN(dstr)     = SvLEN(sstr);
6545         SvIVX(dstr)     = SvIVX(sstr);
6546         SvNVX(dstr)     = SvNVX(sstr);
6547         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6548         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6549         if (SvROK(sstr))
6550             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6551         else if (SvPVX(sstr) && SvLEN(sstr))
6552             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6553         else
6554             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6555         break;
6556     case SVt_PVBM:
6557         SvANY(dstr)     = new_XPVBM();
6558         SvCUR(dstr)     = SvCUR(sstr);
6559         SvLEN(dstr)     = SvLEN(sstr);
6560         SvIVX(dstr)     = SvIVX(sstr);
6561         SvNVX(dstr)     = SvNVX(sstr);
6562         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6563         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6564         if (SvROK(sstr))
6565             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6566         else if (SvPVX(sstr) && SvLEN(sstr))
6567             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6568         else
6569             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6570         BmRARE(dstr)    = BmRARE(sstr);
6571         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
6572         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6573         break;
6574     case SVt_PVLV:
6575         SvANY(dstr)     = new_XPVLV();
6576         SvCUR(dstr)     = SvCUR(sstr);
6577         SvLEN(dstr)     = SvLEN(sstr);
6578         SvIVX(dstr)     = SvIVX(sstr);
6579         SvNVX(dstr)     = SvNVX(sstr);
6580         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6581         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6582         if (SvROK(sstr))
6583             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6584         else if (SvPVX(sstr) && SvLEN(sstr))
6585             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6586         else
6587             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6588         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
6589         LvTARGLEN(dstr) = LvTARGLEN(sstr);
6590         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
6591         LvTYPE(dstr)    = LvTYPE(sstr);
6592         break;
6593     case SVt_PVGV:
6594         SvANY(dstr)     = new_XPVGV();
6595         SvCUR(dstr)     = SvCUR(sstr);
6596         SvLEN(dstr)     = SvLEN(sstr);
6597         SvIVX(dstr)     = SvIVX(sstr);
6598         SvNVX(dstr)     = SvNVX(sstr);
6599         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6600         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6601         if (SvROK(sstr))
6602             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6603         else if (SvPVX(sstr) && SvLEN(sstr))
6604             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6605         else
6606             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6607         GvNAMELEN(dstr) = GvNAMELEN(sstr);
6608         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6609         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
6610         GvFLAGS(dstr)   = GvFLAGS(sstr);
6611         GvGP(dstr)      = gp_dup(GvGP(sstr));
6612         (void)GpREFCNT_inc(GvGP(dstr));
6613         break;
6614     case SVt_PVIO:
6615         SvANY(dstr)     = new_XPVIO();
6616         SvCUR(dstr)     = SvCUR(sstr);
6617         SvLEN(dstr)     = SvLEN(sstr);
6618         SvIVX(dstr)     = SvIVX(sstr);
6619         SvNVX(dstr)     = SvNVX(sstr);
6620         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6621         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6622         if (SvROK(sstr))
6623             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6624         else if (SvPVX(sstr) && SvLEN(sstr))
6625             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6626         else
6627             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6628         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6629         if (IoOFP(sstr) == IoIFP(sstr))
6630             IoOFP(dstr) = IoIFP(dstr);
6631         else
6632             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6633         /* PL_rsfp_filters entries have fake IoDIRP() */
6634         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6635             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
6636         else
6637             IoDIRP(dstr)        = IoDIRP(sstr);
6638         IoLINES(dstr)           = IoLINES(sstr);
6639         IoPAGE(dstr)            = IoPAGE(sstr);
6640         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
6641         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
6642         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
6643         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
6644         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
6645         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
6646         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
6647         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
6648         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
6649         IoTYPE(dstr)            = IoTYPE(sstr);
6650         IoFLAGS(dstr)           = IoFLAGS(sstr);
6651         break;
6652     case SVt_PVAV:
6653         SvANY(dstr)     = new_XPVAV();
6654         SvCUR(dstr)     = SvCUR(sstr);
6655         SvLEN(dstr)     = SvLEN(sstr);
6656         SvIVX(dstr)     = SvIVX(sstr);
6657         SvNVX(dstr)     = SvNVX(sstr);
6658         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6659         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6660         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6661         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6662         if (AvARRAY((AV*)sstr)) {
6663             SV **dst_ary, **src_ary;
6664             SSize_t items = AvFILLp((AV*)sstr) + 1;
6665
6666             src_ary = AvARRAY((AV*)sstr);
6667             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6668             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6669             SvPVX(dstr) = (char*)dst_ary;
6670             AvALLOC((AV*)dstr) = dst_ary;
6671             if (AvREAL((AV*)sstr)) {
6672                 while (items-- > 0)
6673                     *dst_ary++ = sv_dup_inc(*src_ary++);
6674             }
6675             else {
6676                 while (items-- > 0)
6677                     *dst_ary++ = sv_dup(*src_ary++);
6678             }
6679             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6680             while (items-- > 0) {
6681                 *dst_ary++ = &PL_sv_undef;
6682             }
6683         }
6684         else {
6685             SvPVX(dstr)         = Nullch;
6686             AvALLOC((AV*)dstr)  = (SV**)NULL;
6687         }
6688         break;
6689     case SVt_PVHV:
6690         SvANY(dstr)     = new_XPVHV();
6691         SvCUR(dstr)     = SvCUR(sstr);
6692         SvLEN(dstr)     = SvLEN(sstr);
6693         SvIVX(dstr)     = SvIVX(sstr);
6694         SvNVX(dstr)     = SvNVX(sstr);
6695         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6696         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6697         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
6698         if (HvARRAY((HV*)sstr)) {
6699             HE *entry;
6700             STRLEN i = 0;
6701             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6702             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6703             Newz(0, dxhv->xhv_array,
6704                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6705             while (i <= sxhv->xhv_max) {
6706                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6707                                                     !!HvSHAREKEYS(sstr));
6708                 ++i;
6709             }
6710             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6711         }
6712         else {
6713             SvPVX(dstr)         = Nullch;
6714             HvEITER((HV*)dstr)  = (HE*)NULL;
6715         }
6716         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
6717         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
6718         break;
6719     case SVt_PVFM:
6720         SvANY(dstr)     = new_XPVFM();
6721         FmLINES(dstr)   = FmLINES(sstr);
6722         goto dup_pvcv;
6723         /* NOTREACHED */
6724     case SVt_PVCV:
6725         SvANY(dstr)     = new_XPVCV();
6726 dup_pvcv:
6727         SvCUR(dstr)     = SvCUR(sstr);
6728         SvLEN(dstr)     = SvLEN(sstr);
6729         SvIVX(dstr)     = SvIVX(sstr);
6730         SvNVX(dstr)     = SvNVX(sstr);
6731         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6732         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6733         if (SvPVX(sstr) && SvLEN(sstr))
6734             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6735         else
6736             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6737         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6738         CvSTART(dstr)   = CvSTART(sstr);
6739         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
6740         CvXSUB(dstr)    = CvXSUB(sstr);
6741         CvXSUBANY(dstr) = CvXSUBANY(sstr);
6742         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
6743         CvDEPTH(dstr)   = CvDEPTH(sstr);
6744         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6745             /* XXX padlists are real, but pretend to be not */
6746             AvREAL_on(CvPADLIST(sstr));
6747             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6748             AvREAL_off(CvPADLIST(sstr));
6749             AvREAL_off(CvPADLIST(dstr));
6750         }
6751         else
6752             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6753         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6754         CvFLAGS(dstr)   = CvFLAGS(sstr);
6755         break;
6756     default:
6757         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6758         break;
6759     }
6760
6761     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6762         ++PL_sv_objcount;
6763
6764     return dstr;
6765 }
6766
6767 PERL_CONTEXT *
6768 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6769 {
6770     PERL_CONTEXT *ncxs;
6771
6772     if (!cxs)
6773         return (PERL_CONTEXT*)NULL;
6774
6775     /* look for it in the table first */
6776     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6777     if (ncxs)
6778         return ncxs;
6779
6780     /* create anew and remember what it is */
6781     Newz(56, ncxs, max + 1, PERL_CONTEXT);
6782     ptr_table_store(PL_ptr_table, cxs, ncxs);
6783
6784     while (ix >= 0) {
6785         PERL_CONTEXT *cx = &cxs[ix];
6786         PERL_CONTEXT *ncx = &ncxs[ix];
6787         ncx->cx_type    = cx->cx_type;
6788         if (CxTYPE(cx) == CXt_SUBST) {
6789             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6790         }
6791         else {
6792             ncx->blk_oldsp      = cx->blk_oldsp;
6793             ncx->blk_oldcop     = cx->blk_oldcop;
6794             ncx->blk_oldretsp   = cx->blk_oldretsp;
6795             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
6796             ncx->blk_oldscopesp = cx->blk_oldscopesp;
6797             ncx->blk_oldpm      = cx->blk_oldpm;
6798             ncx->blk_gimme      = cx->blk_gimme;
6799             switch (CxTYPE(cx)) {
6800             case CXt_SUB:
6801                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
6802                                            ? cv_dup_inc(cx->blk_sub.cv)
6803                                            : cv_dup(cx->blk_sub.cv));
6804                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
6805                                            ? av_dup_inc(cx->blk_sub.argarray)
6806                                            : Nullav);
6807                 ncx->blk_sub.savearray  = av_dup(cx->blk_sub.savearray);
6808                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
6809                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6810                 ncx->blk_sub.lval       = cx->blk_sub.lval;
6811                 break;
6812             case CXt_EVAL:
6813                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6814                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6815                 ncx->blk_eval.old_name  = SAVEPV(cx->blk_eval.old_name);
6816                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6817                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
6818                 break;
6819             case CXt_LOOP:
6820                 ncx->blk_loop.label     = cx->blk_loop.label;
6821                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
6822                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
6823                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
6824                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
6825                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
6826                                            ? cx->blk_loop.iterdata
6827                                            : gv_dup((GV*)cx->blk_loop.iterdata));
6828                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
6829                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
6830                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
6831                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
6832                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
6833                 break;
6834             case CXt_FORMAT:
6835                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
6836                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
6837                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
6838                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6839                 break;
6840             case CXt_BLOCK:
6841             case CXt_NULL:
6842                 break;
6843             }
6844         }
6845         --ix;
6846     }
6847     return ncxs;
6848 }
6849
6850 PERL_SI *
6851 Perl_si_dup(pTHX_ PERL_SI *si)
6852 {
6853     PERL_SI *nsi;
6854
6855     if (!si)
6856         return (PERL_SI*)NULL;
6857
6858     /* look for it in the table first */
6859     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6860     if (nsi)
6861         return nsi;
6862
6863     /* create anew and remember what it is */
6864     Newz(56, nsi, 1, PERL_SI);
6865     ptr_table_store(PL_ptr_table, si, nsi);
6866
6867     nsi->si_stack       = av_dup_inc(si->si_stack);
6868     nsi->si_cxix        = si->si_cxix;
6869     nsi->si_cxmax       = si->si_cxmax;
6870     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6871     nsi->si_type        = si->si_type;
6872     nsi->si_prev        = si_dup(si->si_prev);
6873     nsi->si_next        = si_dup(si->si_next);
6874     nsi->si_markoff     = si->si_markoff;
6875
6876     return nsi;
6877 }
6878
6879 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
6880 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
6881 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
6882 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
6883 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
6884 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
6885 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
6886 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
6887 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
6888 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
6889 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
6890 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
6891
6892 /* XXXXX todo */
6893 #define pv_dup_inc(p)   SAVEPV(p)
6894 #define pv_dup(p)       SAVEPV(p)
6895 #define svp_dup_inc(p,pp)       any_dup(p,pp)
6896
6897 void *
6898 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
6899 {
6900     void *ret;
6901
6902     if (!v)
6903         return (void*)NULL;
6904
6905     /* look for it in the table first */
6906     ret = ptr_table_fetch(PL_ptr_table, v);
6907     if (ret)
6908         return ret;
6909
6910     /* see if it is part of the interpreter structure */
6911     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
6912         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
6913     else
6914         ret = v;
6915
6916     return ret;
6917 }
6918
6919 ANY *
6920 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
6921 {
6922     ANY *ss     = proto_perl->Tsavestack;
6923     I32 ix      = proto_perl->Tsavestack_ix;
6924     I32 max     = proto_perl->Tsavestack_max;
6925     ANY *nss;
6926     SV *sv;
6927     GV *gv;
6928     AV *av;
6929     HV *hv;
6930     void* ptr;
6931     int intval;
6932     long longval;
6933     GP *gp;
6934     IV iv;
6935     I32 i;
6936     char *c;
6937     void (*dptr) (void*);
6938     void (*dxptr) (pTHXo_ void*);
6939
6940     Newz(54, nss, max, ANY);
6941
6942     while (ix > 0) {
6943         i = POPINT(ss,ix);
6944         TOPINT(nss,ix) = i;
6945         switch (i) {
6946         case SAVEt_ITEM:                        /* normal string */
6947             sv = (SV*)POPPTR(ss,ix);
6948             TOPPTR(nss,ix) = sv_dup_inc(sv);
6949             sv = (SV*)POPPTR(ss,ix);
6950             TOPPTR(nss,ix) = sv_dup_inc(sv);
6951             break;
6952         case SAVEt_SV:                          /* scalar reference */
6953             sv = (SV*)POPPTR(ss,ix);
6954             TOPPTR(nss,ix) = sv_dup_inc(sv);
6955             gv = (GV*)POPPTR(ss,ix);
6956             TOPPTR(nss,ix) = gv_dup_inc(gv);
6957             break;
6958         case SAVEt_GENERIC_SVREF:               /* generic sv */
6959         case SAVEt_SVREF:                       /* scalar reference */
6960             sv = (SV*)POPPTR(ss,ix);
6961             TOPPTR(nss,ix) = sv_dup_inc(sv);
6962             ptr = POPPTR(ss,ix);
6963             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
6964             break;
6965         case SAVEt_AV:                          /* array reference */
6966             av = (AV*)POPPTR(ss,ix);
6967             TOPPTR(nss,ix) = av_dup_inc(av);
6968             gv = (GV*)POPPTR(ss,ix);
6969             TOPPTR(nss,ix) = gv_dup(gv);
6970             break;
6971         case SAVEt_HV:                          /* hash reference */
6972             hv = (HV*)POPPTR(ss,ix);
6973             TOPPTR(nss,ix) = hv_dup_inc(hv);
6974             gv = (GV*)POPPTR(ss,ix);
6975             TOPPTR(nss,ix) = gv_dup(gv);
6976             break;
6977         case SAVEt_INT:                         /* int reference */
6978             ptr = POPPTR(ss,ix);
6979             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6980             intval = (int)POPINT(ss,ix);
6981             TOPINT(nss,ix) = intval;
6982             break;
6983         case SAVEt_LONG:                        /* long reference */
6984             ptr = POPPTR(ss,ix);
6985             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6986             longval = (long)POPLONG(ss,ix);
6987             TOPLONG(nss,ix) = longval;
6988             break;
6989         case SAVEt_I32:                         /* I32 reference */
6990         case SAVEt_I16:                         /* I16 reference */
6991         case SAVEt_I8:                          /* I8 reference */
6992             ptr = POPPTR(ss,ix);
6993             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6994             i = POPINT(ss,ix);
6995             TOPINT(nss,ix) = i;
6996             break;
6997         case SAVEt_IV:                          /* IV reference */
6998             ptr = POPPTR(ss,ix);
6999             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7000             iv = POPIV(ss,ix);
7001             TOPIV(nss,ix) = iv;
7002             break;
7003         case SAVEt_SPTR:                        /* SV* reference */
7004             ptr = POPPTR(ss,ix);
7005             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7006             sv = (SV*)POPPTR(ss,ix);
7007             TOPPTR(nss,ix) = sv_dup(sv);
7008             break;
7009         case SAVEt_VPTR:                        /* random* reference */
7010             ptr = POPPTR(ss,ix);
7011             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7012             ptr = POPPTR(ss,ix);
7013             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7014             break;
7015         case SAVEt_PPTR:                        /* char* reference */
7016             ptr = POPPTR(ss,ix);
7017             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7018             c = (char*)POPPTR(ss,ix);
7019             TOPPTR(nss,ix) = pv_dup(c);
7020             break;
7021         case SAVEt_HPTR:                        /* HV* reference */
7022             ptr = POPPTR(ss,ix);
7023             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7024             hv = (HV*)POPPTR(ss,ix);
7025             TOPPTR(nss,ix) = hv_dup(hv);
7026             break;
7027         case SAVEt_APTR:                        /* AV* reference */
7028             ptr = POPPTR(ss,ix);
7029             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7030             av = (AV*)POPPTR(ss,ix);
7031             TOPPTR(nss,ix) = av_dup(av);
7032             break;
7033         case SAVEt_NSTAB:
7034             gv = (GV*)POPPTR(ss,ix);
7035             TOPPTR(nss,ix) = gv_dup(gv);
7036             break;
7037         case SAVEt_GP:                          /* scalar reference */
7038             gp = (GP*)POPPTR(ss,ix);
7039             TOPPTR(nss,ix) = gp = gp_dup(gp);
7040             (void)GpREFCNT_inc(gp);
7041             gv = (GV*)POPPTR(ss,ix);
7042             TOPPTR(nss,ix) = gv_dup_inc(c);
7043             c = (char*)POPPTR(ss,ix);
7044             TOPPTR(nss,ix) = pv_dup(c);
7045             iv = POPIV(ss,ix);
7046             TOPIV(nss,ix) = iv;
7047             iv = POPIV(ss,ix);
7048             TOPIV(nss,ix) = iv;
7049             break;
7050         case SAVEt_FREESV:
7051             sv = (SV*)POPPTR(ss,ix);
7052             TOPPTR(nss,ix) = sv_dup_inc(sv);
7053             break;
7054         case SAVEt_FREEOP:
7055             ptr = POPPTR(ss,ix);
7056             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7057                 /* these are assumed to be refcounted properly */
7058                 switch (((OP*)ptr)->op_type) {
7059                 case OP_LEAVESUB:
7060                 case OP_LEAVESUBLV:
7061                 case OP_LEAVEEVAL:
7062                 case OP_LEAVE:
7063                 case OP_SCOPE:
7064                 case OP_LEAVEWRITE:
7065                     TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7066                     break;
7067                 default:
7068                     TOPPTR(nss,ix) = Nullop;
7069                     break;
7070                 }
7071             }
7072             else
7073                 TOPPTR(nss,ix) = Nullop;
7074             break;
7075         case SAVEt_FREEPV:
7076             c = (char*)POPPTR(ss,ix);
7077             TOPPTR(nss,ix) = pv_dup_inc(c);
7078             break;
7079         case SAVEt_CLEARSV:
7080             longval = POPLONG(ss,ix);
7081             TOPLONG(nss,ix) = longval;
7082             break;
7083         case SAVEt_DELETE:
7084             hv = (HV*)POPPTR(ss,ix);
7085             TOPPTR(nss,ix) = hv_dup_inc(hv);
7086             c = (char*)POPPTR(ss,ix);
7087             TOPPTR(nss,ix) = pv_dup_inc(c);
7088             i = POPINT(ss,ix);
7089             TOPINT(nss,ix) = i;
7090             break;
7091         case SAVEt_DESTRUCTOR:
7092             ptr = POPPTR(ss,ix);
7093             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7094             dptr = POPDPTR(ss,ix);
7095             TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
7096             break;
7097         case SAVEt_DESTRUCTOR_X:
7098             ptr = POPPTR(ss,ix);
7099             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7100             dxptr = POPDXPTR(ss,ix);
7101             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
7102             break;
7103         case SAVEt_REGCONTEXT:
7104         case SAVEt_ALLOC:
7105             i = POPINT(ss,ix);
7106             TOPINT(nss,ix) = i;
7107             ix -= i;
7108             break;
7109         case SAVEt_STACK_POS:           /* Position on Perl stack */
7110             i = POPINT(ss,ix);
7111             TOPINT(nss,ix) = i;
7112             break;
7113         case SAVEt_AELEM:               /* array element */
7114             sv = (SV*)POPPTR(ss,ix);
7115             TOPPTR(nss,ix) = sv_dup_inc(sv);
7116             i = POPINT(ss,ix);
7117             TOPINT(nss,ix) = i;
7118             av = (AV*)POPPTR(ss,ix);
7119             TOPPTR(nss,ix) = av_dup_inc(av);
7120             break;
7121         case SAVEt_HELEM:               /* hash element */
7122             sv = (SV*)POPPTR(ss,ix);
7123             TOPPTR(nss,ix) = sv_dup_inc(sv);
7124             sv = (SV*)POPPTR(ss,ix);
7125             TOPPTR(nss,ix) = sv_dup_inc(sv);
7126             hv = (HV*)POPPTR(ss,ix);
7127             TOPPTR(nss,ix) = hv_dup_inc(hv);
7128             break;
7129         case SAVEt_OP:
7130             ptr = POPPTR(ss,ix);
7131             TOPPTR(nss,ix) = ptr;
7132             break;
7133         case SAVEt_HINTS:
7134             i = POPINT(ss,ix);
7135             TOPINT(nss,ix) = i;
7136             break;
7137         default:
7138             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7139         }
7140     }
7141
7142     return nss;
7143 }
7144
7145 #ifdef PERL_OBJECT
7146 #include "XSUB.h"
7147 #endif
7148
7149 PerlInterpreter *
7150 perl_clone(PerlInterpreter *proto_perl, UV flags)
7151 {
7152 #ifdef PERL_OBJECT
7153     CPerlObj *pPerl = (CPerlObj*)proto_perl;
7154 #endif
7155
7156 #ifdef PERL_IMPLICIT_SYS
7157     return perl_clone_using(proto_perl, flags,
7158                             proto_perl->IMem,
7159                             proto_perl->IMemShared,
7160                             proto_perl->IMemParse,
7161                             proto_perl->IEnv,
7162                             proto_perl->IStdIO,
7163                             proto_perl->ILIO,
7164                             proto_perl->IDir,
7165                             proto_perl->ISock,
7166                             proto_perl->IProc);
7167 }
7168
7169 PerlInterpreter *
7170 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7171                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
7172                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7173                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7174                  struct IPerlDir* ipD, struct IPerlSock* ipS,
7175                  struct IPerlProc* ipP)
7176 {
7177     /* XXX many of the string copies here can be optimized if they're
7178      * constants; they need to be allocated as common memory and just
7179      * their pointers copied. */
7180
7181     IV i;
7182     SV *sv;
7183     SV **svp;
7184 #  ifdef PERL_OBJECT
7185     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7186                                         ipD, ipS, ipP);
7187     PERL_SET_INTERP(pPerl);
7188 #  else         /* !PERL_OBJECT */
7189     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7190     PERL_SET_INTERP(my_perl);
7191
7192 #    ifdef DEBUGGING
7193     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7194     PL_markstack = 0;
7195     PL_scopestack = 0;
7196     PL_savestack = 0;
7197     PL_retstack = 0;
7198 #    else       /* !DEBUGGING */
7199     Zero(my_perl, 1, PerlInterpreter);
7200 #    endif      /* DEBUGGING */
7201
7202     /* host pointers */
7203     PL_Mem              = ipM;
7204     PL_MemShared        = ipMS;
7205     PL_MemParse         = ipMP;
7206     PL_Env              = ipE;
7207     PL_StdIO            = ipStd;
7208     PL_LIO              = ipLIO;
7209     PL_Dir              = ipD;
7210     PL_Sock             = ipS;
7211     PL_Proc             = ipP;
7212 #  endif        /* PERL_OBJECT */
7213 #else           /* !PERL_IMPLICIT_SYS */
7214     IV i;
7215     SV *sv;
7216     SV **svp;
7217     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7218     PERL_SET_INTERP(my_perl);
7219
7220 #    ifdef DEBUGGING
7221     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7222     PL_markstack = 0;
7223     PL_scopestack = 0;
7224     PL_savestack = 0;
7225     PL_retstack = 0;
7226 #    else       /* !DEBUGGING */
7227     Zero(my_perl, 1, PerlInterpreter);
7228 #    endif      /* DEBUGGING */
7229 #endif          /* PERL_IMPLICIT_SYS */
7230
7231     /* arena roots */
7232     PL_xiv_arenaroot    = NULL;
7233     PL_xiv_root         = NULL;
7234     PL_xnv_root         = NULL;
7235     PL_xrv_root         = NULL;
7236     PL_xpv_root         = NULL;
7237     PL_xpviv_root       = NULL;
7238     PL_xpvnv_root       = NULL;
7239     PL_xpvcv_root       = NULL;
7240     PL_xpvav_root       = NULL;
7241     PL_xpvhv_root       = NULL;
7242     PL_xpvmg_root       = NULL;
7243     PL_xpvlv_root       = NULL;
7244     PL_xpvbm_root       = NULL;
7245     PL_he_root          = NULL;
7246     PL_nice_chunk       = NULL;
7247     PL_nice_chunk_size  = 0;
7248     PL_sv_count         = 0;
7249     PL_sv_objcount      = 0;
7250     PL_sv_root          = Nullsv;
7251     PL_sv_arenaroot     = Nullsv;
7252
7253     PL_debug            = proto_perl->Idebug;
7254
7255     /* create SV map for pointer relocation */
7256     PL_ptr_table = ptr_table_new();
7257
7258     /* initialize these special pointers as early as possible */
7259     SvANY(&PL_sv_undef)         = NULL;
7260     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
7261     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
7262     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7263
7264 #ifdef PERL_OBJECT
7265     SvUPGRADE(&PL_sv_no, SVt_PVNV);
7266 #else
7267     SvANY(&PL_sv_no)            = new_XPVNV();
7268 #endif
7269     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
7270     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7271     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
7272     SvCUR(&PL_sv_no)            = 0;
7273     SvLEN(&PL_sv_no)            = 1;
7274     SvNVX(&PL_sv_no)            = 0;
7275     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7276
7277 #ifdef PERL_OBJECT
7278     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7279 #else
7280     SvANY(&PL_sv_yes)           = new_XPVNV();
7281 #endif
7282     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
7283     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7284     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
7285     SvCUR(&PL_sv_yes)           = 1;
7286     SvLEN(&PL_sv_yes)           = 2;
7287     SvNVX(&PL_sv_yes)           = 1;
7288     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7289
7290     /* create shared string table */
7291     PL_strtab           = newHV();
7292     HvSHAREKEYS_off(PL_strtab);
7293     hv_ksplit(PL_strtab, 512);
7294     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7295
7296     PL_compiling                = proto_perl->Icompiling;
7297     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
7298     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
7299     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7300     if (!specialWARN(PL_compiling.cop_warnings))
7301         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7302     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7303
7304     /* pseudo environmental stuff */
7305     PL_origargc         = proto_perl->Iorigargc;
7306     i = PL_origargc;
7307     New(0, PL_origargv, i+1, char*);
7308     PL_origargv[i] = '\0';
7309     while (i-- > 0) {
7310         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
7311     }
7312     PL_envgv            = gv_dup(proto_perl->Ienvgv);
7313     PL_incgv            = gv_dup(proto_perl->Iincgv);
7314     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
7315     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
7316     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
7317     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
7318
7319     /* switches */
7320     PL_minus_c          = proto_perl->Iminus_c;
7321     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
7322     PL_localpatches     = proto_perl->Ilocalpatches;
7323     PL_splitstr         = proto_perl->Isplitstr;
7324     PL_preprocess       = proto_perl->Ipreprocess;
7325     PL_minus_n          = proto_perl->Iminus_n;
7326     PL_minus_p          = proto_perl->Iminus_p;
7327     PL_minus_l          = proto_perl->Iminus_l;
7328     PL_minus_a          = proto_perl->Iminus_a;
7329     PL_minus_F          = proto_perl->Iminus_F;
7330     PL_doswitches       = proto_perl->Idoswitches;
7331     PL_dowarn           = proto_perl->Idowarn;
7332     PL_doextract        = proto_perl->Idoextract;
7333     PL_sawampersand     = proto_perl->Isawampersand;
7334     PL_unsafe           = proto_perl->Iunsafe;
7335     PL_inplace          = SAVEPV(proto_perl->Iinplace);
7336     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
7337     PL_perldb           = proto_perl->Iperldb;
7338     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7339
7340     /* magical thingies */
7341     /* XXX time(&PL_basetime) when asked for? */
7342     PL_basetime         = proto_perl->Ibasetime;
7343     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
7344
7345     PL_maxsysfd         = proto_perl->Imaxsysfd;
7346     PL_multiline        = proto_perl->Imultiline;
7347     PL_statusvalue      = proto_perl->Istatusvalue;
7348 #ifdef VMS
7349     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
7350 #endif
7351
7352     /* shortcuts to various I/O objects */
7353     PL_stdingv          = gv_dup(proto_perl->Istdingv);
7354     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
7355     PL_defgv            = gv_dup(proto_perl->Idefgv);
7356     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
7357     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
7358     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
7359
7360     /* shortcuts to regexp stuff */
7361     PL_replgv           = gv_dup(proto_perl->Ireplgv);
7362
7363     /* shortcuts to misc objects */
7364     PL_errgv            = gv_dup(proto_perl->Ierrgv);
7365
7366     /* shortcuts to debugging objects */
7367     PL_DBgv             = gv_dup(proto_perl->IDBgv);
7368     PL_DBline           = gv_dup(proto_perl->IDBline);
7369     PL_DBsub            = gv_dup(proto_perl->IDBsub);
7370     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
7371     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
7372     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
7373     PL_lineary          = av_dup(proto_perl->Ilineary);
7374     PL_dbargs           = av_dup(proto_perl->Idbargs);
7375
7376     /* symbol tables */
7377     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
7378     PL_curstash         = hv_dup(proto_perl->Tcurstash);
7379     PL_debstash         = hv_dup(proto_perl->Idebstash);
7380     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
7381     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
7382
7383     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
7384     PL_endav            = av_dup_inc(proto_perl->Iendav);
7385     PL_checkav          = av_dup_inc(proto_perl->Icheckav);
7386     PL_initav           = av_dup_inc(proto_perl->Iinitav);
7387
7388     PL_sub_generation   = proto_perl->Isub_generation;
7389
7390     /* funky return mechanisms */
7391     PL_forkprocess      = proto_perl->Iforkprocess;
7392
7393     /* subprocess state */
7394     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
7395
7396     /* internal state */
7397     PL_tainting         = proto_perl->Itainting;
7398     PL_maxo             = proto_perl->Imaxo;
7399     if (proto_perl->Iop_mask)
7400         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7401     else
7402         PL_op_mask      = Nullch;
7403
7404     /* current interpreter roots */
7405     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
7406     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
7407     PL_main_start       = proto_perl->Imain_start;
7408     PL_eval_root        = OpREFCNT_inc(proto_perl->Ieval_root);
7409     PL_eval_start       = proto_perl->Ieval_start;
7410
7411     /* runtime control stuff */
7412     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7413     PL_copline          = proto_perl->Icopline;
7414
7415     PL_filemode         = proto_perl->Ifilemode;
7416     PL_lastfd           = proto_perl->Ilastfd;
7417     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
7418     PL_Argv             = NULL;
7419     PL_Cmd              = Nullch;
7420     PL_gensym           = proto_perl->Igensym;
7421     PL_preambled        = proto_perl->Ipreambled;
7422     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
7423     PL_laststatval      = proto_perl->Ilaststatval;
7424     PL_laststype        = proto_perl->Ilaststype;
7425     PL_mess_sv          = Nullsv;
7426
7427     PL_orslen           = proto_perl->Iorslen;
7428     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
7429     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
7430
7431     /* interpreter atexit processing */
7432     PL_exitlistlen      = proto_perl->Iexitlistlen;
7433     if (PL_exitlistlen) {
7434         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7435         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7436     }
7437     else
7438         PL_exitlist     = (PerlExitListEntry*)NULL;
7439     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
7440
7441     PL_profiledata      = NULL;
7442     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
7443     /* PL_rsfp_filters entries have fake IoDIRP() */
7444     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
7445
7446     PL_compcv                   = cv_dup(proto_perl->Icompcv);
7447     PL_comppad                  = av_dup(proto_perl->Icomppad);
7448     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
7449     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
7450     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
7451     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
7452                                                         proto_perl->Tcurpad);
7453
7454 #ifdef HAVE_INTERP_INTERN
7455     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7456 #endif
7457
7458     /* more statics moved here */
7459     PL_generation       = proto_perl->Igeneration;
7460     PL_DBcv             = cv_dup(proto_perl->IDBcv);
7461
7462     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
7463     PL_in_clean_all     = proto_perl->Iin_clean_all;
7464
7465     PL_uid              = proto_perl->Iuid;
7466     PL_euid             = proto_perl->Ieuid;
7467     PL_gid              = proto_perl->Igid;
7468     PL_egid             = proto_perl->Iegid;
7469     PL_nomemok          = proto_perl->Inomemok;
7470     PL_an               = proto_perl->Ian;
7471     PL_cop_seqmax       = proto_perl->Icop_seqmax;
7472     PL_op_seqmax        = proto_perl->Iop_seqmax;
7473     PL_evalseq          = proto_perl->Ievalseq;
7474     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
7475     PL_origalen         = proto_perl->Iorigalen;
7476     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
7477     PL_osname           = SAVEPV(proto_perl->Iosname);
7478     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
7479     PL_sighandlerp      = proto_perl->Isighandlerp;
7480
7481
7482     PL_runops           = proto_perl->Irunops;
7483
7484     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7485
7486 #ifdef CSH
7487     PL_cshlen           = proto_perl->Icshlen;
7488     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7489 #endif
7490
7491     PL_lex_state        = proto_perl->Ilex_state;
7492     PL_lex_defer        = proto_perl->Ilex_defer;
7493     PL_lex_expect       = proto_perl->Ilex_expect;
7494     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
7495     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
7496     PL_lex_starts       = proto_perl->Ilex_starts;
7497     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
7498     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
7499     PL_lex_op           = proto_perl->Ilex_op;
7500     PL_lex_inpat        = proto_perl->Ilex_inpat;
7501     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
7502     PL_lex_brackets     = proto_perl->Ilex_brackets;
7503     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7504     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
7505     PL_lex_casemods     = proto_perl->Ilex_casemods;
7506     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7507     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
7508
7509     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7510     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7511     PL_nexttoke         = proto_perl->Inexttoke;
7512
7513     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
7514     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7515     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7516     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7517     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7518     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7519     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7520     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7521     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7522     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7523     PL_pending_ident    = proto_perl->Ipending_ident;
7524     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
7525
7526     PL_expect           = proto_perl->Iexpect;
7527
7528     PL_multi_start      = proto_perl->Imulti_start;
7529     PL_multi_end        = proto_perl->Imulti_end;
7530     PL_multi_open       = proto_perl->Imulti_open;
7531     PL_multi_close      = proto_perl->Imulti_close;
7532
7533     PL_error_count      = proto_perl->Ierror_count;
7534     PL_subline          = proto_perl->Isubline;
7535     PL_subname          = sv_dup_inc(proto_perl->Isubname);
7536
7537     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
7538     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
7539     PL_padix                    = proto_perl->Ipadix;
7540     PL_padix_floor              = proto_perl->Ipadix_floor;
7541     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
7542
7543     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7544     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7545     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7546     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7547     PL_last_lop_op      = proto_perl->Ilast_lop_op;
7548     PL_in_my            = proto_perl->Iin_my;
7549     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
7550 #ifdef FCRYPT
7551     PL_cryptseen        = proto_perl->Icryptseen;
7552 #endif
7553
7554     PL_hints            = proto_perl->Ihints;
7555
7556     PL_amagic_generation        = proto_perl->Iamagic_generation;
7557
7558 #ifdef USE_LOCALE_COLLATE
7559     PL_collation_ix     = proto_perl->Icollation_ix;
7560     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
7561     PL_collation_standard       = proto_perl->Icollation_standard;
7562     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
7563     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
7564 #endif /* USE_LOCALE_COLLATE */
7565
7566 #ifdef USE_LOCALE_NUMERIC
7567     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
7568     PL_numeric_standard = proto_perl->Inumeric_standard;
7569     PL_numeric_local    = proto_perl->Inumeric_local;
7570     PL_numeric_radix    = proto_perl->Inumeric_radix;
7571 #endif /* !USE_LOCALE_NUMERIC */
7572
7573     /* utf8 character classes */
7574     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
7575     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
7576     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
7577     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
7578     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
7579     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
7580     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
7581     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
7582     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
7583     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
7584     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
7585     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
7586     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
7587     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
7588     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
7589     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
7590     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
7591
7592     /* swatch cache */
7593     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
7594     PL_last_swash_klen  = 0;
7595     PL_last_swash_key[0]= '\0';
7596     PL_last_swash_tmps  = (U8*)NULL;
7597     PL_last_swash_slen  = 0;
7598
7599     /* perly.c globals */
7600     PL_yydebug          = proto_perl->Iyydebug;
7601     PL_yynerrs          = proto_perl->Iyynerrs;
7602     PL_yyerrflag        = proto_perl->Iyyerrflag;
7603     PL_yychar           = proto_perl->Iyychar;
7604     PL_yyval            = proto_perl->Iyyval;
7605     PL_yylval           = proto_perl->Iyylval;
7606
7607     PL_glob_index       = proto_perl->Iglob_index;
7608     PL_srand_called     = proto_perl->Isrand_called;
7609     PL_uudmap['M']      = 0;            /* reinits on demand */
7610     PL_bitcount         = Nullch;       /* reinits on demand */
7611
7612     if (proto_perl->Ipsig_ptr) {
7613         int sig_num[] = { SIG_NUM };
7614         Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7615         Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7616         for (i = 1; PL_sig_name[i]; i++) {
7617             PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7618             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7619         }
7620     }
7621     else {
7622         PL_psig_ptr     = (SV**)NULL;
7623         PL_psig_name    = (SV**)NULL;
7624     }
7625
7626     /* thrdvar.h stuff */
7627
7628     if (flags & 1) {
7629         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7630         PL_tmps_ix              = proto_perl->Ttmps_ix;
7631         PL_tmps_max             = proto_perl->Ttmps_max;
7632         PL_tmps_floor           = proto_perl->Ttmps_floor;
7633         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7634         i = 0;
7635         while (i <= PL_tmps_ix) {
7636             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7637             ++i;
7638         }
7639
7640         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7641         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7642         Newz(54, PL_markstack, i, I32);
7643         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
7644                                                   - proto_perl->Tmarkstack);
7645         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
7646                                                   - proto_perl->Tmarkstack);
7647         Copy(proto_perl->Tmarkstack, PL_markstack,
7648              PL_markstack_ptr - PL_markstack + 1, I32);
7649
7650         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7651          * NOTE: unlike the others! */
7652         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
7653         PL_scopestack_max       = proto_perl->Tscopestack_max;
7654         Newz(54, PL_scopestack, PL_scopestack_max, I32);
7655         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7656
7657         /* next push_return() sets PL_retstack[PL_retstack_ix]
7658          * NOTE: unlike the others! */
7659         PL_retstack_ix          = proto_perl->Tretstack_ix;
7660         PL_retstack_max         = proto_perl->Tretstack_max;
7661         Newz(54, PL_retstack, PL_retstack_max, OP*);
7662         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7663
7664         /* NOTE: si_dup() looks at PL_markstack */
7665         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
7666
7667         /* PL_curstack          = PL_curstackinfo->si_stack; */
7668         PL_curstack             = av_dup(proto_perl->Tcurstack);
7669         PL_mainstack            = av_dup(proto_perl->Tmainstack);
7670
7671         /* next PUSHs() etc. set *(PL_stack_sp+1) */
7672         PL_stack_base           = AvARRAY(PL_curstack);
7673         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
7674                                                    - proto_perl->Tstack_base);
7675         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
7676
7677         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7678          * NOTE: unlike the others! */
7679         PL_savestack_ix         = proto_perl->Tsavestack_ix;
7680         PL_savestack_max        = proto_perl->Tsavestack_max;
7681         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7682         PL_savestack            = ss_dup(proto_perl);
7683     }
7684     else {
7685         init_stacks();
7686     }
7687
7688     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
7689     PL_top_env          = &PL_start_env;
7690
7691     PL_op               = proto_perl->Top;
7692
7693     PL_Sv               = Nullsv;
7694     PL_Xpv              = (XPV*)NULL;
7695     PL_na               = proto_perl->Tna;
7696
7697     PL_statbuf          = proto_perl->Tstatbuf;
7698     PL_statcache        = proto_perl->Tstatcache;
7699     PL_statgv           = gv_dup(proto_perl->Tstatgv);
7700     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
7701 #ifdef HAS_TIMES
7702     PL_timesbuf         = proto_perl->Ttimesbuf;
7703 #endif
7704
7705     PL_tainted          = proto_perl->Ttainted;
7706     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
7707     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
7708     PL_rs               = sv_dup_inc(proto_perl->Trs);
7709     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
7710     PL_ofslen           = proto_perl->Tofslen;
7711     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7712     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
7713     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
7714     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
7715     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
7716     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
7717
7718     PL_restartop        = proto_perl->Trestartop;
7719     PL_in_eval          = proto_perl->Tin_eval;
7720     PL_delaymagic       = proto_perl->Tdelaymagic;
7721     PL_dirty            = proto_perl->Tdirty;
7722     PL_localizing       = proto_perl->Tlocalizing;
7723
7724     PL_protect          = proto_perl->Tprotect;
7725     PL_errors           = sv_dup_inc(proto_perl->Terrors);
7726     PL_av_fetch_sv      = Nullsv;
7727     PL_hv_fetch_sv      = Nullsv;
7728     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
7729     PL_modcount         = proto_perl->Tmodcount;
7730     PL_lastgotoprobe    = Nullop;
7731     PL_dumpindent       = proto_perl->Tdumpindent;
7732
7733     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7734     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
7735     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
7736     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
7737     PL_sortcxix         = proto_perl->Tsortcxix;
7738     PL_efloatbuf        = Nullch;               /* reinits on demand */
7739     PL_efloatsize       = 0;                    /* reinits on demand */
7740
7741     /* regex stuff */
7742
7743     PL_screamfirst      = NULL;
7744     PL_screamnext       = NULL;
7745     PL_maxscream        = -1;                   /* reinits on demand */
7746     PL_lastscream       = Nullsv;
7747
7748     PL_watchaddr        = NULL;
7749     PL_watchok          = Nullch;
7750
7751     PL_regdummy         = proto_perl->Tregdummy;
7752     PL_regcomp_parse    = Nullch;
7753     PL_regxend          = Nullch;
7754     PL_regcode          = (regnode*)NULL;
7755     PL_regnaughty       = 0;
7756     PL_regsawback       = 0;
7757     PL_regprecomp       = Nullch;
7758     PL_regnpar          = 0;
7759     PL_regsize          = 0;
7760     PL_regflags         = 0;
7761     PL_regseen          = 0;
7762     PL_seen_zerolen     = 0;
7763     PL_seen_evals       = 0;
7764     PL_regcomp_rx       = (regexp*)NULL;
7765     PL_extralen         = 0;
7766     PL_colorset         = 0;            /* reinits PL_colors[] */
7767     /*PL_colors[6]      = {0,0,0,0,0,0};*/
7768     PL_reg_whilem_seen  = 0;
7769     PL_reginput         = Nullch;
7770     PL_regbol           = Nullch;
7771     PL_regeol           = Nullch;
7772     PL_regstartp        = (I32*)NULL;
7773     PL_regendp          = (I32*)NULL;
7774     PL_reglastparen     = (U32*)NULL;
7775     PL_regtill          = Nullch;
7776     PL_regprev          = '\n';
7777     PL_reg_start_tmp    = (char**)NULL;
7778     PL_reg_start_tmpl   = 0;
7779     PL_regdata          = (struct reg_data*)NULL;
7780     PL_bostr            = Nullch;
7781     PL_reg_flags        = 0;
7782     PL_reg_eval_set     = 0;
7783     PL_regnarrate       = 0;
7784     PL_regprogram       = (regnode*)NULL;
7785     PL_regindent        = 0;
7786     PL_regcc            = (CURCUR*)NULL;
7787     PL_reg_call_cc      = (struct re_cc_state*)NULL;
7788     PL_reg_re           = (regexp*)NULL;
7789     PL_reg_ganch        = Nullch;
7790     PL_reg_sv           = Nullsv;
7791     PL_reg_magic        = (MAGIC*)NULL;
7792     PL_reg_oldpos       = 0;
7793     PL_reg_oldcurpm     = (PMOP*)NULL;
7794     PL_reg_curpm        = (PMOP*)NULL;
7795     PL_reg_oldsaved     = Nullch;
7796     PL_reg_oldsavedlen  = 0;
7797     PL_reg_maxiter      = 0;
7798     PL_reg_leftiter     = 0;
7799     PL_reg_poscache     = Nullch;
7800     PL_reg_poscache_size= 0;
7801
7802     /* RE engine - function pointers */
7803     PL_regcompp         = proto_perl->Tregcompp;
7804     PL_regexecp         = proto_perl->Tregexecp;
7805     PL_regint_start     = proto_perl->Tregint_start;
7806     PL_regint_string    = proto_perl->Tregint_string;
7807     PL_regfree          = proto_perl->Tregfree;
7808
7809     PL_reginterp_cnt    = 0;
7810     PL_reg_starttry     = 0;
7811
7812 #ifdef PERL_OBJECT
7813     return (PerlInterpreter*)pPerl;
7814 #else
7815     return my_perl;
7816 #endif
7817 }
7818
7819 #else   /* !USE_ITHREADS */
7820
7821 #ifdef PERL_OBJECT
7822 #include "XSUB.h"
7823 #endif
7824
7825 #endif /* USE_ITHREADS */
7826
7827 static void
7828 do_report_used(pTHXo_ SV *sv)
7829 {
7830     if (SvTYPE(sv) != SVTYPEMASK) {
7831         PerlIO_printf(Perl_debug_log, "****\n");
7832         sv_dump(sv);
7833     }
7834 }
7835
7836 static void
7837 do_clean_objs(pTHXo_ SV *sv)
7838 {
7839     SV* rv;
7840
7841     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7842         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7843         SvROK_off(sv);
7844         SvRV(sv) = 0;
7845         SvREFCNT_dec(rv);
7846     }
7847
7848     /* XXX Might want to check arrays, etc. */
7849 }
7850
7851 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7852 static void
7853 do_clean_named_objs(pTHXo_ SV *sv)
7854 {
7855     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
7856         if ( SvOBJECT(GvSV(sv)) ||
7857              GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7858              GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7859              GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7860              GvCV(sv) && SvOBJECT(GvCV(sv)) )
7861         {
7862             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7863             SvREFCNT_dec(sv);
7864         }
7865     }
7866 }
7867 #endif
7868
7869 static void
7870 do_clean_all(pTHXo_ SV *sv)
7871 {
7872     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
7873     SvFLAGS(sv) |= SVf_BREAK;
7874     SvREFCNT_dec(sv);
7875 }
7876