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 (GvIMPORTED(dstr) != GVf_IMPORTED
2373                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2374                 {
2375                     GvIMPORTED_on(dstr);
2376                 }
2377                 GvMULTI_on(dstr);
2378                 return;
2379             }
2380             goto glob_assign;
2381         }
2382         break;
2383     case SVt_PV:
2384     case SVt_PVFM:
2385         if (dtype < SVt_PV)
2386             sv_upgrade(dstr, SVt_PV);
2387         break;
2388     case SVt_PVIV:
2389         if (dtype < SVt_PVIV)
2390             sv_upgrade(dstr, SVt_PVIV);
2391         break;
2392     case SVt_PVNV:
2393         if (dtype < SVt_PVNV)
2394             sv_upgrade(dstr, SVt_PVNV);
2395         break;
2396     case SVt_PVAV:
2397     case SVt_PVHV:
2398     case SVt_PVCV:
2399     case SVt_PVIO:
2400         if (PL_op)
2401             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2402                 PL_op_name[PL_op->op_type]);
2403         else
2404             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2405         break;
2406
2407     case SVt_PVGV:
2408         if (dtype <= SVt_PVGV) {
2409   glob_assign:
2410             if (dtype != SVt_PVGV) {
2411                 char *name = GvNAME(sstr);
2412                 STRLEN len = GvNAMELEN(sstr);
2413                 sv_upgrade(dstr, SVt_PVGV);
2414                 sv_magic(dstr, dstr, '*', name, len);
2415                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2416                 GvNAME(dstr) = savepvn(name, len);
2417                 GvNAMELEN(dstr) = len;
2418                 SvFAKE_on(dstr);        /* can coerce to non-glob */
2419             }
2420             /* ahem, death to those who redefine active sort subs */
2421             else if (PL_curstackinfo->si_type == PERLSI_SORT
2422                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2423                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2424                       GvNAME(dstr));
2425             (void)SvOK_off(dstr);
2426             GvINTRO_off(dstr);          /* one-shot flag */
2427             gp_free((GV*)dstr);
2428             GvGP(dstr) = gp_ref(GvGP(sstr));
2429             SvTAINT(dstr);
2430             if (GvIMPORTED(dstr) != GVf_IMPORTED
2431                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2432             {
2433                 GvIMPORTED_on(dstr);
2434             }
2435             GvMULTI_on(dstr);
2436             return;
2437         }
2438         /* FALL THROUGH */
2439
2440     default:
2441         if (SvGMAGICAL(sstr)) {
2442             mg_get(sstr);
2443             if (SvTYPE(sstr) != stype) {
2444                 stype = SvTYPE(sstr);
2445                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2446                     goto glob_assign;
2447             }
2448         }
2449         if (stype == SVt_PVLV)
2450             (void)SvUPGRADE(dstr, SVt_PVNV);
2451         else
2452             (void)SvUPGRADE(dstr, stype);
2453     }
2454
2455     sflags = SvFLAGS(sstr);
2456
2457     if (sflags & SVf_ROK) {
2458         if (dtype >= SVt_PV) {
2459             if (dtype == SVt_PVGV) {
2460                 SV *sref = SvREFCNT_inc(SvRV(sstr));
2461                 SV *dref = 0;
2462                 int intro = GvINTRO(dstr);
2463
2464                 if (intro) {
2465                     GP *gp;
2466                     gp_free((GV*)dstr);
2467                     GvINTRO_off(dstr);  /* one-shot flag */
2468                     Newz(602,gp, 1, GP);
2469                     GvGP(dstr) = gp_ref(gp);
2470                     GvSV(dstr) = NEWSV(72,0);
2471                     GvLINE(dstr) = CopLINE(PL_curcop);
2472                     GvEGV(dstr) = (GV*)dstr;
2473                 }
2474                 GvMULTI_on(dstr);
2475                 switch (SvTYPE(sref)) {
2476                 case SVt_PVAV:
2477                     if (intro)
2478                         SAVESPTR(GvAV(dstr));
2479                     else
2480                         dref = (SV*)GvAV(dstr);
2481                     GvAV(dstr) = (AV*)sref;
2482                     if (GvIMPORTED_AV_off(dstr)
2483                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2484                     {
2485                         GvIMPORTED_AV_on(dstr);
2486                     }
2487                     break;
2488                 case SVt_PVHV:
2489                     if (intro)
2490                         SAVESPTR(GvHV(dstr));
2491                     else
2492                         dref = (SV*)GvHV(dstr);
2493                     GvHV(dstr) = (HV*)sref;
2494                     if (GvIMPORTED_HV_off(dstr)
2495                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2496                     {
2497                         GvIMPORTED_HV_on(dstr);
2498                     }
2499                     break;
2500                 case SVt_PVCV:
2501                     if (intro) {
2502                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2503                             SvREFCNT_dec(GvCV(dstr));
2504                             GvCV(dstr) = Nullcv;
2505                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2506                             PL_sub_generation++;
2507                         }
2508                         SAVESPTR(GvCV(dstr));
2509                     }
2510                     else
2511                         dref = (SV*)GvCV(dstr);
2512                     if (GvCV(dstr) != (CV*)sref) {
2513                         CV* cv = GvCV(dstr);
2514                         if (cv) {
2515                             if (!GvCVGEN((GV*)dstr) &&
2516                                 (CvROOT(cv) || CvXSUB(cv)))
2517                             {
2518                                 SV *const_sv = cv_const_sv(cv);
2519                                 bool const_changed = TRUE;
2520                                 if(const_sv)
2521                                     const_changed = sv_cmp(const_sv,
2522                                            op_const_sv(CvSTART((CV*)sref),
2523                                                        Nullcv));
2524                                 /* ahem, death to those who redefine
2525                                  * active sort subs */
2526                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2527                                       PL_sortcop == CvSTART(cv))
2528                                     Perl_croak(aTHX_
2529                                     "Can't redefine active sort subroutine %s",
2530                                           GvENAME((GV*)dstr));
2531                                 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2532                                     if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2533                                           && HvNAME(GvSTASH(CvGV(cv)))
2534                                           && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2535                                                    "autouse")))
2536                                         Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2537                                              "Constant subroutine %s redefined"
2538                                              : "Subroutine %s redefined",
2539                                              GvENAME((GV*)dstr));
2540                                 }
2541                             }
2542                             cv_ckproto(cv, (GV*)dstr,
2543                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
2544                         }
2545                         GvCV(dstr) = (CV*)sref;
2546                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2547                         GvASSUMECV_on(dstr);
2548                         PL_sub_generation++;
2549                     }
2550                     if (GvIMPORTED_CV_off(dstr)
2551                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2552                     {
2553                         GvIMPORTED_CV_on(dstr);
2554                     }
2555                     break;
2556                 case SVt_PVIO:
2557                     if (intro)
2558                         SAVESPTR(GvIOp(dstr));
2559                     else
2560                         dref = (SV*)GvIOp(dstr);
2561                     GvIOp(dstr) = (IO*)sref;
2562                     break;
2563                 default:
2564                     if (intro)
2565                         SAVESPTR(GvSV(dstr));
2566                     else
2567                         dref = (SV*)GvSV(dstr);
2568                     GvSV(dstr) = sref;
2569                     if (GvIMPORTED_SV_off(dstr)
2570                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2571                     {
2572                         GvIMPORTED_SV_on(dstr);
2573                     }
2574                     break;
2575                 }
2576                 if (dref)
2577                     SvREFCNT_dec(dref);
2578                 if (intro)
2579                     SAVEFREESV(sref);
2580                 SvTAINT(dstr);
2581                 return;
2582             }
2583             if (SvPVX(dstr)) {
2584                 (void)SvOOK_off(dstr);          /* backoff */
2585                 if (SvLEN(dstr))
2586                     Safefree(SvPVX(dstr));
2587                 SvLEN(dstr)=SvCUR(dstr)=0;
2588             }
2589         }
2590         (void)SvOK_off(dstr);
2591         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2592         SvROK_on(dstr);
2593         if (sflags & SVp_NOK) {
2594             SvNOK_on(dstr);
2595             SvNVX(dstr) = SvNVX(sstr);
2596         }
2597         if (sflags & SVp_IOK) {
2598             (void)SvIOK_on(dstr);
2599             SvIVX(dstr) = SvIVX(sstr);
2600             if (SvIsUV(sstr))
2601                 SvIsUV_on(dstr);
2602         }
2603         if (SvAMAGIC(sstr)) {
2604             SvAMAGIC_on(dstr);
2605         }
2606     }
2607     else if (sflags & SVp_POK) {
2608
2609         /*
2610          * Check to see if we can just swipe the string.  If so, it's a
2611          * possible small lose on short strings, but a big win on long ones.
2612          * It might even be a win on short strings if SvPVX(dstr)
2613          * has to be allocated and SvPVX(sstr) has to be freed.
2614          */
2615
2616         if (SvTEMP(sstr) &&             /* slated for free anyway? */
2617             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
2618             !(sflags & SVf_OOK))        /* and not involved in OOK hack? */
2619         {
2620             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
2621                 if (SvOOK(dstr)) {
2622                     SvFLAGS(dstr) &= ~SVf_OOK;
2623                     Safefree(SvPVX(dstr) - SvIVX(dstr));
2624                 }
2625                 else if (SvLEN(dstr))
2626                     Safefree(SvPVX(dstr));
2627             }
2628             (void)SvPOK_only(dstr);
2629             SvPV_set(dstr, SvPVX(sstr));
2630             SvLEN_set(dstr, SvLEN(sstr));
2631             SvCUR_set(dstr, SvCUR(sstr));
2632             SvTEMP_off(dstr);
2633             (void)SvOK_off(sstr);
2634             SvPV_set(sstr, Nullch);
2635             SvLEN_set(sstr, 0);
2636             SvCUR_set(sstr, 0);
2637             SvTEMP_off(sstr);
2638         }
2639         else {                                  /* have to copy actual string */
2640             STRLEN len = SvCUR(sstr);
2641
2642             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
2643             Move(SvPVX(sstr),SvPVX(dstr),len,char);
2644             SvCUR_set(dstr, len);
2645             *SvEND(dstr) = '\0';
2646             (void)SvPOK_only(dstr);
2647         }
2648         /*SUPPRESS 560*/
2649         if (sflags & SVp_NOK) {
2650             SvNOK_on(dstr);
2651             SvNVX(dstr) = SvNVX(sstr);
2652         }
2653         if (sflags & SVp_IOK) {
2654             (void)SvIOK_on(dstr);
2655             SvIVX(dstr) = SvIVX(sstr);
2656             if (SvIsUV(sstr))
2657                 SvIsUV_on(dstr);
2658         }
2659     }
2660     else if (sflags & SVp_NOK) {
2661         SvNVX(dstr) = SvNVX(sstr);
2662         (void)SvNOK_only(dstr);
2663         if (SvIOK(sstr)) {
2664             (void)SvIOK_on(dstr);
2665             SvIVX(dstr) = SvIVX(sstr);
2666             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
2667             if (SvIsUV(sstr))
2668                 SvIsUV_on(dstr);
2669         }
2670     }
2671     else if (sflags & SVp_IOK) {
2672         (void)SvIOK_only(dstr);
2673         SvIVX(dstr) = SvIVX(sstr);
2674         if (SvIsUV(sstr))
2675             SvIsUV_on(dstr);
2676     }
2677     else {
2678         if (dtype == SVt_PVGV) {
2679             if (ckWARN(WARN_UNSAFE))
2680                 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2681         }
2682         else
2683             (void)SvOK_off(dstr);
2684     }
2685     SvTAINT(dstr);
2686 }
2687
2688 void
2689 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2690 {
2691     sv_setsv(dstr,sstr);
2692     SvSETMAGIC(dstr);
2693 }
2694
2695 void
2696 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2697 {
2698     register char *dptr;
2699     assert(len >= 0);  /* STRLEN is probably unsigned, so this may
2700                           elicit a warning, but it won't hurt. */
2701     SV_CHECK_THINKFIRST(sv);
2702     if (!ptr) {
2703         (void)SvOK_off(sv);
2704         return;
2705     }
2706     (void)SvUPGRADE(sv, SVt_PV);
2707
2708     SvGROW(sv, len + 1);
2709     dptr = SvPVX(sv);
2710     Move(ptr,dptr,len,char);
2711     dptr[len] = '\0';
2712     SvCUR_set(sv, len);
2713     (void)SvPOK_only(sv);               /* validate pointer */
2714     SvTAINT(sv);
2715 }
2716
2717 void
2718 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2719 {
2720     sv_setpvn(sv,ptr,len);
2721     SvSETMAGIC(sv);
2722 }
2723
2724 void
2725 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2726 {
2727     register STRLEN len;
2728
2729     SV_CHECK_THINKFIRST(sv);
2730     if (!ptr) {
2731         (void)SvOK_off(sv);
2732         return;
2733     }
2734     len = strlen(ptr);
2735     (void)SvUPGRADE(sv, SVt_PV);
2736
2737     SvGROW(sv, len + 1);
2738     Move(ptr,SvPVX(sv),len+1,char);
2739     SvCUR_set(sv, len);
2740     (void)SvPOK_only(sv);               /* validate pointer */
2741     SvTAINT(sv);
2742 }
2743
2744 void
2745 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2746 {
2747     sv_setpv(sv,ptr);
2748     SvSETMAGIC(sv);
2749 }
2750
2751 void
2752 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2753 {
2754     SV_CHECK_THINKFIRST(sv);
2755     (void)SvUPGRADE(sv, SVt_PV);
2756     if (!ptr) {
2757         (void)SvOK_off(sv);
2758         return;
2759     }
2760     (void)SvOOK_off(sv);
2761     if (SvPVX(sv) && SvLEN(sv))
2762         Safefree(SvPVX(sv));
2763     Renew(ptr, len+1, char);
2764     SvPVX(sv) = ptr;
2765     SvCUR_set(sv, len);
2766     SvLEN_set(sv, len+1);
2767     *SvEND(sv) = '\0';
2768     (void)SvPOK_only(sv);               /* validate pointer */
2769     SvTAINT(sv);
2770 }
2771
2772 void
2773 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2774 {
2775     sv_usepvn(sv,ptr,len);
2776     SvSETMAGIC(sv);
2777 }
2778
2779 void
2780 Perl_sv_force_normal(pTHX_ register SV *sv)
2781 {
2782     if (SvREADONLY(sv)) {
2783         dTHR;
2784         if (PL_curcop != &PL_compiling)
2785             Perl_croak(aTHX_ PL_no_modify);
2786     }
2787     if (SvROK(sv))
2788         sv_unref(sv);
2789     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2790         sv_unglob(sv);
2791 }
2792
2793 void
2794 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2795
2796
2797 {
2798     register STRLEN delta;
2799
2800     if (!ptr || !SvPOKp(sv))
2801         return;
2802     SV_CHECK_THINKFIRST(sv);
2803     if (SvTYPE(sv) < SVt_PVIV)
2804         sv_upgrade(sv,SVt_PVIV);
2805
2806     if (!SvOOK(sv)) {
2807         if (!SvLEN(sv)) { /* make copy of shared string */
2808             char *pvx = SvPVX(sv);
2809             STRLEN len = SvCUR(sv);
2810             SvGROW(sv, len + 1);
2811             Move(pvx,SvPVX(sv),len,char);
2812             *SvEND(sv) = '\0';
2813         }
2814         SvIVX(sv) = 0;
2815         SvFLAGS(sv) |= SVf_OOK;
2816     }
2817     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2818     delta = ptr - SvPVX(sv);
2819     SvLEN(sv) -= delta;
2820     SvCUR(sv) -= delta;
2821     SvPVX(sv) += delta;
2822     SvIVX(sv) += delta;
2823 }
2824
2825 void
2826 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2827 {
2828     STRLEN tlen;
2829     char *junk;
2830
2831     junk = SvPV_force(sv, tlen);
2832     SvGROW(sv, tlen + len + 1);
2833     if (ptr == junk)
2834         ptr = SvPVX(sv);
2835     Move(ptr,SvPVX(sv)+tlen,len,char);
2836     SvCUR(sv) += len;
2837     *SvEND(sv) = '\0';
2838     (void)SvPOK_only(sv);               /* validate pointer */
2839     SvTAINT(sv);
2840 }
2841
2842 void
2843 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2844 {
2845     sv_catpvn(sv,ptr,len);
2846     SvSETMAGIC(sv);
2847 }
2848
2849 void
2850 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2851 {
2852     char *s;
2853     STRLEN len;
2854     if (!sstr)
2855         return;
2856     if (s = SvPV(sstr, len))
2857         sv_catpvn(dstr,s,len);
2858 }
2859
2860 void
2861 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2862 {
2863     sv_catsv(dstr,sstr);
2864     SvSETMAGIC(dstr);
2865 }
2866
2867 void
2868 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2869 {
2870     register STRLEN len;
2871     STRLEN tlen;
2872     char *junk;
2873
2874     if (!ptr)
2875         return;
2876     junk = SvPV_force(sv, tlen);
2877     len = strlen(ptr);
2878     SvGROW(sv, tlen + len + 1);
2879     if (ptr == junk)
2880         ptr = SvPVX(sv);
2881     Move(ptr,SvPVX(sv)+tlen,len+1,char);
2882     SvCUR(sv) += len;
2883     (void)SvPOK_only(sv);               /* validate pointer */
2884     SvTAINT(sv);
2885 }
2886
2887 void
2888 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2889 {
2890     sv_catpv(sv,ptr);
2891     SvSETMAGIC(sv);
2892 }
2893
2894 SV *
2895 Perl_newSV(pTHX_ STRLEN len)
2896 {
2897     register SV *sv;
2898
2899     new_SV(sv);
2900     if (len) {
2901         sv_upgrade(sv, SVt_PV);
2902         SvGROW(sv, len + 1);
2903     }
2904     return sv;
2905 }
2906
2907 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2908
2909 void
2910 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2911 {
2912     MAGIC* mg;
2913
2914     if (SvREADONLY(sv)) {
2915         dTHR;
2916         if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2917             Perl_croak(aTHX_ PL_no_modify);
2918     }
2919     if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2920         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2921             if (how == 't')
2922                 mg->mg_len |= 1;
2923             return;
2924         }
2925     }
2926     else {
2927         (void)SvUPGRADE(sv, SVt_PVMG);
2928     }
2929     Newz(702,mg, 1, MAGIC);
2930     mg->mg_moremagic = SvMAGIC(sv);
2931
2932     SvMAGIC(sv) = mg;
2933     if (!obj || obj == sv || how == '#' || how == 'r')
2934         mg->mg_obj = obj;
2935     else {
2936         dTHR;
2937         mg->mg_obj = SvREFCNT_inc(obj);
2938         mg->mg_flags |= MGf_REFCOUNTED;
2939     }
2940     mg->mg_type = how;
2941     mg->mg_len = namlen;
2942     if (name)
2943         if (namlen >= 0)
2944             mg->mg_ptr = savepvn(name, namlen);
2945         else if (namlen == HEf_SVKEY)
2946             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2947
2948     switch (how) {
2949     case 0:
2950         mg->mg_virtual = &PL_vtbl_sv;
2951         break;
2952     case 'A':
2953         mg->mg_virtual = &PL_vtbl_amagic;
2954         break;
2955     case 'a':
2956         mg->mg_virtual = &PL_vtbl_amagicelem;
2957         break;
2958     case 'c':
2959         mg->mg_virtual = 0;
2960         break;
2961     case 'B':
2962         mg->mg_virtual = &PL_vtbl_bm;
2963         break;
2964     case 'D':
2965         mg->mg_virtual = &PL_vtbl_regdata;
2966         break;
2967     case 'd':
2968         mg->mg_virtual = &PL_vtbl_regdatum;
2969         break;
2970     case 'E':
2971         mg->mg_virtual = &PL_vtbl_env;
2972         break;
2973     case 'f':
2974         mg->mg_virtual = &PL_vtbl_fm;
2975         break;
2976     case 'e':
2977         mg->mg_virtual = &PL_vtbl_envelem;
2978         break;
2979     case 'g':
2980         mg->mg_virtual = &PL_vtbl_mglob;
2981         break;
2982     case 'I':
2983         mg->mg_virtual = &PL_vtbl_isa;
2984         break;
2985     case 'i':
2986         mg->mg_virtual = &PL_vtbl_isaelem;
2987         break;
2988     case 'k':
2989         mg->mg_virtual = &PL_vtbl_nkeys;
2990         break;
2991     case 'L':
2992         SvRMAGICAL_on(sv);
2993         mg->mg_virtual = 0;
2994         break;
2995     case 'l':
2996         mg->mg_virtual = &PL_vtbl_dbline;
2997         break;
2998 #ifdef USE_THREADS
2999     case 'm':
3000         mg->mg_virtual = &PL_vtbl_mutex;
3001         break;
3002 #endif /* USE_THREADS */
3003 #ifdef USE_LOCALE_COLLATE
3004     case 'o':
3005         mg->mg_virtual = &PL_vtbl_collxfrm;
3006         break;
3007 #endif /* USE_LOCALE_COLLATE */
3008     case 'P':
3009         mg->mg_virtual = &PL_vtbl_pack;
3010         break;
3011     case 'p':
3012     case 'q':
3013         mg->mg_virtual = &PL_vtbl_packelem;
3014         break;
3015     case 'r':
3016         mg->mg_virtual = &PL_vtbl_regexp;
3017         break;
3018     case 'S':
3019         mg->mg_virtual = &PL_vtbl_sig;
3020         break;
3021     case 's':
3022         mg->mg_virtual = &PL_vtbl_sigelem;
3023         break;
3024     case 't':
3025         mg->mg_virtual = &PL_vtbl_taint;
3026         mg->mg_len = 1;
3027         break;
3028     case 'U':
3029         mg->mg_virtual = &PL_vtbl_uvar;
3030         break;
3031     case 'v':
3032         mg->mg_virtual = &PL_vtbl_vec;
3033         break;
3034     case 'x':
3035         mg->mg_virtual = &PL_vtbl_substr;
3036         break;
3037     case 'y':
3038         mg->mg_virtual = &PL_vtbl_defelem;
3039         break;
3040     case '*':
3041         mg->mg_virtual = &PL_vtbl_glob;
3042         break;
3043     case '#':
3044         mg->mg_virtual = &PL_vtbl_arylen;
3045         break;
3046     case '.':
3047         mg->mg_virtual = &PL_vtbl_pos;
3048         break;
3049     case '<':
3050         mg->mg_virtual = &PL_vtbl_backref;
3051         break;
3052     case '~':   /* Reserved for use by extensions not perl internals.   */
3053         /* Useful for attaching extension internal data to perl vars.   */
3054         /* Note that multiple extensions may clash if magical scalars   */
3055         /* etc holding private data from one are passed to another.     */
3056         SvRMAGICAL_on(sv);
3057         break;
3058     default:
3059         Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3060     }
3061     mg_magical(sv);
3062     if (SvGMAGICAL(sv))
3063         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3064 }
3065
3066 int
3067 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3068 {
3069     MAGIC* mg;
3070     MAGIC** mgp;
3071     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3072         return 0;
3073     mgp = &SvMAGIC(sv);
3074     for (mg = *mgp; mg; mg = *mgp) {
3075         if (mg->mg_type == type) {
3076             MGVTBL* vtbl = mg->mg_virtual;
3077             *mgp = mg->mg_moremagic;
3078             if (vtbl && vtbl->svt_free)
3079                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3080             if (mg->mg_ptr && mg->mg_type != 'g')
3081                 if (mg->mg_len >= 0)
3082                     Safefree(mg->mg_ptr);
3083                 else if (mg->mg_len == HEf_SVKEY)
3084                     SvREFCNT_dec((SV*)mg->mg_ptr);
3085             if (mg->mg_flags & MGf_REFCOUNTED)
3086                 SvREFCNT_dec(mg->mg_obj);
3087             Safefree(mg);
3088         }
3089         else
3090             mgp = &mg->mg_moremagic;
3091     }
3092     if (!SvMAGIC(sv)) {
3093         SvMAGICAL_off(sv);
3094         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3095     }
3096
3097     return 0;
3098 }
3099
3100 SV *
3101 Perl_sv_rvweaken(pTHX_ SV *sv)
3102 {
3103     SV *tsv;
3104     if (!SvOK(sv))  /* let undefs pass */
3105         return sv;
3106     if (!SvROK(sv))
3107         Perl_croak(aTHX_ "Can't weaken a nonreference");
3108     else if (SvWEAKREF(sv)) {
3109         dTHR;
3110         if (ckWARN(WARN_MISC))
3111             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3112         return sv;
3113     }
3114     tsv = SvRV(sv);
3115     sv_add_backref(tsv, sv);
3116     SvWEAKREF_on(sv);
3117     SvREFCNT_dec(tsv);
3118     return sv;
3119 }
3120
3121 STATIC void
3122 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3123 {
3124     AV *av;
3125     MAGIC *mg;
3126     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3127         av = (AV*)mg->mg_obj;
3128     else {
3129         av = newAV();
3130         sv_magic(tsv, (SV*)av, '<', NULL, 0);
3131         SvREFCNT_dec(av);           /* for sv_magic */
3132     }
3133     av_push(av,sv);
3134 }
3135
3136 STATIC void
3137 S_sv_del_backref(pTHX_ SV *sv)
3138 {
3139     AV *av;
3140     SV **svp;
3141     I32 i;
3142     SV *tsv = SvRV(sv);
3143     MAGIC *mg;
3144     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3145         Perl_croak(aTHX_ "panic: del_backref");
3146     av = (AV *)mg->mg_obj;
3147     svp = AvARRAY(av);
3148     i = AvFILLp(av);
3149     while (i >= 0) {
3150         if (svp[i] == sv) {
3151             svp[i] = &PL_sv_undef; /* XXX */
3152         }
3153         i--;
3154     }
3155 }
3156
3157 void
3158 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3159 {
3160     register char *big;
3161     register char *mid;
3162     register char *midend;
3163     register char *bigend;
3164     register I32 i;
3165     STRLEN curlen;
3166
3167
3168     if (!bigstr)
3169         Perl_croak(aTHX_ "Can't modify non-existent substring");
3170     SvPV_force(bigstr, curlen);
3171     if (offset + len > curlen) {
3172         SvGROW(bigstr, offset+len+1);
3173         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3174         SvCUR_set(bigstr, offset+len);
3175     }
3176
3177     i = littlelen - len;
3178     if (i > 0) {                        /* string might grow */
3179         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3180         mid = big + offset + len;
3181         midend = bigend = big + SvCUR(bigstr);
3182         bigend += i;
3183         *bigend = '\0';
3184         while (midend > mid)            /* shove everything down */
3185             *--bigend = *--midend;
3186         Move(little,big+offset,littlelen,char);
3187         SvCUR(bigstr) += i;
3188         SvSETMAGIC(bigstr);
3189         return;
3190     }
3191     else if (i == 0) {
3192         Move(little,SvPVX(bigstr)+offset,len,char);
3193         SvSETMAGIC(bigstr);
3194         return;
3195     }
3196
3197     big = SvPVX(bigstr);
3198     mid = big + offset;
3199     midend = mid + len;
3200     bigend = big + SvCUR(bigstr);
3201
3202     if (midend > bigend)
3203         Perl_croak(aTHX_ "panic: sv_insert");
3204
3205     if (mid - big > bigend - midend) {  /* faster to shorten from end */
3206         if (littlelen) {
3207             Move(little, mid, littlelen,char);
3208             mid += littlelen;
3209         }
3210         i = bigend - midend;
3211         if (i > 0) {
3212             Move(midend, mid, i,char);
3213             mid += i;
3214         }
3215         *mid = '\0';
3216         SvCUR_set(bigstr, mid - big);
3217     }
3218     /*SUPPRESS 560*/
3219     else if (i = mid - big) {   /* faster from front */
3220         midend -= littlelen;
3221         mid = midend;
3222         sv_chop(bigstr,midend-i);
3223         big += i;
3224         while (i--)
3225             *--midend = *--big;
3226         if (littlelen)
3227             Move(little, mid, littlelen,char);
3228     }
3229     else if (littlelen) {
3230         midend -= littlelen;
3231         sv_chop(bigstr,midend);
3232         Move(little,midend,littlelen,char);
3233     }
3234     else {
3235         sv_chop(bigstr,midend);
3236     }
3237     SvSETMAGIC(bigstr);
3238 }
3239
3240 /* make sv point to what nstr did */
3241
3242 void
3243 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3244 {
3245     dTHR;
3246     U32 refcnt = SvREFCNT(sv);
3247     SV_CHECK_THINKFIRST(sv);
3248     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3249         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3250     if (SvMAGICAL(sv)) {
3251         if (SvMAGICAL(nsv))
3252             mg_free(nsv);
3253         else
3254             sv_upgrade(nsv, SVt_PVMG);
3255         SvMAGIC(nsv) = SvMAGIC(sv);
3256         SvFLAGS(nsv) |= SvMAGICAL(sv);
3257         SvMAGICAL_off(sv);
3258         SvMAGIC(sv) = 0;
3259     }
3260     SvREFCNT(sv) = 0;
3261     sv_clear(sv);
3262     assert(!SvREFCNT(sv));
3263     StructCopy(nsv,sv,SV);
3264     SvREFCNT(sv) = refcnt;
3265     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
3266     del_SV(nsv);
3267 }
3268
3269 void
3270 Perl_sv_clear(pTHX_ register SV *sv)
3271 {
3272     HV* stash;
3273     assert(sv);
3274     assert(SvREFCNT(sv) == 0);
3275
3276     if (SvOBJECT(sv)) {
3277         dTHR;
3278         if (PL_defstash) {              /* Still have a symbol table? */
3279             djSP;
3280             GV* destructor;
3281             SV tmpref;
3282
3283             Zero(&tmpref, 1, SV);
3284             sv_upgrade(&tmpref, SVt_RV);
3285             SvROK_on(&tmpref);
3286             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
3287             SvREFCNT(&tmpref) = 1;
3288
3289             do {
3290                 stash = SvSTASH(sv);
3291                 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3292                 if (destructor) {
3293                     ENTER;
3294                     PUSHSTACKi(PERLSI_DESTROY);
3295                     SvRV(&tmpref) = SvREFCNT_inc(sv);
3296                     EXTEND(SP, 2);
3297                     PUSHMARK(SP);
3298                     PUSHs(&tmpref);
3299                     PUTBACK;
3300                     call_sv((SV*)GvCV(destructor),
3301                             G_DISCARD|G_EVAL|G_KEEPERR);
3302                     SvREFCNT(sv)--;
3303                     POPSTACK;
3304                     SPAGAIN;
3305                     LEAVE;
3306                 }
3307             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3308
3309             del_XRV(SvANY(&tmpref));
3310
3311             if (SvREFCNT(sv)) {
3312                 if (PL_in_clean_objs)
3313                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3314                           HvNAME(stash));
3315                 /* DESTROY gave object new lease on life */
3316                 return;
3317             }
3318         }
3319
3320         if (SvOBJECT(sv)) {
3321             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
3322             SvOBJECT_off(sv);   /* Curse the object. */
3323             if (SvTYPE(sv) != SVt_PVIO)
3324                 --PL_sv_objcount;       /* XXX Might want something more general */
3325         }
3326     }
3327     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3328         mg_free(sv);
3329     stash = NULL;
3330     switch (SvTYPE(sv)) {
3331     case SVt_PVIO:
3332         if (IoIFP(sv) &&
3333             IoIFP(sv) != PerlIO_stdin() &&
3334             IoIFP(sv) != PerlIO_stdout() &&
3335             IoIFP(sv) != PerlIO_stderr())
3336         {
3337             io_close((IO*)sv, FALSE);
3338         }
3339         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3340             PerlDir_close(IoDIRP(sv));
3341         IoDIRP(sv) = (DIR*)NULL;
3342         Safefree(IoTOP_NAME(sv));
3343         Safefree(IoFMT_NAME(sv));
3344         Safefree(IoBOTTOM_NAME(sv));
3345         /* FALL THROUGH */
3346     case SVt_PVBM:
3347         goto freescalar;
3348     case SVt_PVCV:
3349     case SVt_PVFM:
3350         cv_undef((CV*)sv);
3351         goto freescalar;
3352     case SVt_PVHV:
3353         hv_undef((HV*)sv);
3354         break;
3355     case SVt_PVAV:
3356         av_undef((AV*)sv);
3357         break;
3358     case SVt_PVLV:
3359         SvREFCNT_dec(LvTARG(sv));
3360         goto freescalar;
3361     case SVt_PVGV:
3362         gp_free((GV*)sv);
3363         Safefree(GvNAME(sv));
3364         /* cannot decrease stash refcount yet, as we might recursively delete
3365            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3366            of stash until current sv is completely gone.
3367            -- JohnPC, 27 Mar 1998 */
3368         stash = GvSTASH(sv);
3369         /* FALL THROUGH */
3370     case SVt_PVMG:
3371     case SVt_PVNV:
3372     case SVt_PVIV:
3373       freescalar:
3374         (void)SvOOK_off(sv);
3375         /* FALL THROUGH */
3376     case SVt_PV:
3377     case SVt_RV:
3378         if (SvROK(sv)) {
3379             if (SvWEAKREF(sv))
3380                 sv_del_backref(sv);
3381             else
3382                 SvREFCNT_dec(SvRV(sv));
3383         }
3384         else if (SvPVX(sv) && SvLEN(sv))
3385             Safefree(SvPVX(sv));
3386         break;
3387 /*
3388     case SVt_NV:
3389     case SVt_IV:
3390     case SVt_NULL:
3391         break;
3392 */
3393     }
3394
3395     switch (SvTYPE(sv)) {
3396     case SVt_NULL:
3397         break;
3398     case SVt_IV:
3399         del_XIV(SvANY(sv));
3400         break;
3401     case SVt_NV:
3402         del_XNV(SvANY(sv));
3403         break;
3404     case SVt_RV:
3405         del_XRV(SvANY(sv));
3406         break;
3407     case SVt_PV:
3408         del_XPV(SvANY(sv));
3409         break;
3410     case SVt_PVIV:
3411         del_XPVIV(SvANY(sv));
3412         break;
3413     case SVt_PVNV:
3414         del_XPVNV(SvANY(sv));
3415         break;
3416     case SVt_PVMG:
3417         del_XPVMG(SvANY(sv));
3418         break;
3419     case SVt_PVLV:
3420         del_XPVLV(SvANY(sv));
3421         break;
3422     case SVt_PVAV:
3423         del_XPVAV(SvANY(sv));
3424         break;
3425     case SVt_PVHV:
3426         del_XPVHV(SvANY(sv));
3427         break;
3428     case SVt_PVCV:
3429         del_XPVCV(SvANY(sv));
3430         break;
3431     case SVt_PVGV:
3432         del_XPVGV(SvANY(sv));
3433         /* code duplication for increased performance. */
3434         SvFLAGS(sv) &= SVf_BREAK;
3435         SvFLAGS(sv) |= SVTYPEMASK;
3436         /* decrease refcount of the stash that owns this GV, if any */
3437         if (stash)
3438             SvREFCNT_dec(stash);
3439         return; /* not break, SvFLAGS reset already happened */
3440     case SVt_PVBM:
3441         del_XPVBM(SvANY(sv));
3442         break;
3443     case SVt_PVFM:
3444         del_XPVFM(SvANY(sv));
3445         break;
3446     case SVt_PVIO:
3447         del_XPVIO(SvANY(sv));
3448         break;
3449     }
3450     SvFLAGS(sv) &= SVf_BREAK;
3451     SvFLAGS(sv) |= SVTYPEMASK;
3452 }
3453
3454 SV *
3455 Perl_sv_newref(pTHX_ SV *sv)
3456 {
3457     if (sv)
3458         ATOMIC_INC(SvREFCNT(sv));
3459     return sv;
3460 }
3461
3462 void
3463 Perl_sv_free(pTHX_ SV *sv)
3464 {
3465     dTHR;
3466     int refcount_is_zero;
3467
3468     if (!sv)
3469         return;
3470     if (SvREFCNT(sv) == 0) {
3471         if (SvFLAGS(sv) & SVf_BREAK)
3472             return;
3473         if (PL_in_clean_all) /* All is fair */
3474             return;
3475         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3476             /* make sure SvREFCNT(sv)==0 happens very seldom */
3477             SvREFCNT(sv) = (~(U32)0)/2;
3478             return;
3479         }
3480         if (ckWARN_d(WARN_INTERNAL))
3481             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3482         return;
3483     }
3484     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3485     if (!refcount_is_zero)
3486         return;
3487 #ifdef DEBUGGING
3488     if (SvTEMP(sv)) {
3489         if (ckWARN_d(WARN_DEBUGGING))
3490             Perl_warner(aTHX_ WARN_DEBUGGING,
3491                         "Attempt to free temp prematurely: SV 0x%"UVxf,
3492                         PTR2UV(sv));
3493         return;
3494     }
3495 #endif
3496     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3497         /* make sure SvREFCNT(sv)==0 happens very seldom */
3498         SvREFCNT(sv) = (~(U32)0)/2;
3499         return;
3500     }
3501     sv_clear(sv);
3502     if (! SvREFCNT(sv))
3503         del_SV(sv);
3504 }
3505
3506 STRLEN
3507 Perl_sv_len(pTHX_ register SV *sv)
3508 {
3509     char *junk;
3510     STRLEN len;
3511
3512     if (!sv)
3513         return 0;
3514
3515     if (SvGMAGICAL(sv))
3516         len = mg_length(sv);
3517     else
3518         junk = SvPV(sv, len);
3519     return len;
3520 }
3521
3522 STRLEN
3523 Perl_sv_len_utf8(pTHX_ register SV *sv)
3524 {
3525     U8 *s;
3526     U8 *send;
3527     STRLEN len;
3528
3529     if (!sv)
3530         return 0;
3531
3532 #ifdef NOTYET
3533     if (SvGMAGICAL(sv))
3534         len = mg_length(sv);
3535     else
3536 #endif
3537         s = (U8*)SvPV(sv, len);
3538     send = s + len;
3539     len = 0;
3540     while (s < send) {
3541         s += UTF8SKIP(s);
3542         len++;
3543     }
3544     return len;
3545 }
3546
3547 void
3548 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3549 {
3550     U8 *start;
3551     U8 *s;
3552     U8 *send;
3553     I32 uoffset = *offsetp;
3554     STRLEN len;
3555
3556     if (!sv)
3557         return;
3558
3559     start = s = (U8*)SvPV(sv, len);
3560     send = s + len;
3561     while (s < send && uoffset--)
3562         s += UTF8SKIP(s);
3563     if (s >= send)
3564         s = send;
3565     *offsetp = s - start;
3566     if (lenp) {
3567         I32 ulen = *lenp;
3568         start = s;
3569         while (s < send && ulen--)
3570             s += UTF8SKIP(s);
3571         if (s >= send)
3572             s = send;
3573         *lenp = s - start;
3574     }
3575     return;
3576 }
3577
3578 void
3579 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3580 {
3581     U8 *s;
3582     U8 *send;
3583     STRLEN len;
3584
3585     if (!sv)
3586         return;
3587
3588     s = (U8*)SvPV(sv, len);
3589     if (len < *offsetp)
3590         Perl_croak(aTHX_ "panic: bad byte offset");
3591     send = s + *offsetp;
3592     len = 0;
3593     while (s < send) {
3594         s += UTF8SKIP(s);
3595         ++len;
3596     }
3597     if (s != send) {
3598         dTHR;
3599         if (ckWARN_d(WARN_UTF8))
3600             Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3601         --len;
3602     }
3603     *offsetp = len;
3604     return;
3605 }
3606
3607 I32
3608 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3609 {
3610     char *pv1;
3611     STRLEN cur1;
3612     char *pv2;
3613     STRLEN cur2;
3614
3615     if (!str1) {
3616         pv1 = "";
3617         cur1 = 0;
3618     }
3619     else
3620         pv1 = SvPV(str1, cur1);
3621
3622     if (!str2)
3623         return !cur1;
3624     else
3625         pv2 = SvPV(str2, cur2);
3626
3627     if (cur1 != cur2)
3628         return 0;
3629
3630     return memEQ(pv1, pv2, cur1);
3631 }
3632
3633 I32
3634 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3635 {
3636     STRLEN cur1 = 0;
3637     char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3638     STRLEN cur2 = 0;
3639     char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3640     I32 retval;
3641
3642     if (!cur1)
3643         return cur2 ? -1 : 0;
3644
3645     if (!cur2)
3646         return 1;
3647
3648     retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3649
3650     if (retval)
3651         return retval < 0 ? -1 : 1;
3652
3653     if (cur1 == cur2)
3654         return 0;
3655     else
3656         return cur1 < cur2 ? -1 : 1;
3657 }
3658
3659 I32
3660 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3661 {
3662 #ifdef USE_LOCALE_COLLATE
3663
3664     char *pv1, *pv2;
3665     STRLEN len1, len2;
3666     I32 retval;
3667
3668     if (PL_collation_standard)
3669         goto raw_compare;
3670
3671     len1 = 0;
3672     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3673     len2 = 0;
3674     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3675
3676     if (!pv1 || !len1) {
3677         if (pv2 && len2)
3678             return -1;
3679         else
3680             goto raw_compare;
3681     }
3682     else {
3683         if (!pv2 || !len2)
3684             return 1;
3685     }
3686
3687     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3688
3689     if (retval)
3690         return retval < 0 ? -1 : 1;
3691
3692     /*
3693      * When the result of collation is equality, that doesn't mean
3694      * that there are no differences -- some locales exclude some
3695      * characters from consideration.  So to avoid false equalities,
3696      * we use the raw string as a tiebreaker.
3697      */
3698
3699   raw_compare:
3700     /* FALL THROUGH */
3701
3702 #endif /* USE_LOCALE_COLLATE */
3703
3704     return sv_cmp(sv1, sv2);
3705 }
3706
3707 #ifdef USE_LOCALE_COLLATE
3708 /*
3709  * Any scalar variable may carry an 'o' magic that contains the
3710  * scalar data of the variable transformed to such a format that
3711  * a normal memory comparison can be used to compare the data
3712  * according to the locale settings.
3713  */
3714 char *
3715 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3716 {
3717     MAGIC *mg;
3718
3719     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3720     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3721         char *s, *xf;
3722         STRLEN len, xlen;
3723
3724         if (mg)
3725             Safefree(mg->mg_ptr);
3726         s = SvPV(sv, len);
3727         if ((xf = mem_collxfrm(s, len, &xlen))) {
3728             if (SvREADONLY(sv)) {
3729                 SAVEFREEPV(xf);
3730                 *nxp = xlen;
3731                 return xf + sizeof(PL_collation_ix);
3732             }
3733             if (! mg) {
3734                 sv_magic(sv, 0, 'o', 0, 0);
3735                 mg = mg_find(sv, 'o');
3736                 assert(mg);
3737             }
3738             mg->mg_ptr = xf;
3739             mg->mg_len = xlen;
3740         }
3741         else {
3742             if (mg) {
3743                 mg->mg_ptr = NULL;
3744                 mg->mg_len = -1;
3745             }
3746         }
3747     }
3748     if (mg && mg->mg_ptr) {
3749         *nxp = mg->mg_len;
3750         return mg->mg_ptr + sizeof(PL_collation_ix);
3751     }
3752     else {
3753         *nxp = 0;
3754         return NULL;
3755     }
3756 }
3757
3758 #endif /* USE_LOCALE_COLLATE */
3759
3760 char *
3761 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3762 {
3763     dTHR;
3764     char *rsptr;
3765     STRLEN rslen;
3766     register STDCHAR rslast;
3767     register STDCHAR *bp;
3768     register I32 cnt;
3769     I32 i;
3770
3771     SV_CHECK_THINKFIRST(sv);
3772     (void)SvUPGRADE(sv, SVt_PV);
3773
3774     SvSCREAM_off(sv);
3775
3776     if (RsSNARF(PL_rs)) {
3777         rsptr = NULL;
3778         rslen = 0;
3779     }
3780     else if (RsRECORD(PL_rs)) {
3781       I32 recsize, bytesread;
3782       char *buffer;
3783
3784       /* Grab the size of the record we're getting */
3785       recsize = SvIV(SvRV(PL_rs));
3786       (void)SvPOK_only(sv);    /* Validate pointer */
3787       buffer = SvGROW(sv, recsize + 1);
3788       /* Go yank in */
3789 #ifdef VMS
3790       /* VMS wants read instead of fread, because fread doesn't respect */
3791       /* RMS record boundaries. This is not necessarily a good thing to be */
3792       /* doing, but we've got no other real choice */
3793       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3794 #else
3795       bytesread = PerlIO_read(fp, buffer, recsize);
3796 #endif
3797       SvCUR_set(sv, bytesread);
3798       buffer[bytesread] = '\0';
3799       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3800     }
3801     else if (RsPARA(PL_rs)) {
3802         rsptr = "\n\n";
3803         rslen = 2;
3804     }
3805     else
3806         rsptr = SvPV(PL_rs, rslen);
3807     rslast = rslen ? rsptr[rslen - 1] : '\0';
3808
3809     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
3810         do {                    /* to make sure file boundaries work right */
3811             if (PerlIO_eof(fp))
3812                 return 0;
3813             i = PerlIO_getc(fp);
3814             if (i != '\n') {
3815                 if (i == -1)
3816                     return 0;
3817                 PerlIO_ungetc(fp,i);
3818                 break;
3819             }
3820         } while (i != EOF);
3821     }
3822
3823     /* See if we know enough about I/O mechanism to cheat it ! */
3824
3825     /* This used to be #ifdef test - it is made run-time test for ease
3826        of abstracting out stdio interface. One call should be cheap
3827        enough here - and may even be a macro allowing compile
3828        time optimization.
3829      */
3830
3831     if (PerlIO_fast_gets(fp)) {
3832
3833     /*
3834      * We're going to steal some values from the stdio struct
3835      * and put EVERYTHING in the innermost loop into registers.
3836      */
3837     register STDCHAR *ptr;
3838     STRLEN bpx;
3839     I32 shortbuffered;
3840
3841 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3842     /* An ungetc()d char is handled separately from the regular
3843      * buffer, so we getc() it back out and stuff it in the buffer.
3844      */
3845     i = PerlIO_getc(fp);
3846     if (i == EOF) return 0;
3847     *(--((*fp)->_ptr)) = (unsigned char) i;
3848     (*fp)->_cnt++;
3849 #endif
3850
3851     /* Here is some breathtakingly efficient cheating */
3852
3853     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
3854     (void)SvPOK_only(sv);               /* validate pointer */
3855     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3856         if (cnt > 80 && SvLEN(sv) > append) {
3857             shortbuffered = cnt - SvLEN(sv) + append + 1;
3858             cnt -= shortbuffered;
3859         }
3860         else {
3861             shortbuffered = 0;
3862             /* remember that cnt can be negative */
3863             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3864         }
3865     }
3866     else
3867         shortbuffered = 0;
3868     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
3869     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3870     DEBUG_P(PerlIO_printf(Perl_debug_log,
3871         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3872     DEBUG_P(PerlIO_printf(Perl_debug_log,
3873         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3874                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3875                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3876     for (;;) {
3877       screamer:
3878         if (cnt > 0) {
3879             if (rslen) {
3880                 while (cnt > 0) {                    /* this     |  eat */
3881                     cnt--;
3882                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
3883                         goto thats_all_folks;        /* screams  |  sed :-) */
3884                 }
3885             }
3886             else {
3887                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
3888                 bp += cnt;                           /* screams  |  dust */
3889                 ptr += cnt;                          /* louder   |  sed :-) */
3890                 cnt = 0;
3891             }
3892         }
3893
3894         if (shortbuffered) {            /* oh well, must extend */
3895             cnt = shortbuffered;
3896             shortbuffered = 0;
3897             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3898             SvCUR_set(sv, bpx);
3899             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3900             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3901             continue;
3902         }
3903
3904         DEBUG_P(PerlIO_printf(Perl_debug_log,
3905                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3906                               PTR2UV(ptr),(long)cnt));
3907         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3908         DEBUG_P(PerlIO_printf(Perl_debug_log,
3909             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3910             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3911             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3912         /* This used to call 'filbuf' in stdio form, but as that behaves like
3913            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3914            another abstraction.  */
3915         i   = PerlIO_getc(fp);          /* get more characters */
3916         DEBUG_P(PerlIO_printf(Perl_debug_log,
3917             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3918             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3919             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3920         cnt = PerlIO_get_cnt(fp);
3921         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
3922         DEBUG_P(PerlIO_printf(Perl_debug_log,
3923             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3924
3925         if (i == EOF)                   /* all done for ever? */
3926             goto thats_really_all_folks;
3927
3928         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3929         SvCUR_set(sv, bpx);
3930         SvGROW(sv, bpx + cnt + 2);
3931         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3932
3933         *bp++ = i;                      /* store character from PerlIO_getc */
3934
3935         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
3936             goto thats_all_folks;
3937     }
3938
3939 thats_all_folks:
3940     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3941           memNE((char*)bp - rslen, rsptr, rslen))
3942         goto screamer;                          /* go back to the fray */
3943 thats_really_all_folks:
3944     if (shortbuffered)
3945         cnt += shortbuffered;
3946         DEBUG_P(PerlIO_printf(Perl_debug_log,
3947             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3948     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
3949     DEBUG_P(PerlIO_printf(Perl_debug_log,
3950         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3951         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3952         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3953     *bp = '\0';
3954     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
3955     DEBUG_P(PerlIO_printf(Perl_debug_log,
3956         "Screamer: done, len=%ld, string=|%.*s|\n",
3957         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3958     }
3959    else
3960     {
3961 #ifndef EPOC
3962        /*The big, slow, and stupid way */
3963         STDCHAR buf[8192];
3964 #else
3965         /* Need to work around EPOC SDK features          */
3966         /* On WINS: MS VC5 generates calls to _chkstk,    */
3967         /* if a `large' stack frame is allocated          */
3968         /* gcc on MARM does not generate calls like these */
3969         STDCHAR buf[1024];
3970 #endif
3971
3972 screamer2:
3973         if (rslen) {
3974             register STDCHAR *bpe = buf + sizeof(buf);
3975             bp = buf;
3976             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3977                 ; /* keep reading */
3978             cnt = bp - buf;
3979         }
3980         else {
3981             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3982             /* Accomodate broken VAXC compiler, which applies U8 cast to
3983              * both args of ?: operator, causing EOF to change into 255
3984              */
3985             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3986         }
3987
3988         if (append)
3989             sv_catpvn(sv, (char *) buf, cnt);
3990         else
3991             sv_setpvn(sv, (char *) buf, cnt);
3992
3993         if (i != EOF &&                 /* joy */
3994             (!rslen ||
3995              SvCUR(sv) < rslen ||
3996              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3997         {
3998             append = -1;
3999             /*
4000              * If we're reading from a TTY and we get a short read,
4001              * indicating that the user hit his EOF character, we need
4002              * to notice it now, because if we try to read from the TTY
4003              * again, the EOF condition will disappear.
4004              *
4005              * The comparison of cnt to sizeof(buf) is an optimization
4006              * that prevents unnecessary calls to feof().
4007              *
4008              * - jik 9/25/96
4009              */
4010             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4011                 goto screamer2;
4012         }
4013     }
4014
4015     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4016         while (i != EOF) {      /* to make sure file boundaries work right */
4017             i = PerlIO_getc(fp);
4018             if (i != '\n') {
4019                 PerlIO_ungetc(fp,i);
4020                 break;
4021             }
4022         }
4023     }
4024
4025 #ifdef WIN32
4026     win32_strip_return(sv);
4027 #endif
4028
4029     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4030 }
4031
4032
4033 void
4034 Perl_sv_inc(pTHX_ register SV *sv)
4035 {
4036     register char *d;
4037     int flags;
4038
4039     if (!sv)
4040         return;
4041     if (SvGMAGICAL(sv))
4042         mg_get(sv);
4043     if (SvTHINKFIRST(sv)) {
4044         if (SvREADONLY(sv)) {
4045             dTHR;
4046             if (PL_curcop != &PL_compiling)
4047                 Perl_croak(aTHX_ PL_no_modify);
4048         }
4049         if (SvROK(sv)) {
4050             IV i;
4051             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4052                 return;
4053             i = PTR2IV(SvRV(sv));
4054             sv_unref(sv);
4055             sv_setiv(sv, i);
4056         }
4057     }
4058     flags = SvFLAGS(sv);
4059     if (flags & SVp_NOK) {
4060         (void)SvNOK_only(sv);
4061         SvNVX(sv) += 1.0;
4062         return;
4063     }
4064     if (flags & SVp_IOK) {
4065         if (SvIsUV(sv)) {
4066             if (SvUVX(sv) == UV_MAX)
4067                 sv_setnv(sv, (NV)UV_MAX + 1.0);
4068             else
4069                 (void)SvIOK_only_UV(sv);
4070                 ++SvUVX(sv);
4071         } else {
4072             if (SvIVX(sv) == IV_MAX)
4073                 sv_setnv(sv, (NV)IV_MAX + 1.0);
4074             else {
4075                 (void)SvIOK_only(sv);
4076                 ++SvIVX(sv);
4077             }
4078         }
4079         return;
4080     }
4081     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4082         if ((flags & SVTYPEMASK) < SVt_PVNV)
4083             sv_upgrade(sv, SVt_NV);
4084         SvNVX(sv) = 1.0;
4085         (void)SvNOK_only(sv);
4086         return;
4087     }
4088     d = SvPVX(sv);
4089     while (isALPHA(*d)) d++;
4090     while (isDIGIT(*d)) d++;
4091     if (*d) {
4092         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
4093         return;
4094     }
4095     d--;
4096     while (d >= SvPVX(sv)) {
4097         if (isDIGIT(*d)) {
4098             if (++*d <= '9')
4099                 return;
4100             *(d--) = '0';
4101         }
4102         else {
4103 #ifdef EBCDIC
4104             /* MKS: The original code here died if letters weren't consecutive.
4105              * at least it didn't have to worry about non-C locales.  The
4106              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4107              * arranged in order (although not consecutively) and that only
4108              * [A-Za-z] are accepted by isALPHA in the C locale.
4109              */
4110             if (*d != 'z' && *d != 'Z') {
4111                 do { ++*d; } while (!isALPHA(*d));
4112                 return;
4113             }
4114             *(d--) -= 'z' - 'a';
4115 #else
4116             ++*d;
4117             if (isALPHA(*d))
4118                 return;
4119             *(d--) -= 'z' - 'a' + 1;
4120 #endif
4121         }
4122     }
4123     /* oh,oh, the number grew */
4124     SvGROW(sv, SvCUR(sv) + 2);
4125     SvCUR(sv)++;
4126     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4127         *d = d[-1];
4128     if (isDIGIT(d[1]))
4129         *d = '1';
4130     else
4131         *d = d[1];
4132 }
4133
4134 void
4135 Perl_sv_dec(pTHX_ register SV *sv)
4136 {
4137     int flags;
4138
4139     if (!sv)
4140         return;
4141     if (SvGMAGICAL(sv))
4142         mg_get(sv);
4143     if (SvTHINKFIRST(sv)) {
4144         if (SvREADONLY(sv)) {
4145             dTHR;
4146             if (PL_curcop != &PL_compiling)
4147                 Perl_croak(aTHX_ PL_no_modify);
4148         }
4149         if (SvROK(sv)) {
4150             IV i;
4151             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4152                 return;
4153             i = PTR2IV(SvRV(sv));
4154             sv_unref(sv);
4155             sv_setiv(sv, i);
4156         }
4157     }
4158     flags = SvFLAGS(sv);
4159     if (flags & SVp_NOK) {
4160         SvNVX(sv) -= 1.0;
4161         (void)SvNOK_only(sv);
4162         return;
4163     }
4164     if (flags & SVp_IOK) {
4165         if (SvIsUV(sv)) {
4166             if (SvUVX(sv) == 0) {
4167                 (void)SvIOK_only(sv);
4168                 SvIVX(sv) = -1;
4169             }
4170             else {
4171                 (void)SvIOK_only_UV(sv);
4172                 --SvUVX(sv);
4173             }
4174         } else {
4175             if (SvIVX(sv) == IV_MIN)
4176                 sv_setnv(sv, (NV)IV_MIN - 1.0);
4177             else {
4178                 (void)SvIOK_only(sv);
4179                 --SvIVX(sv);
4180             }
4181         }
4182         return;
4183     }
4184     if (!(flags & SVp_POK)) {
4185         if ((flags & SVTYPEMASK) < SVt_PVNV)
4186             sv_upgrade(sv, SVt_NV);
4187         SvNVX(sv) = -1.0;
4188         (void)SvNOK_only(sv);
4189         return;
4190     }
4191     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4192 }
4193
4194 /* Make a string that will exist for the duration of the expression
4195  * evaluation.  Actually, it may have to last longer than that, but
4196  * hopefully we won't free it until it has been assigned to a
4197  * permanent location. */
4198
4199 SV *
4200 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4201 {
4202     dTHR;
4203     register SV *sv;
4204
4205     new_SV(sv);
4206     sv_setsv(sv,oldstr);
4207     EXTEND_MORTAL(1);
4208     PL_tmps_stack[++PL_tmps_ix] = sv;
4209     SvTEMP_on(sv);
4210     return sv;
4211 }
4212
4213 SV *
4214 Perl_sv_newmortal(pTHX)
4215 {
4216     dTHR;
4217     register SV *sv;
4218
4219     new_SV(sv);
4220     SvFLAGS(sv) = SVs_TEMP;
4221     EXTEND_MORTAL(1);
4222     PL_tmps_stack[++PL_tmps_ix] = sv;
4223     return sv;
4224 }
4225
4226 /* same thing without the copying */
4227
4228 SV *
4229 Perl_sv_2mortal(pTHX_ register SV *sv)
4230 {
4231     dTHR;
4232     if (!sv)
4233         return sv;
4234     if (SvREADONLY(sv) && SvIMMORTAL(sv))
4235         return sv;
4236     EXTEND_MORTAL(1);
4237     PL_tmps_stack[++PL_tmps_ix] = sv;
4238     SvTEMP_on(sv);
4239     return sv;
4240 }
4241
4242 SV *
4243 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4244 {
4245     register SV *sv;
4246
4247     new_SV(sv);
4248     if (!len)
4249         len = strlen(s);
4250     sv_setpvn(sv,s,len);
4251     return sv;
4252 }
4253
4254 SV *
4255 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4256 {
4257     register SV *sv;
4258
4259     new_SV(sv);
4260     sv_setpvn(sv,s,len);
4261     return sv;
4262 }
4263
4264 #if defined(PERL_IMPLICIT_CONTEXT)
4265 SV *
4266 Perl_newSVpvf_nocontext(const char* pat, ...)
4267 {
4268     dTHX;
4269     register SV *sv;
4270     va_list args;
4271     va_start(args, pat);
4272     sv = vnewSVpvf(pat, &args);
4273     va_end(args);
4274     return sv;
4275 }
4276 #endif
4277
4278 SV *
4279 Perl_newSVpvf(pTHX_ const char* pat, ...)
4280 {
4281     register SV *sv;
4282     va_list args;
4283     va_start(args, pat);
4284     sv = vnewSVpvf(pat, &args);
4285     va_end(args);
4286     return sv;
4287 }
4288
4289 SV *
4290 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4291 {
4292     register SV *sv;
4293     new_SV(sv);
4294     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4295     return sv;
4296 }
4297
4298 SV *
4299 Perl_newSVnv(pTHX_ NV n)
4300 {
4301     register SV *sv;
4302
4303     new_SV(sv);
4304     sv_setnv(sv,n);
4305     return sv;
4306 }
4307
4308 SV *
4309 Perl_newSViv(pTHX_ IV i)
4310 {
4311     register SV *sv;
4312
4313     new_SV(sv);
4314     sv_setiv(sv,i);
4315     return sv;
4316 }
4317
4318 SV *
4319 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4320 {
4321     dTHR;
4322     register SV *sv;
4323
4324     new_SV(sv);
4325     sv_upgrade(sv, SVt_RV);
4326     SvTEMP_off(tmpRef);
4327     SvRV(sv) = tmpRef;
4328     SvROK_on(sv);
4329     return sv;
4330 }
4331
4332 SV *
4333 Perl_newRV(pTHX_ SV *tmpRef)
4334 {
4335     return newRV_noinc(SvREFCNT_inc(tmpRef));
4336 }
4337
4338 /* make an exact duplicate of old */
4339
4340 SV *
4341 Perl_newSVsv(pTHX_ register SV *old)
4342 {
4343     dTHR;
4344     register SV *sv;
4345
4346     if (!old)
4347         return Nullsv;
4348     if (SvTYPE(old) == SVTYPEMASK) {
4349         if (ckWARN_d(WARN_INTERNAL))
4350             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4351         return Nullsv;
4352     }
4353     new_SV(sv);
4354     if (SvTEMP(old)) {
4355         SvTEMP_off(old);
4356         sv_setsv(sv,old);
4357         SvTEMP_on(old);
4358     }
4359     else
4360         sv_setsv(sv,old);
4361     return sv;
4362 }
4363
4364 void
4365 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4366 {
4367     register HE *entry;
4368     register GV *gv;
4369     register SV *sv;
4370     register I32 i;
4371     register PMOP *pm;
4372     register I32 max;
4373     char todo[PERL_UCHAR_MAX+1];
4374
4375     if (!stash)
4376         return;
4377
4378     if (!*s) {          /* reset ?? searches */
4379         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4380             pm->op_pmdynflags &= ~PMdf_USED;
4381         }
4382         return;
4383     }
4384
4385     /* reset variables */
4386
4387     if (!HvARRAY(stash))
4388         return;
4389
4390     Zero(todo, 256, char);
4391     while (*s) {
4392         i = (unsigned char)*s;
4393         if (s[1] == '-') {
4394             s += 2;
4395         }
4396         max = (unsigned char)*s++;
4397         for ( ; i <= max; i++) {
4398             todo[i] = 1;
4399         }
4400         for (i = 0; i <= (I32) HvMAX(stash); i++) {
4401             for (entry = HvARRAY(stash)[i];
4402                  entry;
4403                  entry = HeNEXT(entry))
4404             {
4405                 if (!todo[(U8)*HeKEY(entry)])
4406                     continue;
4407                 gv = (GV*)HeVAL(entry);
4408                 sv = GvSV(gv);
4409                 if (SvTHINKFIRST(sv)) {
4410                     if (!SvREADONLY(sv) && SvROK(sv))
4411                         sv_unref(sv);
4412                     continue;
4413                 }
4414                 (void)SvOK_off(sv);
4415                 if (SvTYPE(sv) >= SVt_PV) {
4416                     SvCUR_set(sv, 0);
4417                     if (SvPVX(sv) != Nullch)
4418                         *SvPVX(sv) = '\0';
4419                     SvTAINT(sv);
4420                 }
4421                 if (GvAV(gv)) {
4422                     av_clear(GvAV(gv));
4423                 }
4424                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4425                     hv_clear(GvHV(gv));
4426 #ifndef VMS  /* VMS has no environ array */
4427                     if (gv == PL_envgv)
4428                         environ[0] = Nullch;
4429 #endif
4430                 }
4431             }
4432         }
4433     }
4434 }
4435
4436 IO*
4437 Perl_sv_2io(pTHX_ SV *sv)
4438 {
4439     IO* io;
4440     GV* gv;
4441     STRLEN n_a;
4442
4443     switch (SvTYPE(sv)) {
4444     case SVt_PVIO:
4445         io = (IO*)sv;
4446         break;
4447     case SVt_PVGV:
4448         gv = (GV*)sv;
4449         io = GvIO(gv);
4450         if (!io)
4451             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4452         break;
4453     default:
4454         if (!SvOK(sv))
4455             Perl_croak(aTHX_ PL_no_usym, "filehandle");
4456         if (SvROK(sv))
4457             return sv_2io(SvRV(sv));
4458         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4459         if (gv)
4460             io = GvIO(gv);
4461         else
4462             io = 0;
4463         if (!io)
4464             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4465         break;
4466     }
4467     return io;
4468 }
4469
4470 CV *
4471 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4472 {
4473     GV *gv;
4474     CV *cv;
4475     STRLEN n_a;
4476
4477     if (!sv)
4478         return *gvp = Nullgv, Nullcv;
4479     switch (SvTYPE(sv)) {
4480     case SVt_PVCV:
4481         *st = CvSTASH(sv);
4482         *gvp = Nullgv;
4483         return (CV*)sv;
4484     case SVt_PVHV:
4485     case SVt_PVAV:
4486         *gvp = Nullgv;
4487         return Nullcv;
4488     case SVt_PVGV:
4489         gv = (GV*)sv;
4490         *gvp = gv;
4491         *st = GvESTASH(gv);
4492         goto fix_gv;
4493
4494     default:
4495         if (SvGMAGICAL(sv))
4496             mg_get(sv);
4497         if (SvROK(sv)) {
4498             dTHR;
4499             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
4500             tryAMAGICunDEREF(to_cv);
4501
4502             sv = SvRV(sv);
4503             if (SvTYPE(sv) == SVt_PVCV) {
4504                 cv = (CV*)sv;
4505                 *gvp = Nullgv;
4506                 *st = CvSTASH(cv);
4507                 return cv;
4508             }
4509             else if(isGV(sv))
4510                 gv = (GV*)sv;
4511             else
4512                 Perl_croak(aTHX_ "Not a subroutine reference");
4513         }
4514         else if (isGV(sv))
4515             gv = (GV*)sv;
4516         else
4517             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4518         *gvp = gv;
4519         if (!gv)
4520             return Nullcv;
4521         *st = GvESTASH(gv);
4522     fix_gv:
4523         if (lref && !GvCVu(gv)) {
4524             SV *tmpsv;
4525             ENTER;
4526             tmpsv = NEWSV(704,0);
4527             gv_efullname3(tmpsv, gv, Nullch);
4528             /* XXX this is probably not what they think they're getting.
4529              * It has the same effect as "sub name;", i.e. just a forward
4530              * declaration! */
4531             newSUB(start_subparse(FALSE, 0),
4532                    newSVOP(OP_CONST, 0, tmpsv),
4533                    Nullop,
4534                    Nullop);
4535             LEAVE;
4536             if (!GvCVu(gv))
4537                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4538         }
4539         return GvCVu(gv);
4540     }
4541 }
4542
4543 I32
4544 Perl_sv_true(pTHX_ register SV *sv)
4545 {
4546     dTHR;
4547     if (!sv)
4548         return 0;
4549     if (SvPOK(sv)) {
4550         register XPV* tXpv;
4551         if ((tXpv = (XPV*)SvANY(sv)) &&
4552                 (*tXpv->xpv_pv > '0' ||
4553                 tXpv->xpv_cur > 1 ||
4554                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4555             return 1;
4556         else
4557             return 0;
4558     }
4559     else {
4560         if (SvIOK(sv))
4561             return SvIVX(sv) != 0;
4562         else {
4563             if (SvNOK(sv))
4564                 return SvNVX(sv) != 0.0;
4565             else
4566                 return sv_2bool(sv);
4567         }
4568     }
4569 }
4570
4571 IV
4572 Perl_sv_iv(pTHX_ register SV *sv)
4573 {
4574     if (SvIOK(sv)) {
4575         if (SvIsUV(sv))
4576             return (IV)SvUVX(sv);
4577         return SvIVX(sv);
4578     }
4579     return sv_2iv(sv);
4580 }
4581
4582 UV
4583 Perl_sv_uv(pTHX_ register SV *sv)
4584 {
4585     if (SvIOK(sv)) {
4586         if (SvIsUV(sv))
4587             return SvUVX(sv);
4588         return (UV)SvIVX(sv);
4589     }
4590     return sv_2uv(sv);
4591 }
4592
4593 NV
4594 Perl_sv_nv(pTHX_ register SV *sv)
4595 {
4596     if (SvNOK(sv))
4597         return SvNVX(sv);
4598     return sv_2nv(sv);
4599 }
4600
4601 char *
4602 Perl_sv_pv(pTHX_ SV *sv)
4603 {
4604     STRLEN n_a;
4605
4606     if (SvPOK(sv))
4607         return SvPVX(sv);
4608
4609     return sv_2pv(sv, &n_a);
4610 }
4611
4612 char *
4613 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4614 {
4615     if (SvPOK(sv)) {
4616         *lp = SvCUR(sv);
4617         return SvPVX(sv);
4618     }
4619     return sv_2pv(sv, lp);
4620 }
4621
4622 char *
4623 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4624 {
4625     char *s;
4626
4627     if (SvTHINKFIRST(sv) && !SvROK(sv))
4628         sv_force_normal(sv);
4629
4630     if (SvPOK(sv)) {
4631         *lp = SvCUR(sv);
4632     }
4633     else {
4634         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4635             dTHR;
4636             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4637                 PL_op_name[PL_op->op_type]);
4638         }
4639         else
4640             s = sv_2pv(sv, lp);
4641         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
4642             STRLEN len = *lp;
4643
4644             if (SvROK(sv))
4645                 sv_unref(sv);
4646             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
4647             SvGROW(sv, len + 1);
4648             Move(s,SvPVX(sv),len,char);
4649             SvCUR_set(sv, len);
4650             *SvEND(sv) = '\0';
4651         }
4652         if (!SvPOK(sv)) {
4653             SvPOK_on(sv);               /* validate pointer */
4654             SvTAINT(sv);
4655             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4656                                   PTR2UV(sv),SvPVX(sv)));
4657         }
4658     }
4659     return SvPVX(sv);
4660 }
4661
4662 char *
4663 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4664 {
4665     if (ob && SvOBJECT(sv))
4666         return HvNAME(SvSTASH(sv));
4667     else {
4668         switch (SvTYPE(sv)) {
4669         case SVt_NULL:
4670         case SVt_IV:
4671         case SVt_NV:
4672         case SVt_RV:
4673         case SVt_PV:
4674         case SVt_PVIV:
4675         case SVt_PVNV:
4676         case SVt_PVMG:
4677         case SVt_PVBM:
4678                                 if (SvROK(sv))
4679                                     return "REF";
4680                                 else
4681                                     return "SCALAR";
4682         case SVt_PVLV:          return "LVALUE";
4683         case SVt_PVAV:          return "ARRAY";
4684         case SVt_PVHV:          return "HASH";
4685         case SVt_PVCV:          return "CODE";
4686         case SVt_PVGV:          return "GLOB";
4687         case SVt_PVFM:          return "FORMAT";
4688         default:                return "UNKNOWN";
4689         }
4690     }
4691 }
4692
4693 int
4694 Perl_sv_isobject(pTHX_ SV *sv)
4695 {
4696     if (!sv)
4697         return 0;
4698     if (SvGMAGICAL(sv))
4699         mg_get(sv);
4700     if (!SvROK(sv))
4701         return 0;
4702     sv = (SV*)SvRV(sv);
4703     if (!SvOBJECT(sv))
4704         return 0;
4705     return 1;
4706 }
4707
4708 int
4709 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4710 {
4711     if (!sv)
4712         return 0;
4713     if (SvGMAGICAL(sv))
4714         mg_get(sv);
4715     if (!SvROK(sv))
4716         return 0;
4717     sv = (SV*)SvRV(sv);
4718     if (!SvOBJECT(sv))
4719         return 0;
4720
4721     return strEQ(HvNAME(SvSTASH(sv)), name);
4722 }
4723
4724 SV*
4725 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4726 {
4727     dTHR;
4728     SV *sv;
4729
4730     new_SV(sv);
4731
4732     SV_CHECK_THINKFIRST(rv);
4733     SvAMAGIC_off(rv);
4734
4735     if (SvTYPE(rv) < SVt_RV)
4736       sv_upgrade(rv, SVt_RV);
4737
4738     (void)SvOK_off(rv);
4739     SvRV(rv) = sv;
4740     SvROK_on(rv);
4741
4742     if (classname) {
4743         HV* stash = gv_stashpv(classname, TRUE);
4744         (void)sv_bless(rv, stash);
4745     }
4746     return sv;
4747 }
4748
4749 SV*
4750 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4751 {
4752     if (!pv) {
4753         sv_setsv(rv, &PL_sv_undef);
4754         SvSETMAGIC(rv);
4755     }
4756     else
4757         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4758     return rv;
4759 }
4760
4761 SV*
4762 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4763 {
4764     sv_setiv(newSVrv(rv,classname), iv);
4765     return rv;
4766 }
4767
4768 SV*
4769 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4770 {
4771     sv_setnv(newSVrv(rv,classname), nv);
4772     return rv;
4773 }
4774
4775 SV*
4776 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4777 {
4778     sv_setpvn(newSVrv(rv,classname), pv, n);
4779     return rv;
4780 }
4781
4782 SV*
4783 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4784 {
4785     dTHR;
4786     SV *tmpRef;
4787     if (!SvROK(sv))
4788         Perl_croak(aTHX_ "Can't bless non-reference value");
4789     tmpRef = SvRV(sv);
4790     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4791         if (SvREADONLY(tmpRef))
4792             Perl_croak(aTHX_ PL_no_modify);
4793         if (SvOBJECT(tmpRef)) {
4794             if (SvTYPE(tmpRef) != SVt_PVIO)
4795                 --PL_sv_objcount;
4796             SvREFCNT_dec(SvSTASH(tmpRef));
4797         }
4798     }
4799     SvOBJECT_on(tmpRef);
4800     if (SvTYPE(tmpRef) != SVt_PVIO)
4801         ++PL_sv_objcount;
4802     (void)SvUPGRADE(tmpRef, SVt_PVMG);
4803     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4804
4805     if (Gv_AMG(stash))
4806         SvAMAGIC_on(sv);
4807     else
4808         SvAMAGIC_off(sv);
4809
4810     return sv;
4811 }
4812
4813 STATIC void
4814 S_sv_unglob(pTHX_ SV *sv)
4815 {
4816     assert(SvTYPE(sv) == SVt_PVGV);
4817     SvFAKE_off(sv);
4818     if (GvGP(sv))
4819         gp_free((GV*)sv);
4820     if (GvSTASH(sv)) {
4821         SvREFCNT_dec(GvSTASH(sv));
4822         GvSTASH(sv) = Nullhv;
4823     }
4824     sv_unmagic(sv, '*');
4825     Safefree(GvNAME(sv));
4826     GvMULTI_off(sv);
4827     SvFLAGS(sv) &= ~SVTYPEMASK;
4828     SvFLAGS(sv) |= SVt_PVMG;
4829 }
4830
4831 void
4832 Perl_sv_unref(pTHX_ SV *sv)
4833 {
4834     SV* rv = SvRV(sv);
4835
4836     if (SvWEAKREF(sv)) {
4837         sv_del_backref(sv);
4838         SvWEAKREF_off(sv);
4839         SvRV(sv) = 0;
4840         return;
4841     }
4842     SvRV(sv) = 0;
4843     SvROK_off(sv);
4844     if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4845         SvREFCNT_dec(rv);
4846     else
4847         sv_2mortal(rv);         /* Schedule for freeing later */
4848 }
4849
4850 void
4851 Perl_sv_taint(pTHX_ SV *sv)
4852 {
4853     sv_magic((sv), Nullsv, 't', Nullch, 0);
4854 }
4855
4856 void
4857 Perl_sv_untaint(pTHX_ SV *sv)
4858 {
4859     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4860         MAGIC *mg = mg_find(sv, 't');
4861         if (mg)
4862             mg->mg_len &= ~1;
4863     }
4864 }
4865
4866 bool
4867 Perl_sv_tainted(pTHX_ SV *sv)
4868 {
4869     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4870         MAGIC *mg = mg_find(sv, 't');
4871         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4872             return TRUE;
4873     }
4874     return FALSE;
4875 }
4876
4877 void
4878 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4879 {
4880     char buf[TYPE_CHARS(UV)];
4881     char *ebuf;
4882     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4883
4884     sv_setpvn(sv, ptr, ebuf - ptr);
4885 }
4886
4887
4888 void
4889 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4890 {
4891     char buf[TYPE_CHARS(UV)];
4892     char *ebuf;
4893     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4894
4895     sv_setpvn(sv, ptr, ebuf - ptr);
4896     SvSETMAGIC(sv);
4897 }
4898
4899 #if defined(PERL_IMPLICIT_CONTEXT)
4900 void
4901 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4902 {
4903     dTHX;
4904     va_list args;
4905     va_start(args, pat);
4906     sv_vsetpvf(sv, pat, &args);
4907     va_end(args);
4908 }
4909
4910
4911 void
4912 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4913 {
4914     dTHX;
4915     va_list args;
4916     va_start(args, pat);
4917     sv_vsetpvf_mg(sv, pat, &args);
4918     va_end(args);
4919 }
4920 #endif
4921
4922 void
4923 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4924 {
4925     va_list args;
4926     va_start(args, pat);
4927     sv_vsetpvf(sv, pat, &args);
4928     va_end(args);
4929 }
4930
4931 void
4932 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4933 {
4934     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4935 }
4936
4937 void
4938 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4939 {
4940     va_list args;
4941     va_start(args, pat);
4942     sv_vsetpvf_mg(sv, pat, &args);
4943     va_end(args);
4944 }
4945
4946 void
4947 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4948 {
4949     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4950     SvSETMAGIC(sv);
4951 }
4952
4953 #if defined(PERL_IMPLICIT_CONTEXT)
4954 void
4955 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4956 {
4957     dTHX;
4958     va_list args;
4959     va_start(args, pat);
4960     sv_vcatpvf(sv, pat, &args);
4961     va_end(args);
4962 }
4963
4964 void
4965 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4966 {
4967     dTHX;
4968     va_list args;
4969     va_start(args, pat);
4970     sv_vcatpvf_mg(sv, pat, &args);
4971     va_end(args);
4972 }
4973 #endif
4974
4975 void
4976 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4977 {
4978     va_list args;
4979     va_start(args, pat);
4980     sv_vcatpvf(sv, pat, &args);
4981     va_end(args);
4982 }
4983
4984 void
4985 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4986 {
4987     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4988 }
4989
4990 void
4991 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4992 {
4993     va_list args;
4994     va_start(args, pat);
4995     sv_vcatpvf_mg(sv, pat, &args);
4996     va_end(args);
4997 }
4998
4999 void
5000 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5001 {
5002     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5003     SvSETMAGIC(sv);
5004 }
5005
5006 void
5007 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5008 {
5009     sv_setpvn(sv, "", 0);
5010     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5011 }
5012
5013 void
5014 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5015 {
5016     dTHR;
5017     char *p;
5018     char *q;
5019     char *patend;
5020     STRLEN origlen;
5021     I32 svix = 0;
5022     static char nullstr[] = "(null)";
5023
5024     /* no matter what, this is a string now */
5025     (void)SvPV_force(sv, origlen);
5026
5027     /* special-case "", "%s", and "%_" */
5028     if (patlen == 0)
5029         return;
5030     if (patlen == 2 && pat[0] == '%') {
5031         switch (pat[1]) {
5032         case 's':
5033             if (args) {
5034                 char *s = va_arg(*args, char*);
5035                 sv_catpv(sv, s ? s : nullstr);
5036             }
5037             else if (svix < svmax)
5038                 sv_catsv(sv, *svargs);
5039             return;
5040         case '_':
5041             if (args) {
5042                 sv_catsv(sv, va_arg(*args, SV*));
5043                 return;
5044             }
5045             /* See comment on '_' below */
5046             break;
5047         }
5048     }
5049
5050     patend = (char*)pat + patlen;
5051     for (p = (char*)pat; p < patend; p = q) {
5052         bool alt = FALSE;
5053         bool left = FALSE;
5054         char fill = ' ';
5055         char plus = 0;
5056         char intsize = 0;
5057         STRLEN width = 0;
5058         STRLEN zeros = 0;
5059         bool has_precis = FALSE;
5060         STRLEN precis = 0;
5061
5062         char esignbuf[4];
5063         U8 utf8buf[10];
5064         STRLEN esignlen = 0;
5065
5066         char *eptr = Nullch;
5067         STRLEN elen = 0;
5068         /* Times 4: a decimal digit takes more than 3 binary digits.
5069          * NV_DIG: mantissa takes than many decimal digits.
5070          * Plus 32: Playing safe. */
5071         char ebuf[IV_DIG * 4 + NV_DIG + 32];
5072         /* large enough for "%#.#f" --chip */
5073         /* what about long double NVs? --jhi */
5074         char c;
5075         int i;
5076         unsigned base;
5077         IV iv;
5078         UV uv;
5079         NV nv;
5080         STRLEN have;
5081         STRLEN need;
5082         STRLEN gap;
5083
5084         for (q = p; q < patend && *q != '%'; ++q) ;
5085         if (q > p) {
5086             sv_catpvn(sv, p, q - p);
5087             p = q;
5088         }
5089         if (q++ >= patend)
5090             break;
5091
5092         /* FLAGS */
5093
5094         while (*q) {
5095             switch (*q) {
5096             case ' ':
5097             case '+':
5098                 plus = *q++;
5099                 continue;
5100
5101             case '-':
5102                 left = TRUE;
5103                 q++;
5104                 continue;
5105
5106             case '0':
5107                 fill = *q++;
5108                 continue;
5109
5110             case '#':
5111                 alt = TRUE;
5112                 q++;
5113                 continue;
5114
5115             default:
5116                 break;
5117             }
5118             break;
5119         }
5120
5121         /* WIDTH */
5122
5123         switch (*q) {
5124         case '1': case '2': case '3':
5125         case '4': case '5': case '6':
5126         case '7': case '8': case '9':
5127             width = 0;
5128             while (isDIGIT(*q))
5129                 width = width * 10 + (*q++ - '0');
5130             break;
5131
5132         case '*':
5133             if (args)
5134                 i = va_arg(*args, int);
5135             else
5136                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5137             left |= (i < 0);
5138             width = (i < 0) ? -i : i;
5139             q++;
5140             break;
5141         }
5142
5143         /* PRECISION */
5144
5145         if (*q == '.') {
5146             q++;
5147             if (*q == '*') {
5148                 if (args)
5149                     i = va_arg(*args, int);
5150                 else
5151                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5152                 precis = (i < 0) ? 0 : i;
5153                 q++;
5154             }
5155             else {
5156                 precis = 0;
5157                 while (isDIGIT(*q))
5158                     precis = precis * 10 + (*q++ - '0');
5159             }
5160             has_precis = TRUE;
5161         }
5162
5163         /* SIZE */
5164
5165         switch (*q) {
5166 #ifdef HAS_QUAD
5167         case 'L':                       /* Ld */
5168         case 'q':                       /* qd */
5169             intsize = 'q';
5170             q++;
5171             break;
5172 #endif
5173         case 'l':
5174 #ifdef HAS_QUAD
5175              if (*(q + 1) == 'l') {     /* lld */
5176                 intsize = 'q';
5177                 q += 2;
5178                 break;
5179              }
5180 #endif
5181             /* FALL THROUGH */
5182         case 'h':
5183             /* FALL THROUGH */
5184         case 'V':
5185             intsize = *q++;
5186             break;
5187         }
5188
5189         /* CONVERSION */
5190
5191         switch (c = *q++) {
5192
5193             /* STRINGS */
5194
5195         case '%':
5196             eptr = q - 1;
5197             elen = 1;
5198             goto string;
5199
5200         case 'c':
5201             if (IN_UTF8) {
5202                 if (args)
5203                     uv = va_arg(*args, int);
5204                 else
5205                     uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5206
5207                 eptr = (char*)utf8buf;
5208                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5209                 goto string;
5210             }
5211             if (args)
5212                 c = va_arg(*args, int);
5213             else
5214                 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5215             eptr = &c;
5216             elen = 1;
5217             goto string;
5218
5219         case 's':
5220             if (args) {
5221                 eptr = va_arg(*args, char*);
5222                 if (eptr)
5223 #ifdef MACOS_TRADITIONAL
5224                   /* On MacOS, %#s format is used for Pascal strings */
5225                   if (alt)
5226                     elen = *eptr++;
5227                   else
5228 #endif
5229                     elen = strlen(eptr);
5230                 else {
5231                     eptr = nullstr;
5232                     elen = sizeof nullstr - 1;
5233                 }
5234             }
5235             else if (svix < svmax) {
5236                 eptr = SvPVx(svargs[svix++], elen);
5237                 if (IN_UTF8) {
5238                     if (has_precis && precis < elen) {
5239                         I32 p = precis;
5240                         sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5241                         precis = p;
5242                     }
5243                     if (width) { /* fudge width (can't fudge elen) */
5244                         width += elen - sv_len_utf8(svargs[svix - 1]);
5245                     }
5246                 }
5247             }
5248             goto string;
5249
5250         case '_':
5251             /*
5252              * The "%_" hack might have to be changed someday,
5253              * if ISO or ANSI decide to use '_' for something.
5254              * So we keep it hidden from users' code.
5255              */
5256             if (!args)
5257                 goto unknown;
5258             eptr = SvPVx(va_arg(*args, SV*), elen);
5259
5260         string:
5261             if (has_precis && elen > precis)
5262                 elen = precis;
5263             break;
5264
5265             /* INTEGERS */
5266
5267         case 'p':
5268             if (args)
5269                 uv = PTR2UV(va_arg(*args, void*));
5270             else
5271                 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5272             base = 16;
5273             goto integer;
5274
5275         case 'D':
5276 #ifdef IV_IS_QUAD
5277             intsize = 'q';
5278 #else
5279             intsize = 'l';
5280 #endif
5281             /* FALL THROUGH */
5282         case 'd':
5283         case 'i':
5284             if (args) {
5285                 switch (intsize) {
5286                 case 'h':       iv = (short)va_arg(*args, int); break;
5287                 default:        iv = va_arg(*args, int); break;
5288                 case 'l':       iv = va_arg(*args, long); break;
5289                 case 'V':       iv = va_arg(*args, IV); break;
5290 #ifdef HAS_QUAD
5291                 case 'q':       iv = va_arg(*args, Quad_t); break;
5292 #endif
5293                 }
5294             }
5295             else {
5296                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5297                 switch (intsize) {
5298                 case 'h':       iv = (short)iv; break;
5299                 default:        iv = (int)iv; break;
5300                 case 'l':       iv = (long)iv; break;
5301                 case 'V':       break;
5302 #ifdef HAS_QUAD
5303                 case 'q':       iv = (Quad_t)iv; break;
5304 #endif
5305                 }
5306             }
5307             if (iv >= 0) {
5308                 uv = iv;
5309                 if (plus)
5310                     esignbuf[esignlen++] = plus;
5311             }
5312             else {
5313                 uv = -iv;
5314                 esignbuf[esignlen++] = '-';
5315             }
5316             base = 10;
5317             goto integer;
5318
5319         case 'U':
5320 #ifdef IV_IS_QUAD
5321             intsize = 'q';
5322 #else
5323             intsize = 'l';
5324 #endif
5325             /* FALL THROUGH */
5326         case 'u':
5327             base = 10;
5328             goto uns_integer;
5329
5330         case 'b':
5331             base = 2;
5332             goto uns_integer;
5333
5334         case 'O':
5335 #ifdef IV_IS_QUAD
5336             intsize = 'q';
5337 #else
5338             intsize = 'l';
5339 #endif
5340             /* FALL THROUGH */
5341         case 'o':
5342             base = 8;
5343             goto uns_integer;
5344
5345         case 'X':
5346         case 'x':
5347             base = 16;
5348
5349         uns_integer:
5350             if (args) {
5351                 switch (intsize) {
5352                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
5353                 default:   uv = va_arg(*args, unsigned); break;
5354                 case 'l':  uv = va_arg(*args, unsigned long); break;
5355                 case 'V':  uv = va_arg(*args, UV); break;
5356 #ifdef HAS_QUAD
5357                 case 'q':  uv = va_arg(*args, Quad_t); break;
5358 #endif
5359                 }
5360             }
5361             else {
5362                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5363                 switch (intsize) {
5364                 case 'h':       uv = (unsigned short)uv; break;
5365                 default:        uv = (unsigned)uv; break;
5366                 case 'l':       uv = (unsigned long)uv; break;
5367                 case 'V':       break;
5368 #ifdef HAS_QUAD
5369                 case 'q':       uv = (Quad_t)uv; break;
5370 #endif
5371                 }
5372             }
5373
5374         integer:
5375             eptr = ebuf + sizeof ebuf;
5376             switch (base) {
5377                 unsigned dig;
5378             case 16:
5379                 if (!uv)
5380                     alt = FALSE;
5381                 p = (char*)((c == 'X')
5382                             ? "0123456789ABCDEF" : "0123456789abcdef");
5383                 do {
5384                     dig = uv & 15;
5385                     *--eptr = p[dig];
5386                 } while (uv >>= 4);
5387                 if (alt) {
5388                     esignbuf[esignlen++] = '0';
5389                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
5390                 }
5391                 break;
5392             case 8:
5393                 do {
5394                     dig = uv & 7;
5395                     *--eptr = '0' + dig;
5396                 } while (uv >>= 3);
5397                 if (alt && *eptr != '0')
5398                     *--eptr = '0';
5399                 break;
5400             case 2:
5401                 do {
5402                     dig = uv & 1;
5403                     *--eptr = '0' + dig;
5404                 } while (uv >>= 1);
5405                 if (alt) {
5406                     esignbuf[esignlen++] = '0';
5407                     esignbuf[esignlen++] = 'b';
5408                 }
5409                 break;
5410             default:            /* it had better be ten or less */
5411 #if defined(PERL_Y2KWARN)
5412                 if (ckWARN(WARN_MISC)) {
5413                     STRLEN n;
5414                     char *s = SvPV(sv,n);
5415                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5416                         && (n == 2 || !isDIGIT(s[n-3])))
5417                     {
5418                         Perl_warner(aTHX_ WARN_MISC,
5419                                     "Possible Y2K bug: %%%c %s",
5420                                     c, "format string following '19'");
5421                     }
5422                 }
5423 #endif
5424                 do {
5425                     dig = uv % base;
5426                     *--eptr = '0' + dig;
5427                 } while (uv /= base);
5428                 break;
5429             }
5430             elen = (ebuf + sizeof ebuf) - eptr;
5431             if (has_precis) {
5432                 if (precis > elen)
5433                     zeros = precis - elen;
5434                 else if (precis == 0 && elen == 1 && *eptr == '0')
5435                     elen = 0;
5436             }
5437             break;
5438
5439             /* FLOATING POINT */
5440
5441         case 'F':
5442             c = 'f';            /* maybe %F isn't supported here */
5443             /* FALL THROUGH */
5444         case 'e': case 'E':
5445         case 'f':
5446         case 'g': case 'G':
5447
5448             /* This is evil, but floating point is even more evil */
5449
5450             if (args)
5451                 nv = va_arg(*args, NV);
5452             else
5453                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5454
5455             need = 0;
5456             if (c != 'e' && c != 'E') {
5457                 i = PERL_INT_MIN;
5458                 (void)frexp(nv, &i);
5459                 if (i == PERL_INT_MIN)
5460                     Perl_die(aTHX_ "panic: frexp");
5461                 if (i > 0)
5462                     need = BIT_DIGITS(i);
5463             }
5464             need += has_precis ? precis : 6; /* known default */
5465             if (need < width)
5466                 need = width;
5467
5468             need += 20; /* fudge factor */
5469             if (PL_efloatsize < need) {
5470                 Safefree(PL_efloatbuf);
5471                 PL_efloatsize = need + 20; /* more fudge */
5472                 New(906, PL_efloatbuf, PL_efloatsize, char);
5473                 PL_efloatbuf[0] = '\0';
5474             }
5475
5476             eptr = ebuf + sizeof ebuf;
5477             *--eptr = '\0';
5478             *--eptr = c;
5479 #ifdef USE_LONG_DOUBLE
5480             {
5481                 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5482                 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5483             }
5484 #endif
5485             if (has_precis) {
5486                 base = precis;
5487                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5488                 *--eptr = '.';
5489             }
5490             if (width) {
5491                 base = width;
5492                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5493             }
5494             if (fill == '0')
5495                 *--eptr = fill;
5496             if (left)
5497                 *--eptr = '-';
5498             if (plus)
5499                 *--eptr = plus;
5500             if (alt)
5501                 *--eptr = '#';
5502             *--eptr = '%';
5503
5504             {
5505                 RESTORE_NUMERIC_STANDARD();
5506                 (void)sprintf(PL_efloatbuf, eptr, nv);
5507                 RESTORE_NUMERIC_LOCAL();
5508             }
5509
5510             eptr = PL_efloatbuf;
5511             elen = strlen(PL_efloatbuf);
5512             break;
5513
5514             /* SPECIAL */
5515
5516         case 'n':
5517             i = SvCUR(sv) - origlen;
5518             if (args) {
5519                 switch (intsize) {
5520                 case 'h':       *(va_arg(*args, short*)) = i; break;
5521                 default:        *(va_arg(*args, int*)) = i; break;
5522                 case 'l':       *(va_arg(*args, long*)) = i; break;
5523                 case 'V':       *(va_arg(*args, IV*)) = i; break;
5524 #ifdef HAS_QUAD
5525                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
5526 #endif
5527                 }
5528             }
5529             else if (svix < svmax)
5530                 sv_setuv(svargs[svix++], (UV)i);
5531             continue;   /* not "break" */
5532
5533             /* UNKNOWN */
5534
5535         default:
5536       unknown:
5537             if (!args && ckWARN(WARN_PRINTF) &&
5538                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5539                 SV *msg = sv_newmortal();
5540                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5541                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5542                 if (c) {
5543                     if (isPRINT(c))
5544                         Perl_sv_catpvf(aTHX_ msg,
5545                                        "\"%%%c\"", c & 0xFF);
5546                     else
5547                         Perl_sv_catpvf(aTHX_ msg,
5548                                        "\"%%\\%03"UVof"\"",
5549                                        (UV)c & 0xFF);
5550                 } else
5551                     sv_catpv(msg, "end of string");
5552                 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5553             }
5554
5555             /* output mangled stuff ... */
5556             if (c == '\0')
5557                 --q;
5558             eptr = p;
5559             elen = q - p;
5560
5561             /* ... right here, because formatting flags should not apply */
5562             SvGROW(sv, SvCUR(sv) + elen + 1);
5563             p = SvEND(sv);
5564             memcpy(p, eptr, elen);
5565             p += elen;
5566             *p = '\0';
5567             SvCUR(sv) = p - SvPVX(sv);
5568             continue;   /* not "break" */
5569         }
5570
5571         have = esignlen + zeros + elen;
5572         need = (have > width ? have : width);
5573         gap = need - have;
5574
5575         SvGROW(sv, SvCUR(sv) + need + 1);
5576         p = SvEND(sv);
5577         if (esignlen && fill == '0') {
5578             for (i = 0; i < esignlen; i++)
5579                 *p++ = esignbuf[i];
5580         }
5581         if (gap && !left) {
5582             memset(p, fill, gap);
5583             p += gap;
5584         }
5585         if (esignlen && fill != '0') {
5586             for (i = 0; i < esignlen; i++)
5587                 *p++ = esignbuf[i];
5588         }
5589         if (zeros) {
5590             for (i = zeros; i; i--)
5591                 *p++ = '0';
5592         }
5593         if (elen) {
5594             memcpy(p, eptr, elen);
5595             p += elen;
5596         }
5597         if (gap && left) {
5598             memset(p, ' ', gap);
5599             p += gap;
5600         }
5601         *p = '\0';
5602         SvCUR(sv) = p - SvPVX(sv);
5603     }
5604 }
5605
5606 #if defined(USE_ITHREADS)
5607
5608 #if defined(USE_THREADS)
5609 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
5610 #endif
5611
5612 #ifndef OpREFCNT_inc
5613 #  define OpREFCNT_inc(o)       ((o) ? (++(o)->op_targ, (o)) : Nullop)
5614 #endif
5615
5616 #ifndef GpREFCNT_inc
5617 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
5618 #endif
5619
5620
5621 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
5622 #define av_dup(s)       (AV*)sv_dup((SV*)s)
5623 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5624 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
5625 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5626 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
5627 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5628 #define io_dup(s)       (IO*)sv_dup((SV*)s)
5629 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5630 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
5631 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5632 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
5633 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
5634
5635 REGEXP *
5636 Perl_re_dup(pTHX_ REGEXP *r)
5637 {
5638     /* XXX fix when pmop->op_pmregexp becomes shared */
5639     return ReREFCNT_inc(r);
5640 }
5641
5642 PerlIO *
5643 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5644 {
5645     if (!fp)
5646         return (PerlIO*)NULL;
5647     return fp;          /* XXX */
5648     /* return PerlIO_fdopen(PerlIO_fileno(fp),
5649                          type == '<' ? "r" : type == '>' ? "w" : "rw"); */
5650 }
5651
5652 DIR *
5653 Perl_dirp_dup(pTHX_ DIR *dp)
5654 {
5655     if (!dp)
5656         return (DIR*)NULL;
5657     /* XXX TODO */
5658     return dp;
5659 }
5660
5661 GP *
5662 Perl_gp_dup(pTHX_ GP *gp)
5663 {
5664     GP *ret;
5665     if (!gp)
5666         return (GP*)NULL;
5667     /* look for it in the table first */
5668     ret = (GP*)sv_table_fetch(PL_sv_table, (SV*)gp);
5669     if (ret)
5670         return ret;
5671
5672     /* create anew and remember what it is */
5673     Newz(0, ret, 1, GP);
5674     sv_table_store(PL_sv_table, (SV*)gp, (SV*)ret);
5675
5676     /* clone */
5677     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
5678     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
5679     ret->gp_io          = io_dup_inc(gp->gp_io);
5680     ret->gp_form        = cv_dup_inc(gp->gp_form);
5681     ret->gp_av          = av_dup_inc(gp->gp_av);
5682     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
5683     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
5684     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
5685     ret->gp_cvgen       = gp->gp_cvgen;
5686     ret->gp_flags       = gp->gp_flags;
5687     ret->gp_line        = gp->gp_line;
5688     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
5689     return ret;
5690 }
5691
5692 MAGIC *
5693 Perl_mg_dup(pTHX_ MAGIC *mg)
5694 {
5695     MAGIC *mgret = (MAGIC*)NULL;
5696     MAGIC *mgprev;
5697     if (!mg)
5698         return (MAGIC*)NULL;
5699     /* XXX need to handle aliases here? */
5700
5701     for (; mg; mg = mg->mg_moremagic) {
5702         MAGIC *nmg;
5703         Newz(0, nmg, 1, MAGIC);
5704         if (!mgret)
5705             mgret = nmg;
5706         else
5707             mgprev->mg_moremagic = nmg;
5708         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
5709         nmg->mg_private = mg->mg_private;
5710         nmg->mg_type    = mg->mg_type;
5711         nmg->mg_flags   = mg->mg_flags;
5712         if (mg->mg_type == 'r') {
5713             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5714         }
5715         else {
5716             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5717                               ? sv_dup_inc(mg->mg_obj)
5718                               : sv_dup(mg->mg_obj);
5719         }
5720         nmg->mg_len     = mg->mg_len;
5721         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
5722         if (mg->mg_ptr && mg->mg_type != 'g') {
5723             if (mg->mg_len >= 0) {
5724                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
5725                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
5726                     AMT *amtp = (AMT*)mg->mg_ptr;
5727                     AMT *namtp = (AMT*)nmg->mg_ptr;
5728                     I32 i;
5729                     for (i = 1; i < NofAMmeth; i++) {
5730                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
5731                     }
5732                 }
5733             }
5734             else if (mg->mg_len == HEf_SVKEY)
5735                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5736         }
5737         mgprev = nmg;
5738     }
5739     return mgret;
5740 }
5741
5742 SVTBL *
5743 Perl_sv_table_new(pTHX)
5744 {
5745     SVTBL *tbl;
5746     Newz(0, tbl, 1, SVTBL);
5747     tbl->tbl_max        = 511;
5748     tbl->tbl_items      = 0;
5749     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*);
5750     return tbl;
5751 }
5752
5753 SV *
5754 Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv)
5755 {
5756     SVTBLENT *tblent;
5757     UV hash = (UV)sv;
5758     assert(tbl);
5759     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5760     for (; tblent; tblent = tblent->next) {
5761         if (tblent->oldval == sv)
5762             return tblent->newval;
5763     }
5764     return Nullsv;
5765 }
5766
5767 void
5768 Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new)
5769 {
5770     SVTBLENT *tblent, **otblent;
5771     UV hash = (UV)old;
5772     bool i = 1;
5773     assert(tbl);
5774     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5775     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5776         if (tblent->oldval == old) {
5777             tblent->newval = new;
5778             tbl->tbl_items++;
5779             return;
5780         }
5781     }
5782     Newz(0, tblent, 1, SVTBLENT);
5783     tblent->oldval = old;
5784     tblent->newval = new;
5785     tblent->next = *otblent;
5786     *otblent = tblent;
5787     tbl->tbl_items++;
5788     if (i && tbl->tbl_items > tbl->tbl_max)
5789         sv_table_split(tbl);
5790 }
5791
5792 void
5793 Perl_sv_table_split(pTHX_ SVTBL *tbl)
5794 {
5795     SVTBLENT **ary = tbl->tbl_ary;
5796     UV oldsize = tbl->tbl_max + 1;
5797     UV newsize = oldsize * 2;
5798     UV i;
5799
5800     Renew(ary, newsize, SVTBLENT*);
5801     Zero(&ary[oldsize], newsize-oldsize, SVTBLENT*);
5802     tbl->tbl_max = --newsize;
5803     tbl->tbl_ary = ary;
5804     for (i=0; i < oldsize; i++, ary++) {
5805         SVTBLENT **curentp, **entp, *ent;
5806         if (!*ary)
5807             continue;
5808         curentp = ary + oldsize;
5809         for (entp = ary, ent = *ary; ent; ent = *entp) {
5810             if ((newsize & (UV)ent->oldval) != i) {
5811                 *entp = ent->next;
5812                 ent->next = *curentp;
5813                 *curentp = ent;
5814                 continue;
5815             }
5816             else
5817                 entp = &ent->next;
5818         }
5819     }
5820 }
5821
5822 #ifdef DEBUGGING
5823 DllExport char *PL_watch_pvx;
5824 #endif
5825
5826 SV *
5827 Perl_sv_dup(pTHX_ SV *sstr)
5828 {
5829     U32 sflags;
5830     int dtype;
5831     int stype;
5832     SV *dstr;
5833
5834     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
5835         return Nullsv;
5836     /* look for it in the table first */
5837     dstr = sv_table_fetch(PL_sv_table, sstr);
5838     if (dstr)
5839         return dstr;
5840
5841     /* XXX TODO: sanity-check sv_dup() vs sv_dup_inc() appropriateness */
5842
5843     /* create anew and remember what it is */
5844     new_SV(dstr);
5845     sv_table_store(PL_sv_table, sstr, dstr);
5846
5847     /* clone */
5848     SvFLAGS(dstr)       = SvFLAGS(sstr);
5849     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
5850     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
5851
5852 #ifdef DEBUGGING
5853     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
5854         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
5855                       PL_watch_pvx, SvPVX(sstr));
5856 #endif
5857
5858     switch (SvTYPE(sstr)) {
5859     case SVt_NULL:
5860         SvANY(dstr)     = NULL;
5861         break;
5862     case SVt_IV:
5863         SvANY(dstr)     = new_XIV();
5864         SvIVX(dstr)     = SvIVX(sstr);
5865         break;
5866     case SVt_NV:
5867         SvANY(dstr)     = new_XNV();
5868         SvNVX(dstr)     = SvNVX(sstr);
5869         break;
5870     case SVt_RV:
5871         SvANY(dstr)     = new_XRV();
5872         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
5873         break;
5874     case SVt_PV:
5875         SvANY(dstr)     = new_XPV();
5876         SvCUR(dstr)     = SvCUR(sstr);
5877         SvLEN(dstr)     = SvLEN(sstr);
5878         if (SvROK(sstr))
5879             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5880         else if (SvPVX(sstr) && SvLEN(sstr))
5881             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5882         else
5883             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5884         break;
5885     case SVt_PVIV:
5886         SvANY(dstr)     = new_XPVIV();
5887         SvCUR(dstr)     = SvCUR(sstr);
5888         SvLEN(dstr)     = SvLEN(sstr);
5889         SvIVX(dstr)     = SvIVX(sstr);
5890         if (SvROK(sstr))
5891             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5892         else if (SvPVX(sstr) && SvLEN(sstr))
5893             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5894         else
5895             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5896         break;
5897     case SVt_PVNV:
5898         SvANY(dstr)     = new_XPVNV();
5899         SvCUR(dstr)     = SvCUR(sstr);
5900         SvLEN(dstr)     = SvLEN(sstr);
5901         SvIVX(dstr)     = SvIVX(sstr);
5902         SvNVX(dstr)     = SvNVX(sstr);
5903         if (SvROK(sstr))
5904             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5905         else if (SvPVX(sstr) && SvLEN(sstr))
5906             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5907         else
5908             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5909         break;
5910     case SVt_PVMG:
5911         SvANY(dstr)     = new_XPVMG();
5912         SvCUR(dstr)     = SvCUR(sstr);
5913         SvLEN(dstr)     = SvLEN(sstr);
5914         SvIVX(dstr)     = SvIVX(sstr);
5915         SvNVX(dstr)     = SvNVX(sstr);
5916         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5917         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
5918         if (SvROK(sstr))
5919             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5920         else if (SvPVX(sstr) && SvLEN(sstr))
5921             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5922         else
5923             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5924         break;
5925     case SVt_PVBM:
5926         SvANY(dstr)     = new_XPVBM();
5927         SvCUR(dstr)     = SvCUR(sstr);
5928         SvLEN(dstr)     = SvLEN(sstr);
5929         SvIVX(dstr)     = SvIVX(sstr);
5930         SvNVX(dstr)     = SvNVX(sstr);
5931         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5932         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
5933         if (SvROK(sstr))
5934             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5935         else if (SvPVX(sstr) && SvLEN(sstr))
5936             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5937         else
5938             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5939         BmRARE(dstr)    = BmRARE(sstr);
5940         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
5941         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
5942         break;
5943     case SVt_PVLV:
5944         SvANY(dstr)     = new_XPVLV();
5945         SvCUR(dstr)     = SvCUR(sstr);
5946         SvLEN(dstr)     = SvLEN(sstr);
5947         SvIVX(dstr)     = SvIVX(sstr);
5948         SvNVX(dstr)     = SvNVX(sstr);
5949         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5950         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
5951         if (SvROK(sstr))
5952             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5953         else if (SvPVX(sstr) && SvLEN(sstr))
5954             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5955         else
5956             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5957         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
5958         LvTARGLEN(dstr) = LvTARGLEN(sstr);
5959         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
5960         LvTYPE(dstr)    = LvTYPE(sstr);
5961         break;
5962     case SVt_PVGV:
5963         SvANY(dstr)     = new_XPVGV();
5964         SvCUR(dstr)     = SvCUR(sstr);
5965         SvLEN(dstr)     = SvLEN(sstr);
5966         SvIVX(dstr)     = SvIVX(sstr);
5967         SvNVX(dstr)     = SvNVX(sstr);
5968         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5969         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
5970         if (SvROK(sstr))
5971             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5972         else if (SvPVX(sstr) && SvLEN(sstr))
5973             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5974         else
5975             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5976         GvNAMELEN(dstr) = GvNAMELEN(sstr);
5977         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
5978         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
5979         GvFLAGS(dstr)   = GvFLAGS(sstr);
5980         GvGP(dstr)      = gp_dup(GvGP(sstr));
5981         (void)GpREFCNT_inc(GvGP(dstr));
5982         break;
5983     case SVt_PVIO:
5984         SvANY(dstr)     = new_XPVIO();
5985         SvCUR(dstr)     = SvCUR(sstr);
5986         SvLEN(dstr)     = SvLEN(sstr);
5987         SvIVX(dstr)     = SvIVX(sstr);
5988         SvNVX(dstr)     = SvNVX(sstr);
5989         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
5990         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
5991         if (SvROK(sstr))
5992             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
5993         else if (SvPVX(sstr) && SvLEN(sstr))
5994             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5995         else
5996             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
5997         IoIFP(dstr)             = fp_dup(IoIFP(sstr), IoTYPE(sstr));
5998         if (IoOFP(sstr) == IoIFP(sstr))
5999             IoOFP(dstr) = IoIFP(dstr);
6000         else
6001             IoOFP(dstr)         = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6002         /* PL_rsfp_filters entries have fake IoDIRP() */
6003         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6004             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
6005         else
6006             IoDIRP(dstr)        = IoDIRP(sstr);
6007         IoLINES(dstr)           = IoLINES(sstr);
6008         IoPAGE(dstr)            = IoPAGE(sstr);
6009         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
6010         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
6011         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
6012         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
6013         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
6014         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
6015         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
6016         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
6017         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
6018         IoTYPE(dstr)            = IoTYPE(sstr);
6019         IoFLAGS(dstr)           = IoFLAGS(sstr);
6020         break;
6021     case SVt_PVAV:
6022         SvANY(dstr)     = new_XPVAV();
6023         SvCUR(dstr)     = SvCUR(sstr);
6024         SvLEN(dstr)     = SvLEN(sstr);
6025         SvIVX(dstr)     = SvIVX(sstr);
6026         SvNVX(dstr)     = SvNVX(sstr);
6027         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6028         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6029         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6030         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6031         if (AvARRAY((AV*)sstr)) {
6032             SV **dst_ary, **src_ary;
6033             SSize_t items = AvFILLp((AV*)sstr) + 1;
6034
6035             src_ary = AvARRAY((AV*)sstr);
6036             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6037             SvPVX(dstr) = (char*)dst_ary;
6038             AvALLOC((AV*)dstr) = dst_ary;
6039             if (AvREAL((AV*)sstr)) {
6040                 while (items-- > 0)
6041                     *dst_ary++ = sv_dup_inc(*src_ary++);
6042             }
6043             else {
6044                 while (items-- > 0)
6045                     *dst_ary++ = sv_dup(*src_ary++);
6046             }
6047             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6048             while (items-- > 0) {
6049                 *dst_ary++ = &PL_sv_undef;
6050             }
6051         }
6052         else {
6053             SvPVX(dstr)         = Nullch;
6054             AvALLOC((AV*)dstr)  = (SV**)NULL;
6055         }
6056         break;
6057     case SVt_PVHV:
6058         SvANY(dstr)     = new_XPVHV();
6059         SvCUR(dstr)     = SvCUR(sstr);
6060         SvLEN(dstr)     = SvLEN(sstr);
6061         SvIVX(dstr)     = SvIVX(sstr);
6062         SvNVX(dstr)     = SvNVX(sstr);
6063         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6064         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6065         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
6066         if (HvARRAY((HV*)sstr)) {
6067             HE *entry;
6068             STRLEN i = 0;
6069             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6070             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6071             Newz(0, dxhv->xhv_array,
6072                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6073             while (i <= sxhv->xhv_max) {
6074                 HE *dentry, *oentry;
6075                 entry = ((HE**)sxhv->xhv_array)[i];
6076                 dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6077                 ((HE**)dxhv->xhv_array)[i] = dentry;
6078                 while (entry) {
6079                     entry = HeNEXT(entry);
6080                     oentry = dentry;
6081                     dentry = he_dup(entry, !!HvSHAREKEYS(sstr));
6082                     HeNEXT(oentry) = dentry;
6083                 }
6084                 ++i;
6085             }
6086             if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) {
6087                 entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter];
6088                 while (entry && entry != sxhv->xhv_eiter)
6089                     entry = HeNEXT(entry);
6090                 dxhv->xhv_eiter = entry;
6091             }
6092             else
6093                 dxhv->xhv_eiter = (HE*)NULL;
6094         }
6095         else {
6096             SvPVX(dstr)         = Nullch;
6097             HvEITER((HV*)dstr)  = (HE*)NULL;
6098         }
6099         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
6100         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
6101         break;
6102     case SVt_PVFM:
6103         SvANY(dstr)     = new_XPVFM();
6104         FmLINES(dstr)   = FmLINES(sstr);
6105         goto dup_pvcv;
6106         /* NOTREACHED */
6107     case SVt_PVCV:
6108         SvANY(dstr)     = new_XPVCV();
6109 dup_pvcv:
6110         SvCUR(dstr)     = SvCUR(sstr);
6111         SvLEN(dstr)     = SvLEN(sstr);
6112         SvIVX(dstr)     = SvIVX(sstr);
6113         SvNVX(dstr)     = SvNVX(sstr);
6114         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6115         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6116         if (SvPVX(sstr) && SvLEN(sstr))
6117             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6118         else
6119             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6120         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6121         CvSTART(dstr)   = CvSTART(sstr);
6122         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
6123         CvXSUB(dstr)    = CvXSUB(sstr);
6124         CvXSUBANY(dstr) = CvXSUBANY(sstr);
6125         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
6126         CvDEPTH(dstr)   = CvDEPTH(sstr);
6127         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6128             /* XXX padlists are real, but pretend to be not */
6129             AvREAL_on(CvPADLIST(sstr));
6130             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6131             AvREAL_off(CvPADLIST(sstr));
6132             AvREAL_off(CvPADLIST(dstr));
6133         }
6134         else
6135             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6136         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6137         CvFLAGS(dstr)   = CvFLAGS(sstr);
6138         break;
6139     default:
6140         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6141         break;
6142     }
6143
6144     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6145         ++PL_sv_objcount;
6146
6147     return dstr;
6148 }
6149
6150 PerlInterpreter *
6151 perl_clone_using(PerlInterpreter *proto_perl, IV flags,
6152                  struct IPerlMem* ipM, struct IPerlEnv* ipE,
6153                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6154                  struct IPerlDir* ipD, struct IPerlSock* ipS,
6155                  struct IPerlProc* ipP)
6156 {
6157     IV i;
6158     SV *sv;
6159     SV **svp;
6160     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6161     PERL_SET_INTERP(my_perl);
6162
6163 #ifdef DEBUGGING
6164     memset(my_perl, 0x0, sizeof(PerlInterpreter));
6165     PL_markstack = 0;
6166     PL_scopestack = 0;
6167     PL_savestack = 0;
6168     PL_retstack = 0;
6169 #else
6170 #  if 0
6171     Copy(proto_perl, my_perl, 1, PerlInterpreter);
6172 #  endif
6173 #endif
6174
6175     /* XXX many of the string copies here can be optimized if they're
6176      * constants; they need to be allocated as common memory and just
6177      * their pointers copied. */
6178
6179     /* host pointers */
6180     PL_Mem              = ipM;
6181     PL_Env              = ipE;
6182     PL_StdIO            = ipStd;
6183     PL_LIO              = ipLIO;
6184     PL_Dir              = ipD;
6185     PL_Sock             = ipS;
6186     PL_Proc             = ipP;
6187
6188     /* arena roots */
6189     PL_xiv_arenaroot    = NULL;
6190     PL_xiv_root         = NULL;
6191     PL_xnv_root         = NULL;
6192     PL_xrv_root         = NULL;
6193     PL_xpv_root         = NULL;
6194     PL_xpviv_root       = NULL;
6195     PL_xpvnv_root       = NULL;
6196     PL_xpvcv_root       = NULL;
6197     PL_xpvav_root       = NULL;
6198     PL_xpvhv_root       = NULL;
6199     PL_xpvmg_root       = NULL;
6200     PL_xpvlv_root       = NULL;
6201     PL_xpvbm_root       = NULL;
6202     PL_he_root          = NULL;
6203     PL_nice_chunk       = NULL;
6204     PL_nice_chunk_size  = 0;
6205     PL_sv_count         = 0;
6206     PL_sv_objcount      = 0;
6207     PL_sv_root          = Nullsv;
6208     PL_sv_arenaroot     = Nullsv;
6209
6210     PL_debug            = proto_perl->Idebug;
6211
6212     /* create SV map for pointer relocation */
6213     PL_sv_table = sv_table_new();
6214
6215     /* initialize these special pointers as early as possible */
6216     SvANY(&PL_sv_undef)         = NULL;
6217     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
6218     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
6219     sv_table_store(PL_sv_table, &proto_perl->Isv_undef, &PL_sv_undef);
6220
6221     SvANY(&PL_sv_no)            = new_XPVNV();
6222     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
6223     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6224     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
6225     SvCUR(&PL_sv_no)            = 0;
6226     SvLEN(&PL_sv_no)            = 1;
6227     SvNVX(&PL_sv_no)            = 0;
6228     sv_table_store(PL_sv_table, &proto_perl->Isv_no, &PL_sv_no);
6229
6230     SvANY(&PL_sv_yes)           = new_XPVNV();
6231     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
6232     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6233     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
6234     SvCUR(&PL_sv_yes)           = 1;
6235     SvLEN(&PL_sv_yes)           = 2;
6236     SvNVX(&PL_sv_yes)           = 1;
6237     sv_table_store(PL_sv_table, &proto_perl->Isv_yes, &PL_sv_yes);
6238
6239     /* create shared string table */
6240     PL_strtab           = newHV();
6241     HvSHAREKEYS_off(PL_strtab);
6242     hv_ksplit(PL_strtab, 512);
6243     sv_table_store(PL_sv_table, (SV*)proto_perl->Istrtab, (SV*)PL_strtab);
6244
6245     PL_compiling                = proto_perl->Icompiling;
6246     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
6247     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
6248     if (!specialWARN(PL_compiling.cop_warnings))
6249         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6250     if (proto_perl->Tcurcop == &proto_perl->Icompiling)
6251         PL_curcop       = &PL_compiling;
6252     else
6253         PL_curcop       = proto_perl->Tcurcop;
6254
6255     /* pseudo environmental stuff */
6256     PL_origargc         = proto_perl->Iorigargc;
6257     i = PL_origargc;
6258     New(0, PL_origargv, i+1, char*);
6259     PL_origargv[i] = '\0';
6260     while (i-- > 0) {
6261         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
6262     }
6263     PL_envgv            = gv_dup(proto_perl->Ienvgv);
6264     PL_incgv            = gv_dup(proto_perl->Iincgv);
6265     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
6266     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
6267     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
6268     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
6269
6270     /* switches */
6271     PL_minus_c          = proto_perl->Iminus_c;
6272     Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char);
6273     PL_localpatches     = proto_perl->Ilocalpatches;
6274     PL_splitstr         = proto_perl->Isplitstr;
6275     PL_preprocess       = proto_perl->Ipreprocess;
6276     PL_minus_n          = proto_perl->Iminus_n;
6277     PL_minus_p          = proto_perl->Iminus_p;
6278     PL_minus_l          = proto_perl->Iminus_l;
6279     PL_minus_a          = proto_perl->Iminus_a;
6280     PL_minus_F          = proto_perl->Iminus_F;
6281     PL_doswitches       = proto_perl->Idoswitches;
6282     PL_dowarn           = proto_perl->Idowarn;
6283     PL_doextract        = proto_perl->Idoextract;
6284     PL_sawampersand     = proto_perl->Isawampersand;
6285     PL_unsafe           = proto_perl->Iunsafe;
6286     PL_inplace          = SAVEPV(proto_perl->Iinplace);
6287     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
6288     PL_perldb           = proto_perl->Iperldb;
6289     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6290
6291     /* magical thingies */
6292     /* XXX time(&PL_basetime) instead? */
6293     PL_basetime         = proto_perl->Ibasetime;
6294     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
6295
6296     PL_maxsysfd         = proto_perl->Imaxsysfd;
6297     PL_multiline        = proto_perl->Imultiline;
6298     PL_statusvalue      = proto_perl->Istatusvalue;
6299 #ifdef VMS
6300     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
6301 #endif
6302
6303     /* shortcuts to various I/O objects */
6304     PL_stdingv          = gv_dup(proto_perl->Istdingv);
6305     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
6306     PL_defgv            = gv_dup(proto_perl->Idefgv);
6307     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
6308     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
6309     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
6310
6311     /* shortcuts to regexp stuff */
6312     PL_replgv           = gv_dup(proto_perl->Ireplgv);
6313
6314     /* shortcuts to misc objects */
6315     PL_errgv            = gv_dup(proto_perl->Ierrgv);
6316
6317     /* shortcuts to debugging objects */
6318     PL_DBgv             = gv_dup(proto_perl->IDBgv);
6319     PL_DBline           = gv_dup(proto_perl->IDBline);
6320     PL_DBsub            = gv_dup(proto_perl->IDBsub);
6321     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
6322     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
6323     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
6324     PL_lineary          = av_dup(proto_perl->Ilineary);
6325     PL_dbargs           = av_dup(proto_perl->Idbargs);
6326
6327     /* symbol tables */
6328     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
6329     PL_curstash         = hv_dup(proto_perl->Tcurstash);
6330     PL_debstash         = hv_dup(proto_perl->Idebstash);
6331     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
6332     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
6333
6334     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
6335     PL_endav            = av_dup_inc(proto_perl->Iendav);
6336     PL_stopav           = av_dup_inc(proto_perl->Istopav);
6337     PL_initav           = av_dup_inc(proto_perl->Iinitav);
6338
6339     PL_sub_generation   = proto_perl->Isub_generation;
6340
6341     /* funky return mechanisms */
6342     PL_forkprocess      = proto_perl->Iforkprocess;
6343
6344     /* subprocess state */
6345     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
6346
6347     /* internal state */
6348     PL_tainting         = proto_perl->Itainting;
6349     PL_maxo             = proto_perl->Imaxo;
6350     if (proto_perl->Iop_mask)
6351         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6352     else
6353         PL_op_mask      = Nullch;
6354
6355     /* current interpreter roots */
6356     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
6357     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
6358     PL_main_start       = proto_perl->Imain_start;
6359     PL_eval_root        = proto_perl->Ieval_root;
6360     PL_eval_start       = proto_perl->Ieval_start;
6361
6362     /* runtime control stuff */
6363     PL_curcopdb         = proto_perl->Icurcopdb;
6364     PL_copline          = proto_perl->Icopline;
6365
6366     PL_filemode         = proto_perl->Ifilemode;
6367     PL_lastfd           = proto_perl->Ilastfd;
6368     PL_oldname          = proto_perl->Ioldname; /* XXX */
6369     PL_Argv             = NULL;
6370     PL_Cmd              = Nullch;
6371     PL_gensym           = proto_perl->Igensym;
6372     PL_preambled        = proto_perl->Ipreambled;
6373     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
6374     PL_laststatval      = proto_perl->Ilaststatval;
6375     PL_laststype        = proto_perl->Ilaststype;
6376     PL_mess_sv          = Nullsv;
6377
6378     PL_orslen           = proto_perl->Iorslen;
6379     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
6380     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
6381
6382     /* interpreter atexit processing */
6383     PL_exitlistlen      = proto_perl->Iexitlistlen;
6384     if (PL_exitlistlen) {
6385         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6386         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6387     }
6388     else
6389         PL_exitlist     = (PerlExitListEntry*)NULL;
6390     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
6391
6392     PL_profiledata      = NULL;                 /* XXX */
6393     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
6394     /* XXX PL_rsfp_filters entries have fake IoDIRP() */
6395     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
6396
6397     PL_compcv                   = cv_dup(proto_perl->Icompcv);
6398     PL_comppad                  = av_dup(proto_perl->Icomppad);
6399     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
6400     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
6401     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
6402     PL_curpad                   = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL;
6403
6404 #ifdef HAVE_INTERP_INTERN
6405     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6406 #endif
6407
6408     /* more statics moved here */
6409     PL_generation       = proto_perl->Igeneration;
6410     PL_DBcv             = cv_dup(proto_perl->IDBcv);
6411     PL_archpat_auto     = SAVEPV(proto_perl->Iarchpat_auto);
6412
6413     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
6414     PL_in_clean_all     = proto_perl->Iin_clean_all;
6415
6416     PL_uid              = proto_perl->Iuid;
6417     PL_euid             = proto_perl->Ieuid;
6418     PL_gid              = proto_perl->Igid;
6419     PL_egid             = proto_perl->Iegid;
6420     PL_nomemok          = proto_perl->Inomemok;
6421     PL_an               = proto_perl->Ian;
6422     PL_cop_seqmax       = proto_perl->Icop_seqmax;
6423     PL_op_seqmax        = proto_perl->Iop_seqmax;
6424     PL_evalseq          = proto_perl->Ievalseq;
6425     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX */
6426     PL_origalen         = proto_perl->Iorigalen;
6427     PL_pidstatus        = newHV();
6428     PL_osname           = SAVEPV(proto_perl->Iosname);
6429     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
6430     PL_sighandlerp      = proto_perl->Isighandlerp;
6431
6432
6433     PL_runops           = proto_perl->Irunops;
6434
6435     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);        /* XXX */
6436
6437 #ifdef CSH
6438     PL_cshlen           = proto_perl->Icshlen;
6439     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6440 #endif
6441
6442     PL_lex_state        = proto_perl->Ilex_state;
6443     PL_lex_defer        = proto_perl->Ilex_defer;
6444     PL_lex_expect       = proto_perl->Ilex_expect;
6445     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
6446     PL_lex_fakebrack    = proto_perl->Ilex_fakebrack;
6447     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
6448     PL_lex_starts       = proto_perl->Ilex_starts;
6449     PL_lex_stuff        = Nullsv;               /* XXX */
6450     PL_lex_repl         = Nullsv;               /* XXX */
6451     PL_lex_op           = proto_perl->Ilex_op;
6452     PL_lex_inpat        = proto_perl->Ilex_inpat;
6453     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
6454     PL_lex_brackets     = proto_perl->Ilex_brackets;
6455     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6456     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
6457     PL_lex_casemods     = proto_perl->Ilex_casemods;
6458     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6459     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
6460
6461     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6462     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6463     PL_nexttoke         = proto_perl->Inexttoke;
6464
6465     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
6466     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6467     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6468     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6469     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6470     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6471     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6472     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6473     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6474     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6475     PL_pending_ident    = proto_perl->Ipending_ident;
6476     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX */
6477
6478     PL_expect           = proto_perl->Iexpect;
6479
6480     PL_multi_start      = proto_perl->Imulti_start;
6481     PL_multi_end        = proto_perl->Imulti_end;
6482     PL_multi_open       = proto_perl->Imulti_open;
6483     PL_multi_close      = proto_perl->Imulti_close;
6484
6485     PL_error_count      = proto_perl->Ierror_count;
6486     PL_subline          = proto_perl->Isubline;
6487     PL_subname          = sv_dup_inc(proto_perl->Isubname);
6488
6489     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
6490     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
6491     PL_padix                    = proto_perl->Ipadix;
6492     PL_padix_floor              = proto_perl->Ipadix_floor;
6493     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
6494
6495     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6496     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6497     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6498     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6499     PL_last_lop_op      = proto_perl->Ilast_lop_op;
6500     PL_in_my            = proto_perl->Iin_my;
6501     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
6502 #ifdef FCRYPT
6503     PL_cryptseen        = proto_perl->Icryptseen;
6504 #endif
6505
6506     PL_hints            = proto_perl->Ihints;
6507
6508     PL_amagic_generation        = proto_perl->Iamagic_generation;
6509
6510 #ifdef USE_LOCALE_COLLATE
6511     PL_collation_ix     = proto_perl->Icollation_ix;
6512     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
6513     PL_collation_standard       = proto_perl->Icollation_standard;
6514     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
6515     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
6516 #endif /* USE_LOCALE_COLLATE */
6517
6518 #ifdef USE_LOCALE_NUMERIC
6519     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
6520     PL_numeric_standard = proto_perl->Inumeric_standard;
6521     PL_numeric_local    = proto_perl->Inumeric_local;
6522     PL_numeric_radix    = proto_perl->Inumeric_radix;
6523 #endif /* !USE_LOCALE_NUMERIC */
6524
6525     /* utf8 character classes */
6526     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
6527     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
6528     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
6529     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
6530     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
6531     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
6532     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
6533     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
6534     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
6535     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
6536     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
6537     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
6538     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
6539     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
6540     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
6541     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
6542     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
6543
6544     /* swatch cache */
6545     PL_last_swash_hv    = Nullhv;       /* XXX recreate swatch cache? */
6546     PL_last_swash_klen  = 0;
6547     PL_last_swash_key[0]= '\0';
6548     PL_last_swash_tmps  = Nullch;
6549     PL_last_swash_slen  = 0;
6550
6551     /* perly.c globals */
6552     PL_yydebug          = proto_perl->Iyydebug;
6553     PL_yynerrs          = proto_perl->Iyynerrs;
6554     PL_yyerrflag        = proto_perl->Iyyerrflag;
6555     PL_yychar           = proto_perl->Iyychar;
6556     PL_yyval            = proto_perl->Iyyval;
6557     PL_yylval           = proto_perl->Iyylval;
6558
6559     PL_glob_index       = proto_perl->Iglob_index;
6560     PL_srand_called     = proto_perl->Isrand_called;
6561     PL_uudmap['M']      = 0;            /* reinit on demand */
6562     PL_bitcount         = Nullch;       /* reinit on demand */
6563
6564
6565     /* thrdvar.h stuff */
6566
6567 /*    PL_curstackinfo   = clone_stackinfo(proto_perl->Tcurstackinfo);
6568     clone_stacks();
6569     PL_mainstack        = av_dup(proto_perl->Tmainstack);
6570     PL_curstack         = av_dup(proto_perl->Tcurstack);*/      /* XXXXXX */
6571     init_stacks();
6572
6573     PL_op               = proto_perl->Top;
6574     PL_statbuf          = proto_perl->Tstatbuf;
6575     PL_statcache        = proto_perl->Tstatcache;
6576     PL_statgv           = gv_dup(proto_perl->Tstatgv);
6577     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
6578 #ifdef HAS_TIMES
6579     PL_timesbuf         = proto_perl->Ttimesbuf;
6580 #endif
6581
6582     PL_tainted          = proto_perl->Ttainted;
6583     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
6584     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
6585     PL_rs               = sv_dup_inc(proto_perl->Trs);
6586     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
6587     PL_ofslen           = proto_perl->Tofslen;
6588     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
6589     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
6590     PL_chopset          = proto_perl->Tchopset; /* XXX */
6591     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
6592     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
6593     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
6594
6595     PL_restartop        = proto_perl->Trestartop;
6596     PL_in_eval          = proto_perl->Tin_eval;
6597     PL_delaymagic       = proto_perl->Tdelaymagic;
6598     PL_dirty            = proto_perl->Tdirty;
6599     PL_localizing       = proto_perl->Tlocalizing;
6600
6601     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
6602     PL_top_env          = &PL_start_env;
6603     PL_protect          = proto_perl->Tprotect;
6604     PL_errors           = sv_dup_inc(proto_perl->Terrors);
6605     PL_av_fetch_sv      = Nullsv;
6606     PL_hv_fetch_sv      = Nullsv;
6607     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
6608     PL_modcount         = proto_perl->Tmodcount;
6609     PL_lastgotoprobe    = Nullop;
6610     PL_dumpindent       = proto_perl->Tdumpindent;
6611     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
6612     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
6613     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
6614     PL_sortcxix         = proto_perl->Tsortcxix;
6615     PL_efloatbuf        = Nullch;
6616     PL_efloatsize       = 0;
6617
6618     PL_screamfirst      = NULL;
6619     PL_screamnext       = NULL;
6620     PL_maxscream        = -1;
6621     PL_lastscream       = Nullsv;
6622
6623     /* RE engine - function pointers */
6624     PL_regcompp         = proto_perl->Tregcompp;
6625     PL_regexecp         = proto_perl->Tregexecp;
6626     PL_regint_start     = proto_perl->Tregint_start;
6627     PL_regint_string    = proto_perl->Tregint_string;
6628     PL_regfree          = proto_perl->Tregfree;
6629
6630     PL_regindent        = 0;
6631     PL_reginterp_cnt    = 0;
6632     PL_reg_start_tmp    = 0;
6633     PL_reg_start_tmpl   = 0;
6634     PL_reg_poscache     = Nullch;
6635
6636     PL_watchaddr        = NULL;
6637     PL_watchok          = Nullch;
6638
6639     return my_perl;
6640 }
6641
6642 PerlInterpreter *
6643 perl_clone(pTHXx_ IV flags)
6644 {
6645     return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO,
6646                             PL_Dir, PL_Sock, PL_Proc);
6647 }
6648
6649 #endif /* USE_ITHREADS */
6650
6651 #ifdef PERL_OBJECT
6652 #include "XSUB.h"
6653 #endif
6654
6655 static void
6656 do_report_used(pTHXo_ SV *sv)
6657 {
6658     if (SvTYPE(sv) != SVTYPEMASK) {
6659         PerlIO_printf(Perl_debug_log, "****\n");
6660         sv_dump(sv);
6661     }
6662 }
6663
6664 static void
6665 do_clean_objs(pTHXo_ SV *sv)
6666 {
6667     SV* rv;
6668
6669     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
6670         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
6671         SvROK_off(sv);
6672         SvRV(sv) = 0;
6673         SvREFCNT_dec(rv);
6674     }
6675
6676     /* XXX Might want to check arrays, etc. */
6677 }
6678
6679 #ifndef DISABLE_DESTRUCTOR_KLUDGE
6680 static void
6681 do_clean_named_objs(pTHXo_ SV *sv)
6682 {
6683     if (SvTYPE(sv) == SVt_PVGV) {
6684         if ( SvOBJECT(GvSV(sv)) ||
6685              GvAV(sv) && SvOBJECT(GvAV(sv)) ||
6686              GvHV(sv) && SvOBJECT(GvHV(sv)) ||
6687              GvIO(sv) && SvOBJECT(GvIO(sv)) ||
6688              GvCV(sv) && SvOBJECT(GvCV(sv)) )
6689         {
6690             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
6691             SvREFCNT_dec(sv);
6692         }
6693     }
6694 }
6695 #endif
6696
6697 static void
6698 do_clean_all(pTHXo_ SV *sv)
6699 {
6700     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
6701     SvFLAGS(sv) |= SVf_BREAK;
6702     SvREFCNT_dec(sv);
6703 }
6704