sv.c

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