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) = PL_curcop->cop_line;
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)) {
3322             PerlDir_close(IoDIRP(sv));
3323             IoDIRP(sv) = 0;
3324         }
3325         Safefree(IoTOP_NAME(sv));
3326         Safefree(IoFMT_NAME(sv));
3327         Safefree(IoBOTTOM_NAME(sv));
3328         /* FALL THROUGH */
3329     case SVt_PVBM:
3330         goto freescalar;
3331     case SVt_PVCV:
3332     case SVt_PVFM:
3333         cv_undef((CV*)sv);
3334         goto freescalar;
3335     case SVt_PVHV:
3336         hv_undef((HV*)sv);
3337         break;
3338     case SVt_PVAV:
3339         av_undef((AV*)sv);
3340         break;
3341     case SVt_PVLV:
3342         SvREFCNT_dec(LvTARG(sv));
3343         goto freescalar;
3344     case SVt_PVGV:
3345         gp_free((GV*)sv);
3346         Safefree(GvNAME(sv));
3347         /* cannot decrease stash refcount yet, as we might recursively delete
3348            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3349            of stash until current sv is completely gone.
3350            -- JohnPC, 27 Mar 1998 */
3351         stash = GvSTASH(sv);
3352         /* FALL THROUGH */
3353     case SVt_PVMG:
3354     case SVt_PVNV:
3355     case SVt_PVIV:
3356       freescalar:
3357         (void)SvOOK_off(sv);
3358         /* FALL THROUGH */
3359     case SVt_PV:
3360     case SVt_RV:
3361         if (SvROK(sv)) {
3362             if (SvWEAKREF(sv))
3363                 sv_del_backref(sv);
3364             else
3365                 SvREFCNT_dec(SvRV(sv));
3366         }
3367         else if (SvPVX(sv) && SvLEN(sv))
3368             Safefree(SvPVX(sv));
3369         break;
3370 /*
3371     case SVt_NV:
3372     case SVt_IV:
3373     case SVt_NULL:
3374         break;
3375 */
3376     }
3377
3378     switch (SvTYPE(sv)) {
3379     case SVt_NULL:
3380         break;
3381     case SVt_IV:
3382         del_XIV(SvANY(sv));
3383         break;
3384     case SVt_NV:
3385         del_XNV(SvANY(sv));
3386         break;
3387     case SVt_RV:
3388         del_XRV(SvANY(sv));
3389         break;
3390     case SVt_PV:
3391         del_XPV(SvANY(sv));
3392         break;
3393     case SVt_PVIV:
3394         del_XPVIV(SvANY(sv));
3395         break;
3396     case SVt_PVNV:
3397         del_XPVNV(SvANY(sv));
3398         break;
3399     case SVt_PVMG:
3400         del_XPVMG(SvANY(sv));
3401         break;
3402     case SVt_PVLV:
3403         del_XPVLV(SvANY(sv));
3404         break;
3405     case SVt_PVAV:
3406         del_XPVAV(SvANY(sv));
3407         break;
3408     case SVt_PVHV:
3409         del_XPVHV(SvANY(sv));
3410         break;
3411     case SVt_PVCV:
3412         del_XPVCV(SvANY(sv));
3413         break;
3414     case SVt_PVGV:
3415         del_XPVGV(SvANY(sv));
3416         /* code duplication for increased performance. */
3417         SvFLAGS(sv) &= SVf_BREAK;
3418         SvFLAGS(sv) |= SVTYPEMASK;
3419         /* decrease refcount of the stash that owns this GV, if any */
3420         if (stash)
3421             SvREFCNT_dec(stash);
3422         return; /* not break, SvFLAGS reset already happened */
3423     case SVt_PVBM:
3424         del_XPVBM(SvANY(sv));
3425         break;
3426     case SVt_PVFM:
3427         del_XPVFM(SvANY(sv));
3428         break;
3429     case SVt_PVIO:
3430         del_XPVIO(SvANY(sv));
3431         break;
3432     }
3433     SvFLAGS(sv) &= SVf_BREAK;
3434     SvFLAGS(sv) |= SVTYPEMASK;
3435 }
3436
3437 SV *
3438 Perl_sv_newref(pTHX_ SV *sv)
3439 {
3440     if (sv)
3441         ATOMIC_INC(SvREFCNT(sv));
3442     return sv;
3443 }
3444
3445 void
3446 Perl_sv_free(pTHX_ SV *sv)
3447 {
3448     dTHR;
3449     int refcount_is_zero;
3450
3451     if (!sv)
3452         return;
3453     if (SvREFCNT(sv) == 0) {
3454         if (SvFLAGS(sv) & SVf_BREAK)
3455             return;
3456         if (PL_in_clean_all) /* All is fair */
3457             return;
3458         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3459             /* make sure SvREFCNT(sv)==0 happens very seldom */
3460             SvREFCNT(sv) = (~(U32)0)/2;
3461             return;
3462         }
3463         if (ckWARN_d(WARN_INTERNAL))
3464             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3465         return;
3466     }
3467     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3468     if (!refcount_is_zero)
3469         return;
3470 #ifdef DEBUGGING
3471     if (SvTEMP(sv)) {
3472         if (ckWARN_d(WARN_DEBUGGING))
3473             Perl_warner(aTHX_ WARN_DEBUGGING,
3474                         "Attempt to free temp prematurely: SV 0x%"UVxf,
3475                         PTR2UV(sv));
3476         return;
3477     }
3478 #endif
3479     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3480         /* make sure SvREFCNT(sv)==0 happens very seldom */
3481         SvREFCNT(sv) = (~(U32)0)/2;
3482         return;
3483     }
3484     sv_clear(sv);
3485     if (! SvREFCNT(sv))
3486         del_SV(sv);
3487 }
3488
3489 STRLEN
3490 Perl_sv_len(pTHX_ register SV *sv)
3491 {
3492     char *junk;
3493     STRLEN len;
3494
3495     if (!sv)
3496         return 0;
3497
3498     if (SvGMAGICAL(sv))
3499         len = mg_length(sv);
3500     else
3501         junk = SvPV(sv, len);
3502     return len;
3503 }
3504
3505 STRLEN
3506 Perl_sv_len_utf8(pTHX_ register SV *sv)
3507 {
3508     U8 *s;
3509     U8 *send;
3510     STRLEN len;
3511
3512     if (!sv)
3513         return 0;
3514
3515 #ifdef NOTYET
3516     if (SvGMAGICAL(sv))
3517         len = mg_length(sv);
3518     else
3519 #endif
3520         s = (U8*)SvPV(sv, len);
3521     send = s + len;
3522     len = 0;
3523     while (s < send) {
3524         s += UTF8SKIP(s);
3525         len++;
3526     }
3527     return len;
3528 }
3529
3530 void
3531 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3532 {
3533     U8 *start;
3534     U8 *s;
3535     U8 *send;
3536     I32 uoffset = *offsetp;
3537     STRLEN len;
3538
3539     if (!sv)
3540         return;
3541
3542     start = s = (U8*)SvPV(sv, len);
3543     send = s + len;
3544     while (s < send && uoffset--)
3545         s += UTF8SKIP(s);
3546     if (s >= send)
3547         s = send;
3548     *offsetp = s - start;
3549     if (lenp) {
3550         I32 ulen = *lenp;
3551         start = s;
3552         while (s < send && ulen--)
3553             s += UTF8SKIP(s);
3554         if (s >= send)
3555             s = send;
3556         *lenp = s - start;
3557     }
3558     return;
3559 }
3560
3561 void
3562 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3563 {
3564     U8 *s;
3565     U8 *send;
3566     STRLEN len;
3567
3568     if (!sv)
3569         return;
3570
3571     s = (U8*)SvPV(sv, len);
3572     if (len < *offsetp)
3573         Perl_croak(aTHX_ "panic: bad byte offset");
3574     send = s + *offsetp;
3575     len = 0;
3576     while (s < send) {
3577         s += UTF8SKIP(s);
3578         ++len;
3579     }
3580     if (s != send) {
3581         dTHR;
3582         if (ckWARN_d(WARN_UTF8))
3583             Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3584         --len;
3585     }
3586     *offsetp = len;
3587     return;
3588 }
3589
3590 I32
3591 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3592 {
3593     char *pv1;
3594     STRLEN cur1;
3595     char *pv2;
3596     STRLEN cur2;
3597
3598     if (!str1) {
3599         pv1 = "";
3600         cur1 = 0;
3601     }
3602     else
3603         pv1 = SvPV(str1, cur1);
3604
3605     if (!str2)
3606         return !cur1;
3607     else
3608         pv2 = SvPV(str2, cur2);
3609
3610     if (cur1 != cur2)
3611         return 0;
3612
3613     return memEQ(pv1, pv2, cur1);
3614 }
3615
3616 I32
3617 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3618 {
3619     STRLEN cur1 = 0;
3620     char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3621     STRLEN cur2 = 0;
3622     char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3623     I32 retval;
3624
3625     if (!cur1)
3626         return cur2 ? -1 : 0;
3627
3628     if (!cur2)
3629         return 1;
3630
3631     retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3632
3633     if (retval)
3634         return retval < 0 ? -1 : 1;
3635
3636     if (cur1 == cur2)
3637         return 0;
3638     else
3639         return cur1 < cur2 ? -1 : 1;
3640 }
3641
3642 I32
3643 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3644 {
3645 #ifdef USE_LOCALE_COLLATE
3646
3647     char *pv1, *pv2;
3648     STRLEN len1, len2;
3649     I32 retval;
3650
3651     if (PL_collation_standard)
3652         goto raw_compare;
3653
3654     len1 = 0;
3655     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3656     len2 = 0;
3657     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3658
3659     if (!pv1 || !len1) {
3660         if (pv2 && len2)
3661             return -1;
3662         else
3663             goto raw_compare;
3664     }
3665     else {
3666         if (!pv2 || !len2)
3667             return 1;
3668     }
3669
3670     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3671
3672     if (retval)
3673         return retval < 0 ? -1 : 1;
3674
3675     /*
3676      * When the result of collation is equality, that doesn't mean
3677      * that there are no differences -- some locales exclude some
3678      * characters from consideration.  So to avoid false equalities,
3679      * we use the raw string as a tiebreaker.
3680      */
3681
3682   raw_compare:
3683     /* FALL THROUGH */
3684
3685 #endif /* USE_LOCALE_COLLATE */
3686
3687     return sv_cmp(sv1, sv2);
3688 }
3689
3690 #ifdef USE_LOCALE_COLLATE
3691 /*
3692  * Any scalar variable may carry an 'o' magic that contains the
3693  * scalar data of the variable transformed to such a format that
3694  * a normal memory comparison can be used to compare the data
3695  * according to the locale settings.
3696  */
3697 char *
3698 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3699 {
3700     MAGIC *mg;
3701
3702     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3703     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3704         char *s, *xf;
3705         STRLEN len, xlen;
3706
3707         if (mg)
3708             Safefree(mg->mg_ptr);
3709         s = SvPV(sv, len);
3710         if ((xf = mem_collxfrm(s, len, &xlen))) {
3711             if (SvREADONLY(sv)) {
3712                 SAVEFREEPV(xf);
3713                 *nxp = xlen;
3714                 return xf + sizeof(PL_collation_ix);
3715             }
3716             if (! mg) {
3717                 sv_magic(sv, 0, 'o', 0, 0);
3718                 mg = mg_find(sv, 'o');
3719                 assert(mg);
3720             }
3721             mg->mg_ptr = xf;
3722             mg->mg_len = xlen;
3723         }
3724         else {
3725             if (mg) {
3726                 mg->mg_ptr = NULL;
3727                 mg->mg_len = -1;
3728             }
3729         }
3730     }
3731     if (mg && mg->mg_ptr) {
3732         *nxp = mg->mg_len;
3733         return mg->mg_ptr + sizeof(PL_collation_ix);
3734     }
3735     else {
3736         *nxp = 0;
3737         return NULL;
3738     }
3739 }
3740
3741 #endif /* USE_LOCALE_COLLATE */
3742
3743 char *
3744 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3745 {
3746     dTHR;
3747     char *rsptr;
3748     STRLEN rslen;
3749     register STDCHAR rslast;
3750     register STDCHAR *bp;
3751     register I32 cnt;
3752     I32 i;
3753
3754     SV_CHECK_THINKFIRST(sv);
3755     (void)SvUPGRADE(sv, SVt_PV);
3756
3757     SvSCREAM_off(sv);
3758
3759     if (RsSNARF(PL_rs)) {
3760         rsptr = NULL;
3761         rslen = 0;
3762     }
3763     else if (RsRECORD(PL_rs)) {
3764       I32 recsize, bytesread;
3765       char *buffer;
3766
3767       /* Grab the size of the record we're getting */
3768       recsize = SvIV(SvRV(PL_rs));
3769       (void)SvPOK_only(sv);    /* Validate pointer */
3770       buffer = SvGROW(sv, recsize + 1);
3771       /* Go yank in */
3772 #ifdef VMS
3773       /* VMS wants read instead of fread, because fread doesn't respect */
3774       /* RMS record boundaries. This is not necessarily a good thing to be */
3775       /* doing, but we've got no other real choice */
3776       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3777 #else
3778       bytesread = PerlIO_read(fp, buffer, recsize);
3779 #endif
3780       SvCUR_set(sv, bytesread);
3781       buffer[bytesread] = '\0';
3782       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3783     }
3784     else if (RsPARA(PL_rs)) {
3785         rsptr = "\n\n";
3786         rslen = 2;
3787     }
3788     else
3789         rsptr = SvPV(PL_rs, rslen);
3790     rslast = rslen ? rsptr[rslen - 1] : '\0';
3791
3792     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
3793         do {                    /* to make sure file boundaries work right */
3794             if (PerlIO_eof(fp))
3795                 return 0;
3796             i = PerlIO_getc(fp);
3797             if (i != '\n') {
3798                 if (i == -1)
3799                     return 0;
3800                 PerlIO_ungetc(fp,i);
3801                 break;
3802             }
3803         } while (i != EOF);
3804     }
3805
3806     /* See if we know enough about I/O mechanism to cheat it ! */
3807
3808     /* This used to be #ifdef test - it is made run-time test for ease
3809        of abstracting out stdio interface. One call should be cheap
3810        enough here - and may even be a macro allowing compile
3811        time optimization.
3812      */
3813
3814     if (PerlIO_fast_gets(fp)) {
3815
3816     /*
3817      * We're going to steal some values from the stdio struct
3818      * and put EVERYTHING in the innermost loop into registers.
3819      */
3820     register STDCHAR *ptr;
3821     STRLEN bpx;
3822     I32 shortbuffered;
3823
3824 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3825     /* An ungetc()d char is handled separately from the regular
3826      * buffer, so we getc() it back out and stuff it in the buffer.
3827      */
3828     i = PerlIO_getc(fp);
3829     if (i == EOF) return 0;
3830     *(--((*fp)->_ptr)) = (unsigned char) i;
3831     (*fp)->_cnt++;
3832 #endif
3833
3834     /* Here is some breathtakingly efficient cheating */
3835
3836     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
3837     (void)SvPOK_only(sv);               /* validate pointer */
3838     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3839         if (cnt > 80 && SvLEN(sv) > append) {
3840             shortbuffered = cnt - SvLEN(sv) + append + 1;
3841             cnt -= shortbuffered;
3842         }
3843         else {
3844             shortbuffered = 0;
3845             /* remember that cnt can be negative */
3846             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3847         }
3848     }
3849     else
3850         shortbuffered = 0;
3851     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
3852     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3853     DEBUG_P(PerlIO_printf(Perl_debug_log,
3854         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3855     DEBUG_P(PerlIO_printf(Perl_debug_log,
3856         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3857                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3858                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3859     for (;;) {
3860       screamer:
3861         if (cnt > 0) {
3862             if (rslen) {
3863                 while (cnt > 0) {                    /* this     |  eat */
3864                     cnt--;
3865                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
3866                         goto thats_all_folks;        /* screams  |  sed :-) */
3867                 }
3868             }
3869             else {
3870                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
3871                 bp += cnt;                           /* screams  |  dust */
3872                 ptr += cnt;                          /* louder   |  sed :-) */
3873                 cnt = 0;
3874             }
3875         }
3876
3877         if (shortbuffered) {            /* oh well, must extend */
3878             cnt = shortbuffered;
3879             shortbuffered = 0;
3880             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3881             SvCUR_set(sv, bpx);
3882             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3883             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3884             continue;
3885         }
3886
3887         DEBUG_P(PerlIO_printf(Perl_debug_log,
3888                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3889                               PTR2UV(ptr),(long)cnt));
3890         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3891         DEBUG_P(PerlIO_printf(Perl_debug_log,
3892             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3893             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3894             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3895         /* This used to call 'filbuf' in stdio form, but as that behaves like
3896            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3897            another abstraction.  */
3898         i   = PerlIO_getc(fp);          /* get more characters */
3899         DEBUG_P(PerlIO_printf(Perl_debug_log,
3900             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3901             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3902             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3903         cnt = PerlIO_get_cnt(fp);
3904         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
3905         DEBUG_P(PerlIO_printf(Perl_debug_log,
3906             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3907
3908         if (i == EOF)                   /* all done for ever? */
3909             goto thats_really_all_folks;
3910
3911         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3912         SvCUR_set(sv, bpx);
3913         SvGROW(sv, bpx + cnt + 2);
3914         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3915
3916         *bp++ = i;                      /* store character from PerlIO_getc */
3917
3918         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
3919             goto thats_all_folks;
3920     }
3921
3922 thats_all_folks:
3923     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3924           memNE((char*)bp - rslen, rsptr, rslen))
3925         goto screamer;                          /* go back to the fray */
3926 thats_really_all_folks:
3927     if (shortbuffered)
3928         cnt += shortbuffered;
3929         DEBUG_P(PerlIO_printf(Perl_debug_log,
3930             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3931     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
3932     DEBUG_P(PerlIO_printf(Perl_debug_log,
3933         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3934         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3935         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3936     *bp = '\0';
3937     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
3938     DEBUG_P(PerlIO_printf(Perl_debug_log,
3939         "Screamer: done, len=%ld, string=|%.*s|\n",
3940         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3941     }
3942    else
3943     {
3944 #ifndef EPOC
3945        /*The big, slow, and stupid way */
3946         STDCHAR buf[8192];
3947 #else
3948         /* Need to work around EPOC SDK features          */
3949         /* On WINS: MS VC5 generates calls to _chkstk,    */
3950         /* if a `large' stack frame is allocated          */
3951         /* gcc on MARM does not generate calls like these */
3952         STDCHAR buf[1024];
3953 #endif
3954
3955 screamer2:
3956         if (rslen) {
3957             register STDCHAR *bpe = buf + sizeof(buf);
3958             bp = buf;
3959             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3960                 ; /* keep reading */
3961             cnt = bp - buf;
3962         }
3963         else {
3964             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3965             /* Accomodate broken VAXC compiler, which applies U8 cast to
3966              * both args of ?: operator, causing EOF to change into 255
3967              */
3968             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3969         }
3970
3971         if (append)
3972             sv_catpvn(sv, (char *) buf, cnt);
3973         else
3974             sv_setpvn(sv, (char *) buf, cnt);
3975
3976         if (i != EOF &&                 /* joy */
3977             (!rslen ||
3978              SvCUR(sv) < rslen ||
3979              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3980         {
3981             append = -1;
3982             /*
3983              * If we're reading from a TTY and we get a short read,
3984              * indicating that the user hit his EOF character, we need
3985              * to notice it now, because if we try to read from the TTY
3986              * again, the EOF condition will disappear.
3987              *
3988              * The comparison of cnt to sizeof(buf) is an optimization
3989              * that prevents unnecessary calls to feof().
3990              *
3991              * - jik 9/25/96
3992              */
3993             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3994                 goto screamer2;
3995         }
3996     }
3997
3998     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
3999         while (i != EOF) {      /* to make sure file boundaries work right */
4000             i = PerlIO_getc(fp);
4001             if (i != '\n') {
4002                 PerlIO_ungetc(fp,i);
4003                 break;
4004             }
4005         }
4006     }
4007
4008 #ifdef WIN32
4009     win32_strip_return(sv);
4010 #endif
4011
4012     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4013 }
4014
4015
4016 void
4017 Perl_sv_inc(pTHX_ register SV *sv)
4018 {
4019     register char *d;
4020     int flags;
4021
4022     if (!sv)
4023         return;
4024     if (SvGMAGICAL(sv))
4025         mg_get(sv);
4026     if (SvTHINKFIRST(sv)) {
4027         if (SvREADONLY(sv)) {
4028             dTHR;
4029             if (PL_curcop != &PL_compiling)
4030                 Perl_croak(aTHX_ PL_no_modify);
4031         }
4032         if (SvROK(sv)) {
4033             IV i;
4034             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4035                 return;
4036             i = PTR2IV(SvRV(sv));
4037             sv_unref(sv);
4038             sv_setiv(sv, i);
4039         }
4040     }
4041     flags = SvFLAGS(sv);
4042     if (flags & SVp_NOK) {
4043         (void)SvNOK_only(sv);
4044         SvNVX(sv) += 1.0;
4045         return;
4046     }
4047     if (flags & SVp_IOK) {
4048         if (SvIsUV(sv)) {
4049             if (SvUVX(sv) == UV_MAX)
4050                 sv_setnv(sv, (NV)UV_MAX + 1.0);
4051             else
4052                 (void)SvIOK_only_UV(sv);
4053                 ++SvUVX(sv);
4054         } else {
4055             if (SvIVX(sv) == IV_MAX)
4056                 sv_setnv(sv, (NV)IV_MAX + 1.0);
4057             else {
4058                 (void)SvIOK_only(sv);
4059                 ++SvIVX(sv);
4060             }
4061         }
4062         return;
4063     }
4064     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4065         if ((flags & SVTYPEMASK) < SVt_PVNV)
4066             sv_upgrade(sv, SVt_NV);
4067         SvNVX(sv) = 1.0;
4068         (void)SvNOK_only(sv);
4069         return;
4070     }
4071     d = SvPVX(sv);
4072     while (isALPHA(*d)) d++;
4073     while (isDIGIT(*d)) d++;
4074     if (*d) {
4075         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
4076         return;
4077     }
4078     d--;
4079     while (d >= SvPVX(sv)) {
4080         if (isDIGIT(*d)) {
4081             if (++*d <= '9')
4082                 return;
4083             *(d--) = '0';
4084         }
4085         else {
4086 #ifdef EBCDIC
4087             /* MKS: The original code here died if letters weren't consecutive.
4088              * at least it didn't have to worry about non-C locales.  The
4089              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4090              * arranged in order (although not consecutively) and that only
4091              * [A-Za-z] are accepted by isALPHA in the C locale.
4092              */
4093             if (*d != 'z' && *d != 'Z') {
4094                 do { ++*d; } while (!isALPHA(*d));
4095                 return;
4096             }
4097             *(d--) -= 'z' - 'a';
4098 #else
4099             ++*d;
4100             if (isALPHA(*d))
4101                 return;
4102             *(d--) -= 'z' - 'a' + 1;
4103 #endif
4104         }
4105     }
4106     /* oh,oh, the number grew */
4107     SvGROW(sv, SvCUR(sv) + 2);
4108     SvCUR(sv)++;
4109     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4110         *d = d[-1];
4111     if (isDIGIT(d[1]))
4112         *d = '1';
4113     else
4114         *d = d[1];
4115 }
4116
4117 void
4118 Perl_sv_dec(pTHX_ register SV *sv)
4119 {
4120     int flags;
4121
4122     if (!sv)
4123         return;
4124     if (SvGMAGICAL(sv))
4125         mg_get(sv);
4126     if (SvTHINKFIRST(sv)) {
4127         if (SvREADONLY(sv)) {
4128             dTHR;
4129             if (PL_curcop != &PL_compiling)
4130                 Perl_croak(aTHX_ PL_no_modify);
4131         }
4132         if (SvROK(sv)) {
4133             IV i;
4134             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4135                 return;
4136             i = PTR2IV(SvRV(sv));
4137             sv_unref(sv);
4138             sv_setiv(sv, i);
4139         }
4140     }
4141     flags = SvFLAGS(sv);
4142     if (flags & SVp_NOK) {
4143         SvNVX(sv) -= 1.0;
4144         (void)SvNOK_only(sv);
4145         return;
4146     }
4147     if (flags & SVp_IOK) {
4148         if (SvIsUV(sv)) {
4149             if (SvUVX(sv) == 0) {
4150                 (void)SvIOK_only(sv);
4151                 SvIVX(sv) = -1;
4152             }
4153             else {
4154                 (void)SvIOK_only_UV(sv);
4155                 --SvUVX(sv);
4156             }
4157         } else {
4158             if (SvIVX(sv) == IV_MIN)
4159                 sv_setnv(sv, (NV)IV_MIN - 1.0);
4160             else {
4161                 (void)SvIOK_only(sv);
4162                 --SvIVX(sv);
4163             }
4164         }
4165         return;
4166     }
4167     if (!(flags & SVp_POK)) {
4168         if ((flags & SVTYPEMASK) < SVt_PVNV)
4169             sv_upgrade(sv, SVt_NV);
4170         SvNVX(sv) = -1.0;
4171         (void)SvNOK_only(sv);
4172         return;
4173     }
4174     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4175 }
4176
4177 /* Make a string that will exist for the duration of the expression
4178  * evaluation.  Actually, it may have to last longer than that, but
4179  * hopefully we won't free it until it has been assigned to a
4180  * permanent location. */
4181
4182 SV *
4183 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4184 {
4185     dTHR;
4186     register SV *sv;
4187
4188     new_SV(sv);
4189     sv_setsv(sv,oldstr);
4190     EXTEND_MORTAL(1);
4191     PL_tmps_stack[++PL_tmps_ix] = sv;
4192     SvTEMP_on(sv);
4193     return sv;
4194 }
4195
4196 SV *
4197 Perl_sv_newmortal(pTHX)
4198 {
4199     dTHR;
4200     register SV *sv;
4201
4202     new_SV(sv);
4203     SvFLAGS(sv) = SVs_TEMP;
4204     EXTEND_MORTAL(1);
4205     PL_tmps_stack[++PL_tmps_ix] = sv;
4206     return sv;
4207 }
4208
4209 /* same thing without the copying */
4210
4211 SV *
4212 Perl_sv_2mortal(pTHX_ register SV *sv)
4213 {
4214     dTHR;
4215     if (!sv)
4216         return sv;
4217     if (SvREADONLY(sv) && SvIMMORTAL(sv))
4218         return sv;
4219     EXTEND_MORTAL(1);
4220     PL_tmps_stack[++PL_tmps_ix] = sv;
4221     SvTEMP_on(sv);
4222     return sv;
4223 }
4224
4225 SV *
4226 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4227 {
4228     register SV *sv;
4229
4230     new_SV(sv);
4231     if (!len)
4232         len = strlen(s);
4233     sv_setpvn(sv,s,len);
4234     return sv;
4235 }
4236
4237 SV *
4238 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4239 {
4240     register SV *sv;
4241
4242     new_SV(sv);
4243     sv_setpvn(sv,s,len);
4244     return sv;
4245 }
4246
4247 #if defined(PERL_IMPLICIT_CONTEXT)
4248 SV *
4249 Perl_newSVpvf_nocontext(const char* pat, ...)
4250 {
4251     dTHX;
4252     register SV *sv;
4253     va_list args;
4254     va_start(args, pat);
4255     sv = vnewSVpvf(pat, &args);
4256     va_end(args);
4257     return sv;
4258 }
4259 #endif
4260
4261 SV *
4262 Perl_newSVpvf(pTHX_ const char* pat, ...)
4263 {
4264     register SV *sv;
4265     va_list args;
4266     va_start(args, pat);
4267     sv = vnewSVpvf(pat, &args);
4268     va_end(args);
4269     return sv;
4270 }
4271
4272 SV *
4273 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4274 {
4275     register SV *sv;
4276     new_SV(sv);
4277     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4278     return sv;
4279 }
4280
4281 SV *
4282 Perl_newSVnv(pTHX_ NV n)
4283 {
4284     register SV *sv;
4285
4286     new_SV(sv);
4287     sv_setnv(sv,n);
4288     return sv;
4289 }
4290
4291 SV *
4292 Perl_newSViv(pTHX_ IV i)
4293 {
4294     register SV *sv;
4295
4296     new_SV(sv);
4297     sv_setiv(sv,i);
4298     return sv;
4299 }
4300
4301 SV *
4302 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4303 {
4304     dTHR;
4305     register SV *sv;
4306
4307     new_SV(sv);
4308     sv_upgrade(sv, SVt_RV);
4309     SvTEMP_off(tmpRef);
4310     SvRV(sv) = tmpRef;
4311     SvROK_on(sv);
4312     return sv;
4313 }
4314
4315 SV *
4316 Perl_newRV(pTHX_ SV *tmpRef)
4317 {
4318     return newRV_noinc(SvREFCNT_inc(tmpRef));
4319 }
4320
4321 /* make an exact duplicate of old */
4322
4323 SV *
4324 Perl_newSVsv(pTHX_ register SV *old)
4325 {
4326     dTHR;
4327     register SV *sv;
4328
4329     if (!old)
4330         return Nullsv;
4331     if (SvTYPE(old) == SVTYPEMASK) {
4332         if (ckWARN_d(WARN_INTERNAL))
4333             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4334         return Nullsv;
4335     }
4336     new_SV(sv);
4337     if (SvTEMP(old)) {
4338         SvTEMP_off(old);
4339         sv_setsv(sv,old);
4340         SvTEMP_on(old);
4341     }
4342     else
4343         sv_setsv(sv,old);
4344     return sv;
4345 }
4346
4347 void
4348 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4349 {
4350     register HE *entry;
4351     register GV *gv;
4352     register SV *sv;
4353     register I32 i;
4354     register PMOP *pm;
4355     register I32 max;
4356     char todo[PERL_UCHAR_MAX+1];
4357
4358     if (!stash)
4359         return;
4360
4361     if (!*s) {          /* reset ?? searches */
4362         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4363             pm->op_pmdynflags &= ~PMdf_USED;
4364         }
4365         return;
4366     }
4367
4368     /* reset variables */
4369
4370     if (!HvARRAY(stash))
4371         return;
4372
4373     Zero(todo, 256, char);
4374     while (*s) {
4375         i = (unsigned char)*s;
4376         if (s[1] == '-') {
4377             s += 2;
4378         }
4379         max = (unsigned char)*s++;
4380         for ( ; i <= max; i++) {
4381             todo[i] = 1;
4382         }
4383         for (i = 0; i <= (I32) HvMAX(stash); i++) {
4384             for (entry = HvARRAY(stash)[i];
4385                  entry;
4386                  entry = HeNEXT(entry))
4387             {
4388                 if (!todo[(U8)*HeKEY(entry)])
4389                     continue;
4390                 gv = (GV*)HeVAL(entry);
4391                 sv = GvSV(gv);
4392                 if (SvTHINKFIRST(sv)) {
4393                     if (!SvREADONLY(sv) && SvROK(sv))
4394                         sv_unref(sv);
4395                     continue;
4396                 }
4397                 (void)SvOK_off(sv);
4398                 if (SvTYPE(sv) >= SVt_PV) {
4399                     SvCUR_set(sv, 0);
4400                     if (SvPVX(sv) != Nullch)
4401                         *SvPVX(sv) = '\0';
4402                     SvTAINT(sv);
4403                 }
4404                 if (GvAV(gv)) {
4405                     av_clear(GvAV(gv));
4406                 }
4407                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4408                     hv_clear(GvHV(gv));
4409 #ifndef VMS  /* VMS has no environ array */
4410                     if (gv == PL_envgv)
4411                         environ[0] = Nullch;
4412 #endif
4413                 }
4414             }
4415         }
4416     }
4417 }
4418
4419 IO*
4420 Perl_sv_2io(pTHX_ SV *sv)
4421 {
4422     IO* io;
4423     GV* gv;
4424     STRLEN n_a;
4425
4426     switch (SvTYPE(sv)) {
4427     case SVt_PVIO:
4428         io = (IO*)sv;
4429         break;
4430     case SVt_PVGV:
4431         gv = (GV*)sv;
4432         io = GvIO(gv);
4433         if (!io)
4434             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4435         break;
4436     default:
4437         if (!SvOK(sv))
4438             Perl_croak(aTHX_ PL_no_usym, "filehandle");
4439         if (SvROK(sv))
4440             return sv_2io(SvRV(sv));
4441         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4442         if (gv)
4443             io = GvIO(gv);
4444         else
4445             io = 0;
4446         if (!io)
4447             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4448         break;
4449     }
4450     return io;
4451 }
4452
4453 CV *
4454 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4455 {
4456     GV *gv;
4457     CV *cv;
4458     STRLEN n_a;
4459
4460     if (!sv)
4461         return *gvp = Nullgv, Nullcv;
4462     switch (SvTYPE(sv)) {
4463     case SVt_PVCV:
4464         *st = CvSTASH(sv);
4465         *gvp = Nullgv;
4466         return (CV*)sv;
4467     case SVt_PVHV:
4468     case SVt_PVAV:
4469         *gvp = Nullgv;
4470         return Nullcv;
4471     case SVt_PVGV:
4472         gv = (GV*)sv;
4473         *gvp = gv;
4474         *st = GvESTASH(gv);
4475         goto fix_gv;
4476
4477     default:
4478         if (SvGMAGICAL(sv))
4479             mg_get(sv);
4480         if (SvROK(sv)) {
4481             dTHR;
4482             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
4483             tryAMAGICunDEREF(to_cv);
4484
4485             sv = SvRV(sv);
4486             if (SvTYPE(sv) == SVt_PVCV) {
4487                 cv = (CV*)sv;
4488                 *gvp = Nullgv;
4489                 *st = CvSTASH(cv);
4490                 return cv;
4491             }
4492             else if(isGV(sv))
4493                 gv = (GV*)sv;
4494             else
4495                 Perl_croak(aTHX_ "Not a subroutine reference");
4496         }
4497         else if (isGV(sv))
4498             gv = (GV*)sv;
4499         else
4500             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4501         *gvp = gv;
4502         if (!gv)
4503             return Nullcv;
4504         *st = GvESTASH(gv);
4505     fix_gv:
4506         if (lref && !GvCVu(gv)) {
4507             SV *tmpsv;
4508             ENTER;
4509             tmpsv = NEWSV(704,0);
4510             gv_efullname3(tmpsv, gv, Nullch);
4511             /* XXX this is probably not what they think they're getting.
4512              * It has the same effect as "sub name;", i.e. just a forward
4513              * declaration! */
4514             newSUB(start_subparse(FALSE, 0),
4515                    newSVOP(OP_CONST, 0, tmpsv),
4516                    Nullop,
4517                    Nullop);
4518             LEAVE;
4519             if (!GvCVu(gv))
4520                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4521         }
4522         return GvCVu(gv);
4523     }
4524 }
4525
4526 I32
4527 Perl_sv_true(pTHX_ register SV *sv)
4528 {
4529     dTHR;
4530     if (!sv)
4531         return 0;
4532     if (SvPOK(sv)) {
4533         register XPV* tXpv;
4534         if ((tXpv = (XPV*)SvANY(sv)) &&
4535                 (*tXpv->xpv_pv > '0' ||
4536                 tXpv->xpv_cur > 1 ||
4537                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4538             return 1;
4539         else
4540             return 0;
4541     }
4542     else {
4543         if (SvIOK(sv))
4544             return SvIVX(sv) != 0;
4545         else {
4546             if (SvNOK(sv))
4547                 return SvNVX(sv) != 0.0;
4548             else
4549                 return sv_2bool(sv);
4550         }
4551     }
4552 }
4553
4554 IV
4555 Perl_sv_iv(pTHX_ register SV *sv)
4556 {
4557     if (SvIOK(sv)) {
4558         if (SvIsUV(sv))
4559             return (IV)SvUVX(sv);
4560         return SvIVX(sv);
4561     }
4562     return sv_2iv(sv);
4563 }
4564
4565 UV
4566 Perl_sv_uv(pTHX_ register SV *sv)
4567 {
4568     if (SvIOK(sv)) {
4569         if (SvIsUV(sv))
4570             return SvUVX(sv);
4571         return (UV)SvIVX(sv);
4572     }
4573     return sv_2uv(sv);
4574 }
4575
4576 NV
4577 Perl_sv_nv(pTHX_ register SV *sv)
4578 {
4579     if (SvNOK(sv))
4580         return SvNVX(sv);
4581     return sv_2nv(sv);
4582 }
4583
4584 char *
4585 Perl_sv_pv(pTHX_ SV *sv)
4586 {
4587     STRLEN n_a;
4588
4589     if (SvPOK(sv))
4590         return SvPVX(sv);
4591
4592     return sv_2pv(sv, &n_a);
4593 }
4594
4595 char *
4596 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4597 {
4598     if (SvPOK(sv)) {
4599         *lp = SvCUR(sv);
4600         return SvPVX(sv);
4601     }
4602     return sv_2pv(sv, lp);
4603 }
4604
4605 char *
4606 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4607 {
4608     char *s;
4609
4610     if (SvTHINKFIRST(sv) && !SvROK(sv))
4611         sv_force_normal(sv);
4612
4613     if (SvPOK(sv)) {
4614         *lp = SvCUR(sv);
4615     }
4616     else {
4617         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4618             dTHR;
4619             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4620                 PL_op_name[PL_op->op_type]);
4621         }
4622         else
4623             s = sv_2pv(sv, lp);
4624         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
4625             STRLEN len = *lp;
4626
4627             if (SvROK(sv))
4628                 sv_unref(sv);
4629             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
4630             SvGROW(sv, len + 1);
4631             Move(s,SvPVX(sv),len,char);
4632             SvCUR_set(sv, len);
4633             *SvEND(sv) = '\0';
4634         }
4635         if (!SvPOK(sv)) {
4636             SvPOK_on(sv);               /* validate pointer */
4637             SvTAINT(sv);
4638             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4639                                   PTR2UV(sv),SvPVX(sv)));
4640         }
4641     }
4642     return SvPVX(sv);
4643 }
4644
4645 char *
4646 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4647 {
4648     if (ob && SvOBJECT(sv))
4649         return HvNAME(SvSTASH(sv));
4650     else {
4651         switch (SvTYPE(sv)) {
4652         case SVt_NULL:
4653         case SVt_IV:
4654         case SVt_NV:
4655         case SVt_RV:
4656         case SVt_PV:
4657         case SVt_PVIV:
4658         case SVt_PVNV:
4659         case SVt_PVMG:
4660         case SVt_PVBM:
4661                                 if (SvROK(sv))
4662                                     return "REF";
4663                                 else
4664                                     return "SCALAR";
4665         case SVt_PVLV:          return "LVALUE";
4666         case SVt_PVAV:          return "ARRAY";
4667         case SVt_PVHV:          return "HASH";
4668         case SVt_PVCV:          return "CODE";
4669         case SVt_PVGV:          return "GLOB";
4670         case SVt_PVFM:          return "FORMAT";
4671         default:                return "UNKNOWN";
4672         }
4673     }
4674 }
4675
4676 int
4677 Perl_sv_isobject(pTHX_ SV *sv)
4678 {
4679     if (!sv)
4680         return 0;
4681     if (SvGMAGICAL(sv))
4682         mg_get(sv);
4683     if (!SvROK(sv))
4684         return 0;
4685     sv = (SV*)SvRV(sv);
4686     if (!SvOBJECT(sv))
4687         return 0;
4688     return 1;
4689 }
4690
4691 int
4692 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4693 {
4694     if (!sv)
4695         return 0;
4696     if (SvGMAGICAL(sv))
4697         mg_get(sv);
4698     if (!SvROK(sv))
4699         return 0;
4700     sv = (SV*)SvRV(sv);
4701     if (!SvOBJECT(sv))
4702         return 0;
4703
4704     return strEQ(HvNAME(SvSTASH(sv)), name);
4705 }
4706
4707 SV*
4708 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4709 {
4710     dTHR;
4711     SV *sv;
4712
4713     new_SV(sv);
4714
4715     SV_CHECK_THINKFIRST(rv);
4716     SvAMAGIC_off(rv);
4717
4718     if (SvTYPE(rv) < SVt_RV)
4719       sv_upgrade(rv, SVt_RV);
4720
4721     (void)SvOK_off(rv);
4722     SvRV(rv) = sv;
4723     SvROK_on(rv);
4724
4725     if (classname) {
4726         HV* stash = gv_stashpv(classname, TRUE);
4727         (void)sv_bless(rv, stash);
4728     }
4729     return sv;
4730 }
4731
4732 SV*
4733 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4734 {
4735     if (!pv) {
4736         sv_setsv(rv, &PL_sv_undef);
4737         SvSETMAGIC(rv);
4738     }
4739     else
4740         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4741     return rv;
4742 }
4743
4744 SV*
4745 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4746 {
4747     sv_setiv(newSVrv(rv,classname), iv);
4748     return rv;
4749 }
4750
4751 SV*
4752 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4753 {
4754     sv_setnv(newSVrv(rv,classname), nv);
4755     return rv;
4756 }
4757
4758 SV*
4759 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4760 {
4761     sv_setpvn(newSVrv(rv,classname), pv, n);
4762     return rv;
4763 }
4764
4765 SV*
4766 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4767 {
4768     dTHR;
4769     SV *tmpRef;
4770     if (!SvROK(sv))
4771         Perl_croak(aTHX_ "Can't bless non-reference value");
4772     tmpRef = SvRV(sv);
4773     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4774         if (SvREADONLY(tmpRef))
4775             Perl_croak(aTHX_ PL_no_modify);
4776         if (SvOBJECT(tmpRef)) {
4777             if (SvTYPE(tmpRef) != SVt_PVIO)
4778                 --PL_sv_objcount;
4779             SvREFCNT_dec(SvSTASH(tmpRef));
4780         }
4781     }
4782     SvOBJECT_on(tmpRef);
4783     if (SvTYPE(tmpRef) != SVt_PVIO)
4784         ++PL_sv_objcount;
4785     (void)SvUPGRADE(tmpRef, SVt_PVMG);
4786     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4787
4788     if (Gv_AMG(stash))
4789         SvAMAGIC_on(sv);
4790     else
4791         SvAMAGIC_off(sv);
4792
4793     return sv;
4794 }
4795
4796 STATIC void
4797 S_sv_unglob(pTHX_ SV *sv)
4798 {
4799     assert(SvTYPE(sv) == SVt_PVGV);
4800     SvFAKE_off(sv);
4801     if (GvGP(sv))
4802         gp_free((GV*)sv);
4803     if (GvSTASH(sv)) {
4804         SvREFCNT_dec(GvSTASH(sv));
4805         GvSTASH(sv) = Nullhv;
4806     }
4807     sv_unmagic(sv, '*');
4808     Safefree(GvNAME(sv));
4809     GvMULTI_off(sv);
4810     SvFLAGS(sv) &= ~SVTYPEMASK;
4811     SvFLAGS(sv) |= SVt_PVMG;
4812 }
4813
4814 void
4815 Perl_sv_unref(pTHX_ SV *sv)
4816 {
4817     SV* rv = SvRV(sv);
4818
4819     if (SvWEAKREF(sv)) {
4820         sv_del_backref(sv);
4821         SvWEAKREF_off(sv);
4822         SvRV(sv) = 0;
4823         return;
4824     }
4825     SvRV(sv) = 0;
4826     SvROK_off(sv);
4827     if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4828         SvREFCNT_dec(rv);
4829     else
4830         sv_2mortal(rv);         /* Schedule for freeing later */
4831 }
4832
4833 void
4834 Perl_sv_taint(pTHX_ SV *sv)
4835 {
4836     sv_magic((sv), Nullsv, 't', Nullch, 0);
4837 }
4838
4839 void
4840 Perl_sv_untaint(pTHX_ SV *sv)
4841 {
4842     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4843         MAGIC *mg = mg_find(sv, 't');
4844         if (mg)
4845             mg->mg_len &= ~1;
4846     }
4847 }
4848
4849 bool
4850 Perl_sv_tainted(pTHX_ SV *sv)
4851 {
4852     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4853         MAGIC *mg = mg_find(sv, 't');
4854         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4855             return TRUE;
4856     }
4857     return FALSE;
4858 }
4859
4860 void
4861 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4862 {
4863     char buf[TYPE_CHARS(UV)];
4864     char *ebuf;
4865     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4866
4867     sv_setpvn(sv, ptr, ebuf - ptr);
4868 }
4869
4870
4871 void
4872 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4873 {
4874     char buf[TYPE_CHARS(UV)];
4875     char *ebuf;
4876     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4877
4878     sv_setpvn(sv, ptr, ebuf - ptr);
4879     SvSETMAGIC(sv);
4880 }
4881
4882 #if defined(PERL_IMPLICIT_CONTEXT)
4883 void
4884 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4885 {
4886     dTHX;
4887     va_list args;
4888     va_start(args, pat);
4889     sv_vsetpvf(sv, pat, &args);
4890     va_end(args);
4891 }
4892
4893
4894 void
4895 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4896 {
4897     dTHX;
4898     va_list args;
4899     va_start(args, pat);
4900     sv_vsetpvf_mg(sv, pat, &args);
4901     va_end(args);
4902 }
4903 #endif
4904
4905 void
4906 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4907 {
4908     va_list args;
4909     va_start(args, pat);
4910     sv_vsetpvf(sv, pat, &args);
4911     va_end(args);
4912 }
4913
4914 void
4915 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4916 {
4917     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4918 }
4919
4920 void
4921 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4922 {
4923     va_list args;
4924     va_start(args, pat);
4925     sv_vsetpvf_mg(sv, pat, &args);
4926     va_end(args);
4927 }
4928
4929 void
4930 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4931 {
4932     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4933     SvSETMAGIC(sv);
4934 }
4935
4936 #if defined(PERL_IMPLICIT_CONTEXT)
4937 void
4938 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4939 {
4940     dTHX;
4941     va_list args;
4942     va_start(args, pat);
4943     sv_vcatpvf(sv, pat, &args);
4944     va_end(args);
4945 }
4946
4947 void
4948 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4949 {
4950     dTHX;
4951     va_list args;
4952     va_start(args, pat);
4953     sv_vcatpvf_mg(sv, pat, &args);
4954     va_end(args);
4955 }
4956 #endif
4957
4958 void
4959 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4960 {
4961     va_list args;
4962     va_start(args, pat);
4963     sv_vcatpvf(sv, pat, &args);
4964     va_end(args);
4965 }
4966
4967 void
4968 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4969 {
4970     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4971 }
4972
4973 void
4974 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4975 {
4976     va_list args;
4977     va_start(args, pat);
4978     sv_vcatpvf_mg(sv, pat, &args);
4979     va_end(args);
4980 }
4981
4982 void
4983 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4984 {
4985     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4986     SvSETMAGIC(sv);
4987 }
4988
4989 void
4990 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
4991 {
4992     sv_setpvn(sv, "", 0);
4993     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
4994 }
4995
4996 void
4997 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
4998 {
4999     dTHR;
5000     char *p;
5001     char *q;
5002     char *patend;
5003     STRLEN origlen;
5004     I32 svix = 0;
5005     static char nullstr[] = "(null)";
5006
5007     /* no matter what, this is a string now */
5008     (void)SvPV_force(sv, origlen);
5009
5010     /* special-case "", "%s", and "%_" */
5011     if (patlen == 0)
5012         return;
5013     if (patlen == 2 && pat[0] == '%') {
5014         switch (pat[1]) {
5015         case 's':
5016             if (args) {
5017                 char *s = va_arg(*args, char*);
5018                 sv_catpv(sv, s ? s : nullstr);
5019             }
5020             else if (svix < svmax)
5021                 sv_catsv(sv, *svargs);
5022             return;
5023         case '_':
5024             if (args) {
5025                 sv_catsv(sv, va_arg(*args, SV*));
5026                 return;
5027             }
5028             /* See comment on '_' below */
5029             break;
5030         }
5031     }
5032
5033     patend = (char*)pat + patlen;
5034     for (p = (char*)pat; p < patend; p = q) {
5035         bool alt = FALSE;
5036         bool left = FALSE;
5037         char fill = ' ';
5038         char plus = 0;
5039         char intsize = 0;
5040         STRLEN width = 0;
5041         STRLEN zeros = 0;
5042         bool has_precis = FALSE;
5043         STRLEN precis = 0;
5044
5045         char esignbuf[4];
5046         U8 utf8buf[10];
5047         STRLEN esignlen = 0;
5048
5049         char *eptr = Nullch;
5050         STRLEN elen = 0;
5051         /* Times 4: a decimal digit takes more than 3 binary digits.
5052          * NV_DIG: mantissa takes than many decimal digits.
5053          * Plus 32: Playing safe. */
5054         char ebuf[IV_DIG * 4 + NV_DIG + 32];
5055         /* large enough for "%#.#f" --chip */
5056         /* what about long double NVs? --jhi */
5057         char c;
5058         int i;
5059         unsigned base;
5060         IV iv;
5061         UV uv;
5062         NV nv;
5063         STRLEN have;
5064         STRLEN need;
5065         STRLEN gap;
5066
5067         for (q = p; q < patend && *q != '%'; ++q) ;
5068         if (q > p) {
5069             sv_catpvn(sv, p, q - p);
5070             p = q;
5071         }
5072         if (q++ >= patend)
5073             break;
5074
5075         /* FLAGS */
5076
5077         while (*q) {
5078             switch (*q) {
5079             case ' ':
5080             case '+':
5081                 plus = *q++;
5082                 continue;
5083
5084             case '-':
5085                 left = TRUE;
5086                 q++;
5087                 continue;
5088
5089             case '0':
5090                 fill = *q++;
5091                 continue;
5092
5093             case '#':
5094                 alt = TRUE;
5095                 q++;
5096                 continue;
5097
5098             default:
5099                 break;
5100             }
5101             break;
5102         }
5103
5104         /* WIDTH */
5105
5106         switch (*q) {
5107         case '1': case '2': case '3':
5108         case '4': case '5': case '6':
5109         case '7': case '8': case '9':
5110             width = 0;
5111             while (isDIGIT(*q))
5112                 width = width * 10 + (*q++ - '0');
5113             break;
5114
5115         case '*':
5116             if (args)
5117                 i = va_arg(*args, int);
5118             else
5119                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5120             left |= (i < 0);
5121             width = (i < 0) ? -i : i;
5122             q++;
5123             break;
5124         }
5125
5126         /* PRECISION */
5127
5128         if (*q == '.') {
5129             q++;
5130             if (*q == '*') {
5131                 if (args)
5132                     i = va_arg(*args, int);
5133                 else
5134                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5135                 precis = (i < 0) ? 0 : i;
5136                 q++;
5137             }
5138             else {
5139                 precis = 0;
5140                 while (isDIGIT(*q))
5141                     precis = precis * 10 + (*q++ - '0');
5142             }
5143             has_precis = TRUE;
5144         }
5145
5146         /* SIZE */
5147
5148         switch (*q) {
5149 #ifdef Quad_t
5150         case 'L':                       /* Ld */
5151         case 'q':                       /* qd */
5152             intsize = 'q';
5153             q++;
5154             break;
5155 #endif
5156         case 'l':
5157 #ifdef Quad_t
5158              if (*(q + 1) == 'l') {     /* lld */
5159                 intsize = 'q';
5160                 q += 2;
5161                 break;
5162              }
5163 #endif
5164             /* FALL THROUGH */
5165         case 'h':
5166             /* FALL THROUGH */
5167         case 'V':
5168             intsize = *q++;
5169             break;
5170         }
5171
5172         /* CONVERSION */
5173
5174         switch (c = *q++) {
5175
5176             /* STRINGS */
5177
5178         case '%':
5179             eptr = q - 1;
5180             elen = 1;
5181             goto string;
5182
5183         case 'c':
5184             if (IN_UTF8) {
5185                 if (args)
5186                     uv = va_arg(*args, int);
5187                 else
5188                     uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5189
5190                 eptr = (char*)utf8buf;
5191                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5192                 goto string;
5193             }
5194             if (args)
5195                 c = va_arg(*args, int);
5196             else
5197                 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5198             eptr = &c;
5199             elen = 1;
5200             goto string;
5201
5202         case 's':
5203             if (args) {
5204                 eptr = va_arg(*args, char*);
5205                 if (eptr)
5206                     elen = strlen(eptr);
5207                 else {
5208                     eptr = nullstr;
5209                     elen = sizeof nullstr - 1;
5210                 }
5211             }
5212             else if (svix < svmax) {
5213                 eptr = SvPVx(svargs[svix++], elen);
5214                 if (IN_UTF8) {
5215                     if (has_precis && precis < elen) {
5216                         I32 p = precis;
5217                         sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5218                         precis = p;
5219                     }
5220                     if (width) { /* fudge width (can't fudge elen) */
5221                         width += elen - sv_len_utf8(svargs[svix - 1]);
5222                     }
5223                 }
5224             }
5225             goto string;
5226
5227         case '_':
5228             /*
5229              * The "%_" hack might have to be changed someday,
5230              * if ISO or ANSI decide to use '_' for something.
5231              * So we keep it hidden from users' code.
5232              */
5233             if (!args)
5234                 goto unknown;
5235             eptr = SvPVx(va_arg(*args, SV*), elen);
5236
5237         string:
5238             if (has_precis && elen > precis)
5239                 elen = precis;
5240             break;
5241
5242             /* INTEGERS */
5243
5244         case 'p':
5245             if (args)
5246                 uv = PTR2UV(va_arg(*args, void*));
5247             else
5248                 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5249             base = 16;
5250             goto integer;
5251
5252         case 'D':
5253 #ifdef IV_IS_QUAD
5254             intsize = 'q';
5255 #else
5256             intsize = 'l';
5257 #endif
5258             /* FALL THROUGH */
5259         case 'd':
5260         case 'i':
5261             if (args) {
5262                 switch (intsize) {
5263                 case 'h':       iv = (short)va_arg(*args, int); break;
5264                 default:        iv = va_arg(*args, int); break;
5265                 case 'l':       iv = va_arg(*args, long); break;
5266                 case 'V':       iv = va_arg(*args, IV); break;
5267 #ifdef Quad_t
5268                 case 'q':       iv = va_arg(*args, Quad_t); break;
5269 #endif
5270                 }
5271             }
5272             else {
5273                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5274                 switch (intsize) {
5275                 case 'h':       iv = (short)iv; break;
5276                 default:        iv = (int)iv; break;
5277                 case 'l':       iv = (long)iv; break;
5278                 case 'V':       break;
5279 #ifdef Quad_t
5280                 case 'q':       iv = (Quad_t)iv; break;
5281 #endif
5282                 }
5283             }
5284             if (iv >= 0) {
5285                 uv = iv;
5286                 if (plus)
5287                     esignbuf[esignlen++] = plus;
5288             }
5289             else {
5290                 uv = -iv;
5291                 esignbuf[esignlen++] = '-';
5292             }
5293             base = 10;
5294             goto integer;
5295
5296         case 'U':
5297 #ifdef IV_IS_QUAD
5298             intsize = 'q';
5299 #else
5300             intsize = 'l';
5301 #endif
5302             /* FALL THROUGH */
5303         case 'u':
5304             base = 10;
5305             goto uns_integer;
5306
5307         case 'b':
5308             base = 2;
5309             goto uns_integer;
5310
5311         case 'O':
5312 #ifdef IV_IS_QUAD
5313             intsize = 'q';
5314 #else
5315             intsize = 'l';
5316 #endif
5317             /* FALL THROUGH */
5318         case 'o':
5319             base = 8;
5320             goto uns_integer;
5321
5322         case 'X':
5323         case 'x':
5324             base = 16;
5325
5326         uns_integer:
5327             if (args) {
5328                 switch (intsize) {
5329                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
5330                 default:   uv = va_arg(*args, unsigned); break;
5331                 case 'l':  uv = va_arg(*args, unsigned long); break;
5332                 case 'V':  uv = va_arg(*args, UV); break;
5333 #ifdef Quad_t
5334                 case 'q':  uv = va_arg(*args, Quad_t); break;
5335 #endif
5336                 }
5337             }
5338             else {
5339                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5340                 switch (intsize) {
5341                 case 'h':       uv = (unsigned short)uv; break;
5342                 default:        uv = (unsigned)uv; break;
5343                 case 'l':       uv = (unsigned long)uv; break;
5344                 case 'V':       break;
5345 #ifdef Quad_t
5346                 case 'q':       uv = (Quad_t)uv; break;
5347 #endif
5348                 }
5349             }
5350
5351         integer:
5352             eptr = ebuf + sizeof ebuf;
5353             switch (base) {
5354                 unsigned dig;
5355             case 16:
5356                 if (!uv)
5357                     alt = FALSE;
5358                 p = (char*)((c == 'X')
5359                             ? "0123456789ABCDEF" : "0123456789abcdef");
5360                 do {
5361                     dig = uv & 15;
5362                     *--eptr = p[dig];
5363                 } while (uv >>= 4);
5364                 if (alt) {
5365                     esignbuf[esignlen++] = '0';
5366                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
5367                 }
5368                 break;
5369             case 8:
5370                 do {
5371                     dig = uv & 7;
5372                     *--eptr = '0' + dig;
5373                 } while (uv >>= 3);
5374                 if (alt && *eptr != '0')
5375                     *--eptr = '0';
5376                 break;
5377             case 2:
5378                 do {
5379                     dig = uv & 1;
5380                     *--eptr = '0' + dig;
5381                 } while (uv >>= 1);
5382                 if (alt) {
5383                     esignbuf[esignlen++] = '0';
5384                     esignbuf[esignlen++] = 'b';
5385                 }
5386                 break;
5387             default:            /* it had better be ten or less */
5388 #if defined(PERL_Y2KWARN)
5389                 if (ckWARN(WARN_MISC)) {
5390                     STRLEN n;
5391                     char *s = SvPV(sv,n);
5392                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5393                         && (n == 2 || !isDIGIT(s[n-3])))
5394                     {
5395                         Perl_warner(aTHX_ WARN_MISC,
5396                                     "Possible Y2K bug: %%%c %s",
5397                                     c, "format string following '19'");
5398                     }
5399                 }
5400 #endif
5401                 do {
5402                     dig = uv % base;
5403                     *--eptr = '0' + dig;
5404                 } while (uv /= base);
5405                 break;
5406             }
5407             elen = (ebuf + sizeof ebuf) - eptr;
5408             if (has_precis) {
5409                 if (precis > elen)
5410                     zeros = precis - elen;
5411                 else if (precis == 0 && elen == 1 && *eptr == '0')
5412                     elen = 0;
5413             }
5414             break;
5415
5416             /* FLOATING POINT */
5417
5418         case 'F':
5419             c = 'f';            /* maybe %F isn't supported here */
5420             /* FALL THROUGH */
5421         case 'e': case 'E':
5422         case 'f':
5423         case 'g': case 'G':
5424
5425             /* This is evil, but floating point is even more evil */
5426
5427             if (args)
5428                 nv = va_arg(*args, NV);
5429             else
5430                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5431
5432             need = 0;
5433             if (c != 'e' && c != 'E') {
5434                 i = PERL_INT_MIN;
5435                 (void)frexp(nv, &i);
5436                 if (i == PERL_INT_MIN)
5437                     Perl_die(aTHX_ "panic: frexp");
5438                 if (i > 0)
5439                     need = BIT_DIGITS(i);
5440             }
5441             need += has_precis ? precis : 6; /* known default */
5442             if (need < width)
5443                 need = width;
5444
5445             need += 20; /* fudge factor */
5446             if (PL_efloatsize < need) {
5447                 Safefree(PL_efloatbuf);
5448                 PL_efloatsize = need + 20; /* more fudge */
5449                 New(906, PL_efloatbuf, PL_efloatsize, char);
5450                 PL_efloatbuf[0] = '\0';
5451             }
5452
5453             eptr = ebuf + sizeof ebuf;
5454             *--eptr = '\0';
5455             *--eptr = c;
5456 #ifdef USE_LONG_DOUBLE
5457             {
5458                 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5459                 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5460             }
5461 #endif
5462             if (has_precis) {
5463                 base = precis;
5464                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5465                 *--eptr = '.';
5466             }
5467             if (width) {
5468                 base = width;
5469                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5470             }
5471             if (fill == '0')
5472                 *--eptr = fill;
5473             if (left)
5474                 *--eptr = '-';
5475             if (plus)
5476                 *--eptr = plus;
5477             if (alt)
5478                 *--eptr = '#';
5479             *--eptr = '%';
5480
5481             {
5482                 RESTORE_NUMERIC_STANDARD();
5483                 (void)sprintf(PL_efloatbuf, eptr, nv);
5484                 RESTORE_NUMERIC_LOCAL();
5485             }
5486
5487             eptr = PL_efloatbuf;
5488             elen = strlen(PL_efloatbuf);
5489             break;
5490
5491             /* SPECIAL */
5492
5493         case 'n':
5494             i = SvCUR(sv) - origlen;
5495             if (args) {
5496                 switch (intsize) {
5497                 case 'h':       *(va_arg(*args, short*)) = i; break;
5498                 default:        *(va_arg(*args, int*)) = i; break;
5499                 case 'l':       *(va_arg(*args, long*)) = i; break;
5500                 case 'V':       *(va_arg(*args, IV*)) = i; break;
5501 #ifdef Quad_t
5502                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
5503 #endif
5504                 }
5505             }
5506             else if (svix < svmax)
5507                 sv_setuv(svargs[svix++], (UV)i);
5508             continue;   /* not "break" */
5509
5510             /* UNKNOWN */
5511
5512         default:
5513       unknown:
5514             if (!args && ckWARN(WARN_PRINTF) &&
5515                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5516                 SV *msg = sv_newmortal();
5517                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5518                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5519                 if (c) {
5520                     if (isPRINT(c))
5521                         Perl_sv_catpvf(aTHX_ msg,
5522                                        "\"%%%c\"", c & 0xFF);
5523                     else
5524                         Perl_sv_catpvf(aTHX_ msg,
5525                                        "\"%%\\%03"UVof"\"",
5526                                        (UV)c & 0xFF);
5527                 } else
5528                     sv_catpv(msg, "end of string");
5529                 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5530             }
5531
5532             /* output mangled stuff ... */
5533             if (c == '\0')
5534                 --q;
5535             eptr = p;
5536             elen = q - p;
5537
5538             /* ... right here, because formatting flags should not apply */
5539             SvGROW(sv, SvCUR(sv) + elen + 1);
5540             p = SvEND(sv);
5541             memcpy(p, eptr, elen);
5542             p += elen;
5543             *p = '\0';
5544             SvCUR(sv) = p - SvPVX(sv);
5545             continue;   /* not "break" */
5546         }
5547
5548         have = esignlen + zeros + elen;
5549         need = (have > width ? have : width);
5550         gap = need - have;
5551
5552         SvGROW(sv, SvCUR(sv) + need + 1);
5553         p = SvEND(sv);
5554         if (esignlen && fill == '0') {
5555             for (i = 0; i < esignlen; i++)
5556                 *p++ = esignbuf[i];
5557         }
5558         if (gap && !left) {
5559             memset(p, fill, gap);
5560             p += gap;
5561         }
5562         if (esignlen && fill != '0') {
5563             for (i = 0; i < esignlen; i++)
5564                 *p++ = esignbuf[i];
5565         }
5566         if (zeros) {
5567             for (i = zeros; i; i--)
5568                 *p++ = '0';
5569         }
5570         if (elen) {
5571             memcpy(p, eptr, elen);
5572             p += elen;
5573         }
5574         if (gap && left) {
5575             memset(p, ' ', gap);
5576             p += gap;
5577         }
5578         *p = '\0';
5579         SvCUR(sv) = p - SvPVX(sv);
5580     }
5581 }
5582
5583 #if defined(USE_ITHREADS)
5584
5585 #if defined(USE_THREADS)
5586 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
5587 #endif
5588
5589 #ifndef OpREFCNT_inc
5590 #  define OpREFCNT_inc(o)       o
5591 #endif
5592
5593 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
5594 #define av_dup(s)       (AV*)sv_dup((SV*)s)
5595 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5596 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
5597 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5598 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
5599 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5600 #define io_dup(s)       (IO*)sv_dup((SV*)s)
5601 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5602 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
5603 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5604 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
5605 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
5606
5607 REGEXP *
5608 Perl_re_dup(pTHX_ REGEXP *r)
5609 {
5610     /* XXX fix when pmop->op_pmregexp becomes shared */
5611     return ReREFCNT_inc(r);
5612 }
5613
5614 PerlIO *
5615 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5616 {
5617     if (!fp)
5618         return (PerlIO*)NULL;
5619     return fp;          /* XXX */
5620     /* return PerlIO_fdopen(PerlIO_fileno(fp),
5621                          type == '<' ? "r" : type == '>' ? "w" : "rw"); */
5622 }
5623
5624 DIR *
5625 Perl_dirp_dup(pTHX_ DIR *dp)
5626 {
5627     if (!dp)
5628         return (DIR*)NULL;
5629     /* XXX TODO */
5630     return dp;
5631 }
5632
5633 GP *
5634 Perl_gp_dup(pTHX_ GP *gp)
5635 {
5636     GP *ret;
5637     if (!gp)
5638         return (GP*)NULL;
5639     Newz(0, ret, 1, GP);
5640     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
5641     ret->gp_io          = io_dup_inc(gp->gp_io);
5642     ret->gp_form        = cv_dup_inc(gp->gp_form);
5643     ret->gp_av          = av_dup_inc(gp->gp_av);
5644     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
5645     ret->gp_egv         = gv_dup_inc(gp->gp_egv);
5646     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
5647     ret->gp_cvgen       = gp->gp_cvgen;
5648     ret->gp_flags       = gp->gp_flags;
5649     ret->gp_line        = gp->gp_line;
5650     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
5651     ret->gp_refcnt      = 0;
5652     return ret;
5653 }
5654
5655 MAGIC *
5656 Perl_mg_dup(pTHX_ MAGIC *mg)
5657 {
5658     MAGIC *mgret = (MAGIC*)NULL;
5659     MAGIC *mgprev;
5660     if (!mg)
5661         return (MAGIC*)NULL;
5662     for (; mg; mg = mg->mg_moremagic) {
5663         MAGIC *nmg;
5664         Newz(0, nmg, 1, MAGIC);
5665         if (!mgret)
5666             mgret = nmg;
5667         else
5668             mgprev->mg_moremagic = nmg;
5669         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
5670         nmg->mg_private = mg->mg_private;
5671         nmg->mg_type    = mg->mg_type;
5672         nmg->mg_flags   = mg->mg_flags;
5673         if (mg->mg_type == 'r') {
5674             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5675         }
5676         else {
5677             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5678                               ? sv_dup_inc(mg->mg_obj)
5679                               : sv_dup(mg->mg_obj);
5680         }
5681         nmg->mg_len     = mg->mg_len;
5682         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
5683         if (mg->mg_ptr && mg->mg_type != 'g') {
5684             if (mg->mg_len >= 0)
5685                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
5686             else if (mg->mg_len == HEf_SVKEY)
5687                 nmg->mg_ptr     = (char*)sv_dup((SV*)mg->mg_ptr);
5688         }
5689         mgprev = nmg;
5690     }
5691     return mgret;
5692 }
5693
5694 SVTBL *
5695 Perl_sv_table_new(pTHX)
5696 {
5697     SVTBL *tbl;
5698     Newz(0, tbl, 1, SVTBL);
5699     tbl->tbl_max        = 511;
5700     tbl->tbl_items      = 0;
5701     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*);
5702     return tbl;
5703 }
5704
5705 SV *
5706 Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv)
5707 {
5708     SVTBLENT *tblent;
5709     UV hash = (UV)sv;
5710     assert(tbl);
5711     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5712     for (; tblent; tblent = tblent->next) {
5713         if (tblent->oldval == sv)
5714             return tblent->newval;
5715     }
5716     return Nullsv;
5717 }
5718
5719 void
5720 Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new)
5721 {
5722     SVTBLENT *tblent, **otblent;
5723     UV hash = (UV)old;
5724     bool i = 1;
5725     assert(tbl);
5726     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5727     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5728         if (tblent->oldval == old) {
5729             tblent->newval = new;
5730             tbl->tbl_items++;
5731             return;
5732         }
5733     }
5734     Newz(0, tblent, 1, SVTBLENT);
5735     tblent->oldval = old;
5736     tblent->newval = new;
5737     tblent->next = *otblent;
5738     *otblent = tblent;
5739     tbl->tbl_items++;
5740     if (i && tbl->tbl_items > tbl->tbl_max)
5741         sv_table_split(tbl);
5742 }
5743
5744 void
5745 Perl_sv_table_split(pTHX_ SVTBL *tbl)
5746 {
5747     SVTBLENT **ary = tbl->tbl_ary;
5748     UV oldsize = tbl->tbl_max + 1;
5749     UV newsize = oldsize * 2;
5750     UV i;
5751
5752     Renew(ary, newsize, SVTBLENT*);
5753     Zero(&ary[oldsize * sizeof(SVTBLENT*)], (newsize-oldsize) * sizeof(SVTBLENT*), char);
5754     tbl->tbl_max = --newsize;
5755     tbl->tbl_ary = ary;
5756     for (i=0; i < oldsize; i++, ary++) {
5757         SVTBLENT **curentp, **entp, *ent;
5758         if (!*ary)
5759             continue;
5760         curentp = ary + oldsize;
5761         for (entp = ary, ent = *ary; ent; ent = *entp) {
5762             if ((newsize & (UV)ent->oldval) != i) {
5763                 *entp = ent->next;
5764                 ent->next = *curentp;
5765                 *curentp = ent;
5766                 continue;
5767             }
5768             else
5769                 entp = &ent->next;
5770         }
5771     }
5772 }
5773
5774 SV *
5775 Perl_sv_dup(pTHX_ SV *sstr)
5776 {
5777     U32 sflags;
5778     int dtype;
5779     int stype;
5780     SV *dstr;
5781
5782     if (!sstr)
5783         return Nullsv;
5784     /* look for it in the table first */
5785     dstr = sv_table_fetch(PL_sv_table, sstr);
5786     if (dstr)
5787         return dstr;
5788
5789     /* XXX TODO: sanity-check sv_dup() vs sv_dup_inc() appropriateness */
5790
5791     /* create anew and remember what it is */
5792     new_SV(dstr);
5793     sv_table_store(PL_sv_table, sstr, dstr);
5794
5795     /* clone */
5796     SvFLAGS(dstr)       = SvFLAGS(sstr);
5797     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
5798     SvREFCNT(dstr)      = 0;
5799
5800     switch (SvTYPE(sstr)) {
5801     case SVt_NULL:
5802         SvANY(dstr)     = NULL;
5803         break;
5804     case SVt_IV:
5805         SvANY(dstr)     = new_XIV();
5806         SvIVX(dstr)     = SvIVX(sstr);
5807         break;
5808     case SVt_NV:
5809         SvANY(dstr)     = new_XNV();
5810         SvNVX(dstr)     = SvNVX(sstr);
5811         break;
5812     case SVt_RV:
5813         SvANY(dstr)     = new_XRV();
5814         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
5815         break;
5816     case SVt_PV:
5817         SvANY(dstr)     = new_XPV();
5818         SvCUR(dstr)     = SvCUR(sstr);
5819         SvLEN(dstr)     = SvLEN(sstr);
5820         if (SvPOKp(sstr) && SvLEN(sstr))
5821             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5822         else
5823             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5824         break;
5825     case SVt_PVIV:
5826         SvANY(dstr)     = new_XPVIV();
5827         SvCUR(dstr)     = SvCUR(sstr);
5828         SvLEN(dstr)     = SvLEN(sstr);
5829         SvIVX(dstr)     = SvIVX(sstr);
5830         if (SvPOKp(sstr) && SvLEN(sstr))
5831             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5832         else
5833             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5834         break;
5835     case SVt_PVNV:
5836         SvANY(dstr)     = new_XPVNV();
5837         SvCUR(dstr)     = SvCUR(sstr);
5838         SvLEN(dstr)     = SvLEN(sstr);
5839         SvIVX(dstr)     = SvIVX(sstr);
5840         SvNVX(dstr)     = SvNVX(sstr);
5841         if (SvPOKp(sstr) && SvLEN(sstr))
5842             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5843         else
5844             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5845         break;
5846     case SVt_PVMG:
5847         SvANY(dstr)     = new_XPVMG();
5848         SvCUR(dstr)     = SvCUR(sstr);
5849         SvLEN(dstr)     = SvLEN(sstr);
5850         SvIVX(dstr)     = SvIVX(sstr);
5851         SvNVX(dstr)     = SvNVX(sstr);
5852         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5853         if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5854             SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
5855         else
5856             SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
5857         if (SvPOKp(sstr) && SvLEN(sstr))
5858             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5859         else
5860             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5861         break;
5862     case SVt_PVBM:
5863         SvANY(dstr)     = new_XPVBM();
5864         SvCUR(dstr)     = SvCUR(sstr);
5865         SvLEN(dstr)     = SvLEN(sstr);
5866         SvIVX(dstr)     = SvIVX(sstr);
5867         SvNVX(dstr)     = SvNVX(sstr);
5868         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5869         if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5870             SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
5871         else
5872             SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
5873         if (SvPOKp(sstr) && SvLEN(sstr))
5874             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5875         else
5876             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5877         BmRARE(dstr)    = BmRARE(sstr);
5878         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
5879         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
5880         break;
5881     case SVt_PVLV:
5882         SvANY(dstr)     = new_XPVLV();
5883         SvCUR(dstr)     = SvCUR(sstr);
5884         SvLEN(dstr)     = SvLEN(sstr);
5885         SvIVX(dstr)     = SvIVX(sstr);
5886         SvNVX(dstr)     = SvNVX(sstr);
5887         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5888         if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5889             SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
5890         else
5891             SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
5892         if (SvPOKp(sstr) && SvLEN(sstr))
5893             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5894         else
5895             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5896         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
5897         LvTARGLEN(dstr) = LvTARGLEN(sstr);
5898         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
5899         LvTYPE(dstr)    = LvTYPE(sstr);
5900         break;
5901     case SVt_PVGV:
5902         SvANY(dstr)     = new_XPVGV();
5903         SvCUR(dstr)     = SvCUR(sstr);
5904         SvLEN(dstr)     = SvLEN(sstr);
5905         SvIVX(dstr)     = SvIVX(sstr);
5906         SvNVX(dstr)     = SvNVX(sstr);
5907         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5908         if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5909             SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
5910         else
5911             SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
5912         if (SvPOKp(sstr) && SvLEN(sstr))
5913             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5914         else
5915             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5916         GvNAMELEN(dstr) = GvNAMELEN(sstr);
5917         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
5918         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
5919         GvFLAGS(dstr)   = GvFLAGS(sstr);
5920         GvGP(dstr)      = gp_dup(GvGP(sstr));
5921         GvGP(dstr)->gp_refcnt++;
5922         break;
5923     case SVt_PVIO:
5924         SvANY(dstr)     = new_XPVIO();
5925         SvCUR(dstr)     = SvCUR(sstr);
5926         SvLEN(dstr)     = SvLEN(sstr);
5927         SvIVX(dstr)     = SvIVX(sstr);
5928         SvNVX(dstr)     = SvNVX(sstr);
5929         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5930         if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
5931             SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
5932         else
5933             SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
5934         if (SvPOKp(sstr) && SvLEN(sstr))
5935             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
5936         else
5937             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5938         IoIFP(dstr)             = fp_dup(IoIFP(sstr), IoTYPE(sstr));
5939         if (IoOFP(sstr) == IoIFP(sstr))
5940             IoOFP(dstr) = IoIFP(dstr);
5941         else
5942             IoOFP(dstr)         = fp_dup(IoOFP(sstr), IoTYPE(sstr));
5943         /* XXX PL_rsfp_filters entries have fake IoDIRP() */
5944         IoDIRP(dstr)            = dirp_dup(IoDIRP(sstr));
5945         IoLINES(dstr)           = IoLINES(sstr);
5946         IoPAGE(dstr)            = IoPAGE(sstr);
5947         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
5948         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
5949         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
5950         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
5951         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
5952         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
5953         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
5954         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
5955         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
5956         IoTYPE(dstr)            = IoTYPE(sstr);
5957         IoFLAGS(dstr)           = IoFLAGS(sstr);
5958         break;
5959     case SVt_PVAV:
5960         SvANY(dstr)     = new_XPVAV();
5961         SvCUR(dstr)     = SvCUR(sstr);
5962         SvLEN(dstr)     = SvLEN(sstr);
5963         SvIVX(dstr)     = SvIVX(sstr);
5964         SvNVX(dstr)     = SvNVX(sstr);
5965         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5966         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
5967         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
5968         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
5969         if (AvALLOC((AV*)sstr)) {
5970             SV **dst_ary, **src_ary;
5971             SSize_t items = AvFILLp((AV*)sstr) + 1;
5972
5973             src_ary = AvALLOC((AV*)sstr);
5974             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
5975             SvPVX(dstr) = (char*)dst_ary;
5976             AvALLOC((AV*)dstr) = dst_ary;
5977             if (AvREAL((AV*)sstr)) {
5978                 while (items-- > 0)
5979                     *dst_ary++ = sv_dup_inc(*src_ary++);
5980             }
5981             else {
5982                 while (items-- > 0)
5983                     *dst_ary++ = sv_dup(*src_ary++);
5984             }
5985             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
5986             while (items-- > 0) {
5987                 *dst_ary++ = &PL_sv_undef;
5988             }
5989         }
5990         else {
5991             SvPVX(dstr)         = Nullch;
5992             AvALLOC((AV*)dstr)  = (SV**)NULL;
5993         }
5994         break;
5995     case SVt_PVHV:
5996         SvANY(dstr)     = new_XPVHV();
5997         SvCUR(dstr)     = SvCUR(sstr);
5998         SvLEN(dstr)     = SvLEN(sstr);
5999         SvIVX(dstr)     = SvIVX(sstr);
6000         SvNVX(dstr)     = SvNVX(sstr);
6001         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6002         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6003         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
6004         if (HvARRAY((HV*)sstr)) {
6005             HE *entry;
6006             STRLEN i = 0;
6007             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6008             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6009             Newz(0, dxhv->xhv_array,
6010                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6011             while (i <= sxhv->xhv_max) {
6012                 HE *dentry, *oentry;
6013                 entry = ((HE**)sxhv->xhv_array)[i];
6014                 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6015                 ((HE**)dxhv->xhv_array)[i] = dentry;
6016                 while (entry) {
6017                     entry = HeNEXT(entry);
6018                     oentry = dentry;
6019                     dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6020                     HeNEXT(oentry) = dentry;
6021                 }
6022                 ++i;
6023             }
6024             if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) {
6025                 entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter];
6026                 while (entry && entry != sxhv->xhv_eiter)
6027                     entry = HeNEXT(entry);
6028                 dxhv->xhv_eiter = entry;
6029             }
6030             else
6031                 dxhv->xhv_eiter = (HE*)NULL;
6032         }
6033         else
6034             SvPVX(dstr)         = Nullch;
6035         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
6036         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
6037         break;
6038     case SVt_PVFM:
6039         SvANY(dstr)     = new_XPVFM();
6040         goto dup_pvcv;
6041         /* NOTREACHED */
6042     case SVt_PVCV:
6043         SvANY(dstr)     = new_XPVCV();
6044 dup_pvcv:
6045         SvCUR(dstr)     = SvCUR(sstr);
6046         SvLEN(dstr)     = SvLEN(sstr);
6047         SvIVX(dstr)     = SvIVX(sstr);
6048         SvNVX(dstr)     = SvNVX(sstr);
6049         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6050         if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
6051             SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
6052         else
6053             SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
6054         if (SvPOKp(sstr) && SvLEN(sstr))
6055             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
6056         else
6057             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6058         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6059         CvSTART(dstr)   = CvSTART(sstr);
6060         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
6061         CvXSUB(dstr)    = CvXSUB(sstr);
6062         CvXSUBANY(dstr) = CvXSUBANY(sstr);
6063         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
6064         CvDEPTH(dstr)   = CvDEPTH(sstr);
6065         CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6066         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6067         CvFLAGS(dstr)   = CvFLAGS(sstr);
6068         break;
6069     default:
6070         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6071         break;
6072     }
6073
6074     if (SvOBJECT(dstr))
6075         ++PL_sv_objcount;
6076
6077     return dstr;
6078 }
6079
6080 PerlInterpreter *
6081 perl_clone_using(PerlInterpreter *proto_perl, IV flags,
6082                  struct IPerlMem* ipM, struct IPerlEnv* ipE,
6083                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6084                  struct IPerlDir* ipD, struct IPerlSock* ipS,
6085                  struct IPerlProc* ipP)
6086 {
6087     IV i;
6088     SV *sv;
6089     SV **svp;
6090     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6091     PERL_SET_INTERP(my_perl);
6092
6093 #ifdef DEBUGGING
6094     memset(my_perl, 0xab, sizeof(PerlInterpreter));
6095     PL_markstack = 0;
6096     PL_scopestack = 0;
6097     PL_savestack = 0;
6098     PL_retstack = 0;
6099 #else
6100 #  if 0
6101     Copy(proto_perl, my_perl, 1, PerlInterpreter);
6102 #  endif
6103 #endif
6104
6105     /* XXX many of the string copies here can be optimized if they're
6106      * constants; they need to be allocated as common memory and just
6107      * their pointers copied. */
6108
6109     /* host pointers */
6110     PL_Mem              = ipM;
6111     PL_Env              = ipE;
6112     PL_StdIO            = ipStd;
6113     PL_LIO              = ipLIO;
6114     PL_Dir              = ipD;
6115     PL_Sock             = ipS;
6116     PL_Proc             = ipP;
6117
6118     /* arena roots */
6119     PL_xiv_arenaroot    = NULL;
6120     PL_xiv_root         = NULL;
6121     PL_xnv_root         = NULL;
6122     PL_xrv_root         = NULL;
6123     PL_xpv_root         = NULL;
6124     PL_xpviv_root       = NULL;
6125     PL_xpvnv_root       = NULL;
6126     PL_xpvcv_root       = NULL;
6127     PL_xpvav_root       = NULL;
6128     PL_xpvhv_root       = NULL;
6129     PL_xpvmg_root       = NULL;
6130     PL_xpvlv_root       = NULL;
6131     PL_xpvbm_root       = NULL;
6132     PL_he_root          = NULL;
6133     PL_nice_chunk       = NULL;
6134     PL_nice_chunk_size  = 0;
6135     PL_sv_count         = 0;
6136     PL_sv_objcount      = 0;
6137     PL_sv_root          = Nullsv;
6138     PL_sv_arenaroot     = Nullsv;
6139
6140     PL_debug            = proto_perl->Idebug;
6141
6142     /* create SV map for pointer relocation */
6143     PL_sv_table = sv_table_new();
6144
6145     /* initialize these special pointers as early as possible */
6146     SvANY(&PL_sv_undef)         = NULL;
6147     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
6148     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
6149     sv_table_store(PL_sv_table, &proto_perl->Isv_undef, &PL_sv_undef);
6150
6151     SvANY(&PL_sv_no)            = new_XPVNV();
6152     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
6153     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6154     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
6155     SvCUR(&PL_sv_no)            = 0;
6156     SvLEN(&PL_sv_no)            = 1;
6157     SvNVX(&PL_sv_no)            = 0;
6158     sv_table_store(PL_sv_table, &proto_perl->Isv_no, &PL_sv_no);
6159
6160     SvANY(&PL_sv_yes)           = new_XPVNV();
6161     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
6162     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6163     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
6164     SvCUR(&PL_sv_yes)           = 1;
6165     SvLEN(&PL_sv_yes)           = 2;
6166     SvNVX(&PL_sv_yes)           = 1;
6167     sv_table_store(PL_sv_table, &proto_perl->Isv_yes, &PL_sv_yes);
6168
6169     /* create shared string table */
6170     PL_strtab           = newHV();
6171     HvSHAREKEYS_off(PL_strtab);
6172     hv_ksplit(PL_strtab, 512);
6173     sv_table_store(PL_sv_table, (SV*)proto_perl->Istrtab, (SV*)PL_strtab);
6174
6175     PL_compiling                = proto_perl->Icompiling;
6176     PL_compiling.cop_stash      = hv_dup(PL_compiling.cop_stash);
6177     PL_compiling.cop_filegv     = gv_dup(PL_compiling.cop_filegv);
6178     PL_compiling.cop_warnings   = sv_dup_inc(PL_compiling.cop_warnings);
6179     if (proto_perl->Tcurcop == &proto_perl->Icompiling)
6180         PL_curcop       = &PL_compiling;
6181     else
6182         PL_curcop       = proto_perl->Tcurcop;
6183
6184     /* pseudo environmental stuff */
6185     PL_origargc         = proto_perl->Iorigargc;
6186     i = PL_origargc;
6187     New(0, PL_origargv, i+1, char*);
6188     PL_origargv[i] = '\0';
6189     while (i-- > 0) {
6190         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
6191     }
6192     PL_envgv            = gv_dup(proto_perl->Ienvgv);
6193     PL_incgv            = gv_dup(proto_perl->Iincgv);
6194     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
6195     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
6196     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
6197     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
6198
6199     /* switches */
6200     PL_minus_c          = proto_perl->Iminus_c;
6201     Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char);
6202     PL_localpatches     = proto_perl->Ilocalpatches;
6203     PL_splitstr         = proto_perl->Isplitstr;
6204     PL_preprocess       = proto_perl->Ipreprocess;
6205     PL_minus_n          = proto_perl->Iminus_n;
6206     PL_minus_p          = proto_perl->Iminus_p;
6207     PL_minus_l          = proto_perl->Iminus_l;
6208     PL_minus_a          = proto_perl->Iminus_a;
6209     PL_minus_F          = proto_perl->Iminus_F;
6210     PL_doswitches       = proto_perl->Idoswitches;
6211     PL_dowarn           = proto_perl->Idowarn;
6212     PL_doextract        = proto_perl->Idoextract;
6213     PL_sawampersand     = proto_perl->Isawampersand;
6214     PL_unsafe           = proto_perl->Iunsafe;
6215     PL_inplace          = SAVEPV(proto_perl->Iinplace);
6216     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
6217     PL_perldb           = proto_perl->Iperldb;
6218     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6219
6220     /* magical thingies */
6221     /* XXX time(&PL_basetime) instead? */
6222     PL_basetime         = proto_perl->Ibasetime;
6223     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
6224
6225     PL_maxsysfd         = proto_perl->Imaxsysfd;
6226     PL_multiline        = proto_perl->Imultiline;
6227     PL_statusvalue      = proto_perl->Istatusvalue;
6228 #ifdef VMS
6229     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
6230 #endif
6231
6232     /* shortcuts to various I/O objects */
6233     PL_stdingv          = gv_dup(proto_perl->Istdingv);
6234     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
6235     PL_defgv            = gv_dup(proto_perl->Idefgv);
6236     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
6237     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
6238     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
6239
6240     /* shortcuts to regexp stuff */
6241     PL_replgv           = gv_dup(proto_perl->Ireplgv);
6242
6243     /* shortcuts to misc objects */
6244     PL_errgv            = gv_dup(proto_perl->Ierrgv);
6245
6246     /* shortcuts to debugging objects */
6247     PL_DBgv             = gv_dup(proto_perl->IDBgv);
6248     PL_DBline           = gv_dup(proto_perl->IDBline);
6249     PL_DBsub            = gv_dup(proto_perl->IDBsub);
6250     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
6251     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
6252     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
6253     PL_lineary          = av_dup(proto_perl->Ilineary);
6254     PL_dbargs           = av_dup(proto_perl->Idbargs);
6255
6256     /* symbol tables */
6257     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
6258     PL_curstash         = hv_dup(proto_perl->Tcurstash);
6259     PL_debstash         = hv_dup(proto_perl->Idebstash);
6260     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
6261     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
6262
6263     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
6264     PL_endav            = av_dup_inc(proto_perl->Iendav);
6265     PL_stopav           = av_dup_inc(proto_perl->Istopav);
6266     PL_initav           = av_dup_inc(proto_perl->Iinitav);
6267
6268     PL_sub_generation   = proto_perl->Isub_generation;
6269
6270     /* funky return mechanisms */
6271     PL_forkprocess      = proto_perl->Iforkprocess;
6272
6273     /* subprocess state */
6274     PL_fdpid            = av_dup(proto_perl->Ifdpid);
6275
6276     /* internal state */
6277     PL_tainting         = proto_perl->Itainting;
6278     PL_maxo             = proto_perl->Imaxo;
6279     if (proto_perl->Iop_mask)
6280         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6281     else
6282         PL_op_mask      = Nullch;
6283
6284     /* current interpreter roots */
6285     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
6286     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
6287     PL_main_start       = proto_perl->Imain_start;
6288     PL_eval_root        = proto_perl->Ieval_root;
6289     PL_eval_start       = proto_perl->Ieval_start;
6290
6291     /* runtime control stuff */
6292     PL_curcopdb         = proto_perl->Icurcopdb;
6293     PL_copline          = proto_perl->Icopline;
6294
6295     PL_filemode         = proto_perl->Ifilemode;
6296     PL_lastfd           = proto_perl->Ilastfd;
6297     PL_oldname          = proto_perl->Ioldname; /* XXX */
6298     PL_Argv             = NULL;
6299     PL_Cmd              = Nullch;
6300     PL_gensym           = proto_perl->Igensym;
6301     PL_preambled        = proto_perl->Ipreambled;
6302     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
6303     PL_laststatval      = proto_perl->Ilaststatval;
6304     PL_laststype        = proto_perl->Ilaststype;
6305     PL_mess_sv          = Nullsv;
6306
6307     PL_orslen           = proto_perl->Iorslen;
6308     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
6309     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
6310
6311     /* interpreter atexit processing */
6312     PL_exitlistlen      = proto_perl->Iexitlistlen;
6313     if (PL_exitlistlen) {
6314         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6315         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6316     }
6317     else
6318         PL_exitlist     = (PerlExitListEntry*)NULL;
6319     PL_modglobal        = hv_dup(proto_perl->Imodglobal);
6320
6321     PL_profiledata      = NULL;                 /* XXX */
6322     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
6323     /* XXX PL_rsfp_filters entries have fake IoDIRP() */
6324     PL_rsfp_filters     = av_dup(proto_perl->Irsfp_filters);
6325
6326     PL_compcv                   = cv_dup(proto_perl->Icompcv);
6327     PL_comppad                  = av_dup(proto_perl->Icomppad);
6328     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
6329     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
6330     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
6331     PL_curpad                   = AvARRAY(PL_comppad);  /* XXX */
6332
6333 #ifdef HAVE_INTERP_INTERN
6334     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6335 #endif
6336
6337     /* more statics moved here */
6338     PL_generation       = proto_perl->Igeneration;
6339     PL_DBcv             = cv_dup(proto_perl->IDBcv);
6340     PL_archpat_auto     = SAVEPV(proto_perl->Iarchpat_auto);
6341
6342     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
6343     PL_in_clean_all     = proto_perl->Iin_clean_all;
6344
6345     PL_uid              = proto_perl->Iuid;
6346     PL_euid             = proto_perl->Ieuid;
6347     PL_gid              = proto_perl->Igid;
6348     PL_egid             = proto_perl->Iegid;
6349     PL_nomemok          = proto_perl->Inomemok;
6350     PL_an               = proto_perl->Ian;
6351     PL_cop_seqmax       = proto_perl->Icop_seqmax;
6352     PL_op_seqmax        = proto_perl->Iop_seqmax;
6353     PL_evalseq          = proto_perl->Ievalseq;
6354     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX */
6355     PL_origalen         = proto_perl->Iorigalen;
6356     PL_pidstatus        = newHV();
6357     PL_osname           = SAVEPV(proto_perl->Iosname);
6358     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
6359     PL_sighandlerp      = proto_perl->Isighandlerp;
6360
6361
6362     PL_runops           = proto_perl->Irunops;
6363
6364     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);        /* XXX */
6365
6366 #ifdef CSH
6367     PL_cshlen           = proto_perl->Icshlen;
6368     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6369 #endif
6370
6371     PL_lex_state        = proto_perl->Ilex_state;
6372     PL_lex_defer        = proto_perl->Ilex_defer;
6373     PL_lex_expect       = proto_perl->Ilex_expect;
6374     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
6375     PL_lex_fakebrack    = proto_perl->Ilex_fakebrack;
6376     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
6377     PL_lex_starts       = proto_perl->Ilex_starts;
6378     PL_lex_stuff        = Nullsv;               /* XXX */
6379     PL_lex_repl         = Nullsv;               /* XXX */
6380     PL_lex_op           = proto_perl->Ilex_op;
6381     PL_lex_inpat        = proto_perl->Ilex_inpat;
6382     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
6383     PL_lex_brackets     = proto_perl->Ilex_brackets;
6384     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6385     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
6386     PL_lex_casemods     = proto_perl->Ilex_casemods;
6387     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6388     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
6389
6390     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6391     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6392     PL_nexttoke         = proto_perl->Inexttoke;
6393
6394     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
6395     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6396     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6397     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6398     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6399     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6400     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6401     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6402     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6403     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6404     PL_pending_ident    = proto_perl->Ipending_ident;
6405     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX */
6406
6407     PL_expect           = proto_perl->Iexpect;
6408
6409     PL_multi_start      = proto_perl->Imulti_start;
6410     PL_multi_end        = proto_perl->Imulti_end;
6411     PL_multi_open       = proto_perl->Imulti_open;
6412     PL_multi_close      = proto_perl->Imulti_close;
6413
6414     PL_error_count      = proto_perl->Ierror_count;
6415     PL_subline          = proto_perl->Isubline;
6416     PL_subname          = sv_dup_inc(proto_perl->Isubname);
6417
6418     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
6419     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
6420     PL_padix                    = proto_perl->Ipadix;
6421     PL_padix_floor              = proto_perl->Ipadix_floor;
6422     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
6423
6424     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6425     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6426     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6427     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6428     PL_last_lop_op      = proto_perl->Ilast_lop_op;
6429     PL_in_my            = proto_perl->Iin_my;
6430     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
6431 #ifdef FCRYPT
6432     PL_cryptseen        = proto_perl->Icryptseen;
6433 #endif
6434
6435     PL_hints            = proto_perl->Ihints;
6436
6437     PL_amagic_generation        = proto_perl->Iamagic_generation;
6438
6439 #ifdef USE_LOCALE_COLLATE
6440     PL_collation_ix     = proto_perl->Icollation_ix;
6441     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
6442     PL_collation_standard       = proto_perl->Icollation_standard;
6443     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
6444     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
6445 #endif /* USE_LOCALE_COLLATE */
6446
6447 #ifdef USE_LOCALE_NUMERIC
6448     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
6449     PL_numeric_standard = proto_perl->Inumeric_standard;
6450     PL_numeric_local    = proto_perl->Inumeric_local;
6451     PL_numeric_radix    = proto_perl->Inumeric_radix;
6452 #endif /* !USE_LOCALE_NUMERIC */
6453
6454     /* utf8 character classes */
6455     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
6456     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
6457     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
6458     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
6459     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
6460     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
6461     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
6462     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
6463     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
6464     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
6465     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
6466     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
6467     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
6468     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
6469     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
6470     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
6471     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
6472
6473     /* swatch cache */
6474     PL_last_swash_hv    = Nullhv;       /* XXX recreate swatch cache? */
6475     PL_last_swash_klen  = 0;
6476     PL_last_swash_key[0]= '\0';
6477     PL_last_swash_tmps  = Nullch;
6478     PL_last_swash_slen  = 0;
6479
6480     /* perly.c globals */
6481     PL_yydebug          = proto_perl->Iyydebug;
6482     PL_yynerrs          = proto_perl->Iyynerrs;
6483     PL_yyerrflag        = proto_perl->Iyyerrflag;
6484     PL_yychar           = proto_perl->Iyychar;
6485     PL_yyval            = proto_perl->Iyyval;
6486     PL_yylval           = proto_perl->Iyylval;
6487
6488     PL_glob_index       = proto_perl->Iglob_index;
6489     PL_srand_called     = proto_perl->Isrand_called;
6490     PL_uudmap['M']      = 0;            /* reinit on demand */
6491     PL_bitcount         = Nullch;       /* reinit on demand */
6492
6493
6494     /* thrdvar.h stuff */
6495
6496 /*    PL_curstackinfo   = clone_stackinfo(proto_perl->Tcurstackinfo);
6497     clone_stacks();
6498     PL_mainstack        = av_dup(proto_perl->Tmainstack);
6499     PL_curstack         = av_dup(proto_perl->Tcurstack);*/      /* XXXXXX */
6500     init_stacks();
6501
6502     PL_op               = proto_perl->Top;
6503     PL_statbuf          = proto_perl->Tstatbuf;
6504     PL_statcache        = proto_perl->Tstatcache;
6505     PL_statgv           = gv_dup(proto_perl->Tstatgv);
6506     PL_statname         = sv_dup(proto_perl->Tstatname);
6507 #ifdef HAS_TIMES
6508     PL_timesbuf         = proto_perl->Ttimesbuf;
6509 #endif
6510
6511     PL_tainted          = proto_perl->Ttainted;
6512     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
6513     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
6514     PL_rs               = sv_dup_inc(proto_perl->Trs);
6515     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
6516     PL_ofslen           = proto_perl->Tofslen;
6517     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
6518     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
6519     PL_chopset          = proto_perl->Tchopset;
6520     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
6521     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
6522     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
6523
6524     PL_restartop        = proto_perl->Trestartop;
6525     PL_in_eval          = proto_perl->Tin_eval;
6526     PL_delaymagic       = proto_perl->Tdelaymagic;
6527     PL_dirty            = proto_perl->Tdirty;
6528     PL_localizing       = proto_perl->Tlocalizing;
6529
6530     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
6531     PL_top_env          = &PL_start_env;
6532     PL_protect          = proto_perl->Tprotect;
6533     PL_errors           = sv_dup_inc(proto_perl->Terrors);
6534     PL_av_fetch_sv      = Nullsv;
6535     PL_hv_fetch_sv      = Nullsv;
6536     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
6537     PL_modcount         = proto_perl->Tmodcount;
6538     PL_lastgotoprobe    = Nullop;
6539     PL_dumpindent       = proto_perl->Tdumpindent;
6540     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
6541     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
6542     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
6543     PL_sortcxix         = proto_perl->Tsortcxix;
6544     PL_efloatbuf        = Nullch;
6545     PL_efloatsize       = 0;
6546
6547     PL_screamfirst      = NULL;
6548     PL_screamnext       = NULL;
6549     PL_maxscream        = -1;
6550     PL_lastscream       = Nullsv;
6551
6552     /* RE engine - function pointers */
6553     PL_regcompp         = proto_perl->Tregcompp;
6554     PL_regexecp         = proto_perl->Tregexecp;
6555     PL_regint_start     = proto_perl->Tregint_start;
6556     PL_regint_string    = proto_perl->Tregint_string;
6557     PL_regfree          = proto_perl->Tregfree;
6558
6559     PL_regindent        = 0;
6560     PL_reginterp_cnt    = 0;
6561     PL_reg_start_tmp    = 0;
6562     PL_reg_start_tmpl   = 0;
6563     PL_reg_poscache     = Nullch;
6564
6565     PL_watchaddr        = NULL;
6566     PL_watchok          = Nullch;
6567
6568     return my_perl;
6569 }
6570
6571 PerlInterpreter *
6572 perl_clone(pTHXx_ IV flags)
6573 {
6574     return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO,
6575                             PL_Dir, PL_Sock, PL_Proc);
6576 }
6577
6578 #endif /* USE_ITHREADS */
6579
6580 #ifdef PERL_OBJECT
6581 #include "XSUB.h"
6582 #endif
6583
6584 static void
6585 do_report_used(pTHXo_ SV *sv)
6586 {
6587     if (SvTYPE(sv) != SVTYPEMASK) {
6588         PerlIO_printf(Perl_debug_log, "****\n");
6589         sv_dump(sv);
6590     }
6591 }
6592
6593 static void
6594 do_clean_objs(pTHXo_ SV *sv)
6595 {
6596     SV* rv;
6597
6598     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
6599         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
6600         SvROK_off(sv);
6601         SvRV(sv) = 0;
6602         SvREFCNT_dec(rv);
6603     }
6604
6605     /* XXX Might want to check arrays, etc. */
6606 }
6607
6608 #ifndef DISABLE_DESTRUCTOR_KLUDGE
6609 static void
6610 do_clean_named_objs(pTHXo_ SV *sv)
6611 {
6612     if (SvTYPE(sv) == SVt_PVGV) {
6613         if ( SvOBJECT(GvSV(sv)) ||
6614              GvAV(sv) && SvOBJECT(GvAV(sv)) ||
6615              GvHV(sv) && SvOBJECT(GvHV(sv)) ||
6616              GvIO(sv) && SvOBJECT(GvIO(sv)) ||
6617              GvCV(sv) && SvOBJECT(GvCV(sv)) )
6618         {
6619             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
6620             SvREFCNT_dec(sv);
6621         }
6622     }
6623 }
6624 #endif
6625
6626 static void
6627 do_clean_all(pTHXo_ SV *sv)
6628 {
6629     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
6630     SvFLAGS(sv) |= SVf_BREAK;
6631     SvREFCNT_dec(sv);
6632 }
6633