sv.c

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