sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (c) 1991-1997, 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 #include "perl.h"
  16
  17 #ifdef OVR_DBL_DIG
  18 /* Use an overridden DBL_DIG */
  19 # ifdef DBL_DIG
  20 #  undef DBL_DIG
  21 # endif
  22 # define DBL_DIG OVR_DBL_DIG
  23 #else
  24 /* The following is all to get DBL_DIG, in order to pick a nice
  25    default value for printing floating point numbers in Gconvert.
  26    (see config.h)
  27 */
  28 #ifdef I_LIMITS
  29 #include <limits.h>
  30 #endif
  31 #ifdef I_FLOAT
  32 #include <float.h>
  33 #endif
  34 #ifndef HAS_DBL_DIG
  35 #define DBL_DIG 15   /* A guess that works lots of places */
  36 #endif
  37 #endif
  38
  39 #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__)
  40 #  define FAST_SV_GETS
  41 #endif
  42
  43 #ifdef PERL_OBJECT
  44 #define FCALL this->*f
  45 #define VTBL this->*vtbl
  46
  47 #else /* !PERL_OBJECT */
  48
  49 static IV asIV _((SV* sv));
  50 static UV asUV _((SV* sv));
  51 static SV *more_sv _((void));
  52 static XPVIV *more_xiv _((void));
  53 static XPVNV *more_xnv _((void));
  54 static XPV *more_xpv _((void));
  55 static XRV *more_xrv _((void));
  56 static XPVIV *new_xiv _((void));
  57 static XPVNV *new_xnv _((void));
  58 static XPV *new_xpv _((void));
  59 static XRV *new_xrv _((void));
  60 static void del_xiv _((XPVIV* p));
  61 static void del_xnv _((XPVNV* p));
  62 static void del_xpv _((XPV* p));
  63 static void del_xrv _((XRV* p));
  64 static void sv_mortalgrow _((void));
  65 static void sv_unglob _((SV* sv));
  66 static void sv_check_thinkfirst _((SV *sv));
  67
  68 #ifndef PURIFY
  69 static void *my_safemalloc(MEM_SIZE size);
  70 #endif
  71
  72 typedef void (*SVFUNC) _((SV*));
  73 #define VTBL *vtbl
  74 #define FCALL *f
  75
  76 #endif /* PERL_OBJECT */
  77
  78 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_check_thinkfirst(sv)
  79
  80 #ifdef PURIFY
  81
  82 #define new_SV(p)                       \
  83     do {                                \
  84         LOCK_SV_MUTEX;                  \
  85         (p) = (SV*)safemalloc(sizeof(SV)); \
  86         reg_add(p);                     \
  87         UNLOCK_SV_MUTEX;                \
  88     } while (0)
  89
  90 #define del_SV(p)                       \
  91     do {                                \
  92         LOCK_SV_MUTEX;                  \
  93         reg_remove(p);                  \
  94         Safefree((char*)(p));           \
  95         UNLOCK_SV_MUTEX;                \
  96     } while (0)
  97
  98 static SV **registry;
  99 static I32 regsize;
 100
 101 #define REGHASH(sv,size)  ((((U32)(sv)) >> 2) % (size))
 102
 103 #define REG_REPLACE(sv,a,b) \
 104     do {                                \
 105         void* p = sv->sv_any;           \
 106         I32 h = REGHASH(sv, regsize);   \
 107         I32 i = h;                      \
 108         while (registry[i] != (a)) {    \
 109             if (++i >= regsize)         \
 110                 i = 0;                  \
 111             if (i == h)                 \
 112                 die("SV registry bug"); \
 113         }                               \
 114         registry[i] = (b);              \
 115     } while (0)
 116
 117 #define REG_ADD(sv)     REG_REPLACE(sv,Nullsv,sv)
 118 #define REG_REMOVE(sv)  REG_REPLACE(sv,sv,Nullsv)
 119
 120 static void
 121 reg_add(sv)
 122 SV* sv;
 123 {
 124     if (sv_count >= (regsize >> 1))
 125     {
 126         SV **oldreg = registry;
 127         I32 oldsize = regsize;
 128
 129         regsize = regsize ? ((regsize << 2) + 1) : 2037;
 130         Newz(707, registry, regsize, SV*);
 131
 132         if (oldreg) {
 133             I32 i;
 134
 135             for (i = 0; i < oldsize; ++i) {
 136                 SV* oldsv = oldreg[i];
 137                 if (oldsv)
 138                     REG_ADD(oldsv);
 139             }
 140             Safefree(oldreg);
 141         }
 142     }
 143
 144     REG_ADD(sv);
 145     ++sv_count;
 146 }
 147
 148 static void
 149 reg_remove(sv)
 150 SV* sv;
 151 {
 152     REG_REMOVE(sv);
 153     --sv_count;
 154 }
 155
 156 static void
 157 visit(f)
 158 SVFUNC f;
 159 {
 160     I32 i;
 161
 162     for (i = 0; i < regsize; ++i) {
 163         SV* sv = registry[i];
 164         if (sv)
 165             (*f)(sv);
 166     }
 167 }
 168
 169 void
 170 sv_add_arena(ptr, size, flags)
 171 char* ptr;
 172 U32 size;
 173 U32 flags;
 174 {
 175     if (!(flags & SVf_FAKE))
 176         Safefree(ptr);
 177 }
 178
 179 #else /* ! PURIFY */
 180
 181 /*
 182  * "A time to plant, and a time to uproot what was planted..."
 183  */
 184
 185 #define plant_SV(p)                     \
 186     do {                                \
 187         SvANY(p) = (void *)sv_root;     \
 188         SvFLAGS(p) = SVTYPEMASK;        \
 189         sv_root = (p);                  \
 190         --sv_count;                     \
 191     } while (0)
 192
 193 /* sv_mutex must be held while calling uproot_SV() */
 194 #define uproot_SV(p)                    \
 195     do {                                \
 196         (p) = sv_root;                  \
 197         sv_root = (SV*)SvANY(p);        \
 198         ++sv_count;                     \
 199     } while (0)
 200
 201 #define new_SV(p)       do {    \
 202         LOCK_SV_MUTEX;          \
 203         if (sv_root)            \
 204             uproot_SV(p);       \
 205         else                    \
 206             (p) = more_sv();    \
 207         UNLOCK_SV_MUTEX;        \
 208     } while (0)
 209
 210 #ifdef DEBUGGING
 211
 212 #define del_SV(p)       do {    \
 213         LOCK_SV_MUTEX;          \
 214         if (debug & 32768)      \
 215             del_sv(p);          \
 216         else                    \
 217             plant_SV(p);        \
 218         UNLOCK_SV_MUTEX;        \
 219     } while (0)
 220
 221 STATIC void
 222 del_sv(SV *p)
 223 {
 224     if (debug & 32768) {
 225         SV* sva;
 226         SV* sv;
 227         SV* svend;
 228         int ok = 0;
 229         for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
 230             sv = sva + 1;
 231             svend = &sva[SvREFCNT(sva)];
 232             if (p >= sv && p < svend)
 233                 ok = 1;
 234         }
 235         if (!ok) {
 236             warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
 237             return;
 238         }
 239     }
 240     plant_SV(p);
 241 }
 242
 243 #else /* ! DEBUGGING */
 244
 245 #define del_SV(p)   plant_SV(p)
 246
 247 #endif /* DEBUGGING */
 248
 249 void
 250 sv_add_arena(char *ptr, U32 size, U32 flags)
 251 {
 252     SV* sva = (SV*)ptr;
 253     register SV* sv;
 254     register SV* svend;
 255     Zero(sva, size, char);
 256
 257     /* The first SV in an arena isn't an SV. */
 258     SvANY(sva) = (void *) sv_arenaroot;         /* ptr to next arena */
 259     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 260     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 261
 262     sv_arenaroot = sva;
 263     sv_root = sva + 1;
 264
 265     svend = &sva[SvREFCNT(sva) - 1];
 266     sv = sva + 1;
 267     while (sv < svend) {
 268         SvANY(sv) = (void *)(SV*)(sv + 1);
 269         SvFLAGS(sv) = SVTYPEMASK;
 270         sv++;
 271     }
 272     SvANY(sv) = 0;
 273     SvFLAGS(sv) = SVTYPEMASK;
 274 }
 275
 276 /* sv_mutex must be held while calling more_sv() */
 277 STATIC SV*
 278 more_sv(void)
 279 {
 280     register SV* sv;
 281
 282     if (nice_chunk) {
 283         sv_add_arena(nice_chunk, nice_chunk_size, 0);
 284         nice_chunk = Nullch;
 285     }
 286     else {
 287         char *chunk;                /* must use New here to match call to */
 288         New(704,chunk,1008,char);   /* Safefree() in sv_free_arenas()     */
 289         sv_add_arena(chunk, 1008, 0);
 290     }
 291     uproot_SV(sv);
 292     return sv;
 293 }
 294
 295 STATIC void
 296 visit(SVFUNC f)
 297 {
 298     SV* sva;
 299     SV* sv;
 300     register SV* svend;
 301
 302     for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 303         svend = &sva[SvREFCNT(sva)];
 304         for (sv = sva + 1; sv < svend; ++sv) {
 305             if (SvTYPE(sv) != SVTYPEMASK)
 306                 (FCALL)(sv);
 307         }
 308     }
 309 }
 310
 311 #endif /* PURIFY */
 312
 313 STATIC void
 314 do_report_used(SV *sv)
 315 {
 316     if (SvTYPE(sv) != SVTYPEMASK) {
 317         /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
 318         PerlIO_printf(PerlIO_stderr(), "****\n");
 319         sv_dump(sv);
 320     }
 321 }
 322
 323 void
 324 sv_report_used(void)
 325 {
 326     visit(FUNC_NAME_TO_PTR(do_report_used));
 327 }
 328
 329 STATIC void
 330 do_clean_objs(SV *sv)
 331 {
 332     SV* rv;
 333
 334     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
 335         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
 336         SvROK_off(sv);
 337         SvRV(sv) = 0;
 338         SvREFCNT_dec(rv);
 339     }
 340
 341     /* XXX Might want to check arrays, etc. */
 342 }
 343
 344 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 345 STATIC void
 346 do_clean_named_objs(SV *sv)
 347 {
 348     if (SvTYPE(sv) == SVt_PVGV) {
 349         if ( SvOBJECT(GvSV(sv)) ||
 350              GvAV(sv) && SvOBJECT(GvAV(sv)) ||
 351              GvHV(sv) && SvOBJECT(GvHV(sv)) ||
 352              GvIO(sv) && SvOBJECT(GvIO(sv)) ||
 353              GvCV(sv) && SvOBJECT(GvCV(sv)) )
 354         {
 355             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
 356             SvREFCNT_dec(sv);
 357         }
 358         else if (GvSV(sv))
 359             do_clean_objs(GvSV(sv));
 360     }
 361 }
 362 #endif
 363
 364 void
 365 sv_clean_objs(void)
 366 {
 367     in_clean_objs = TRUE;
 368 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 369     visit(FUNC_NAME_TO_PTR(do_clean_named_objs));
 370 #endif
 371     visit(FUNC_NAME_TO_PTR(do_clean_objs));
 372     in_clean_objs = FALSE;
 373 }
 374
 375 STATIC void
 376 do_clean_all(SV *sv)
 377 {
 378     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));)
 379     SvFLAGS(sv) |= SVf_BREAK;
 380     SvREFCNT_dec(sv);
 381 }
 382
 383 void
 384 sv_clean_all(void)
 385 {
 386     in_clean_all = TRUE;
 387     visit(FUNC_NAME_TO_PTR(do_clean_all));
 388     in_clean_all = FALSE;
 389 }
 390
 391 void
 392 sv_free_arenas(void)
 393 {
 394     SV* sva;
 395     SV* svanext;
 396
 397     /* Free arenas here, but be careful about fake ones.  (We assume
 398        contiguity of the fake ones with the corresponding real ones.) */
 399
 400     for (sva = sv_arenaroot; sva; sva = svanext) {
 401         svanext = (SV*) SvANY(sva);
 402         while (svanext && SvFAKE(svanext))
 403             svanext = (SV*) SvANY(svanext);
 404
 405         if (!SvFAKE(sva))
 406             Safefree((void *)sva);
 407     }
 408
 409     if (nice_chunk)
 410         Safefree(nice_chunk);
 411     nice_chunk = Nullch;
 412     nice_chunk_size = 0;
 413     sv_arenaroot = 0;
 414     sv_root = 0;
 415 }
 416
 417 STATIC XPVIV*
 418 new_xiv(void)
 419 {
 420     IV** xiv;
 421     if (xiv_root) {
 422         xiv = xiv_root;
 423         /*
 424          * See comment in more_xiv() -- RAM.
 425          */
 426         xiv_root = (IV**)*xiv;
 427         return (XPVIV*)((char*)xiv - sizeof(XPV));
 428     }
 429     return more_xiv();
 430 }
 431
 432 STATIC void
 433 del_xiv(XPVIV *p)
 434 {
 435     IV** xiv = (IV**)((char*)(p) + sizeof(XPV));
 436     *xiv = (IV *)xiv_root;
 437     xiv_root = xiv;
 438 }
 439
 440 STATIC XPVIV*
 441 more_xiv(void)
 442 {
 443     register IV** xiv;
 444     register IV** xivend;
 445     XPV* ptr;
 446     New(705, ptr, 1008/sizeof(XPV), XPV);
 447     ptr->xpv_pv = (char*)xiv_arenaroot;         /* linked list of xiv arenas */
 448     xiv_arenaroot = ptr;                        /* to keep Purify happy */
 449
 450     xiv = (IV**) ptr;
 451     xivend = &xiv[1008 / sizeof(IV *) - 1];
 452     xiv += (sizeof(XPV) - 1) / sizeof(IV *) + 1;   /* fudge by size of XPV */
 453     xiv_root = xiv;
 454     while (xiv < xivend) {
 455         *xiv = (IV *)(xiv + 1);
 456         xiv++;
 457     }
 458     *xiv = 0;
 459     return new_xiv();
 460 }
 461
 462 STATIC XPVNV*
 463 new_xnv(void)
 464 {
 465     double* xnv;
 466     if (xnv_root) {
 467         xnv = xnv_root;
 468         xnv_root = *(double**)xnv;
 469         return (XPVNV*)((char*)xnv - sizeof(XPVIV));
 470     }
 471     return more_xnv();
 472 }
 473
 474 STATIC void
 475 del_xnv(XPVNV *p)
 476 {
 477     double* xnv = (double*)((char*)(p) + sizeof(XPVIV));
 478     *(double**)xnv = xnv_root;
 479     xnv_root = xnv;
 480 }
 481
 482 STATIC XPVNV*
 483 more_xnv(void)
 484 {
 485     register double* xnv;
 486     register double* xnvend;
 487     New(711, xnv, 1008/sizeof(double), double);
 488     xnvend = &xnv[1008 / sizeof(double) - 1];
 489     xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
 490     xnv_root = xnv;
 491     while (xnv < xnvend) {
 492         *(double**)xnv = (double*)(xnv + 1);
 493         xnv++;
 494     }
 495     *(double**)xnv = 0;
 496     return new_xnv();
 497 }
 498
 499 STATIC XRV*
 500 new_xrv(void)
 501 {
 502     XRV* xrv;
 503     if (xrv_root) {
 504         xrv = xrv_root;
 505         xrv_root = (XRV*)xrv->xrv_rv;
 506         return xrv;
 507     }
 508     return more_xrv();
 509 }
 510
 511 STATIC void
 512 del_xrv(XRV *p)
 513 {
 514     p->xrv_rv = (SV*)xrv_root;
 515     xrv_root = p;
 516 }
 517
 518 STATIC XRV*
 519 more_xrv(void)
 520 {
 521     register XRV* xrv;
 522     register XRV* xrvend;
 523     New(712, xrv_root, 1008/sizeof(XRV), XRV);
 524     xrv = xrv_root;
 525     xrvend = &xrv[1008 / sizeof(XRV) - 1];
 526     while (xrv < xrvend) {
 527         xrv->xrv_rv = (SV*)(xrv + 1);
 528         xrv++;
 529     }
 530     xrv->xrv_rv = 0;
 531     return new_xrv();
 532 }
 533
 534 STATIC XPV*
 535 new_xpv(void)
 536 {
 537     XPV* xpv;
 538     if (xpv_root) {
 539         xpv = xpv_root;
 540         xpv_root = (XPV*)xpv->xpv_pv;
 541         return xpv;
 542     }
 543     return more_xpv();
 544 }
 545
 546 STATIC void
 547 del_xpv(XPV *p)
 548 {
 549     p->xpv_pv = (char*)xpv_root;
 550     xpv_root = p;
 551 }
 552
 553 STATIC XPV*
 554 more_xpv(void)
 555 {
 556     register XPV* xpv;
 557     register XPV* xpvend;
 558     New(713, xpv_root, 1008/sizeof(XPV), XPV);
 559     xpv = xpv_root;
 560     xpvend = &xpv[1008 / sizeof(XPV) - 1];
 561     while (xpv < xpvend) {
 562         xpv->xpv_pv = (char*)(xpv + 1);
 563         xpv++;
 564     }
 565     xpv->xpv_pv = 0;
 566     return new_xpv();
 567 }
 568
 569 #ifdef PURIFY
 570 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
 571 #define del_XIV(p) Safefree((char*)p)
 572 #else
 573 #define new_XIV() (void*)new_xiv()
 574 #define del_XIV(p) del_xiv((XPVIV*) p)
 575 #endif
 576
 577 #ifdef PURIFY
 578 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
 579 #define del_XNV(p) Safefree((char*)p)
 580 #else
 581 #define new_XNV() (void*)new_xnv()
 582 #define del_XNV(p) del_xnv((XPVNV*) p)
 583 #endif
 584
 585 #ifdef PURIFY
 586 #define new_XRV() (void*)safemalloc(sizeof(XRV))
 587 #define del_XRV(p) Safefree((char*)p)
 588 #else
 589 #define new_XRV() (void*)new_xrv()
 590 #define del_XRV(p) del_xrv((XRV*) p)
 591 #endif
 592
 593 #ifdef PURIFY
 594 #define new_XPV() (void*)safemalloc(sizeof(XPV))
 595 #define del_XPV(p) Safefree((char*)p)
 596 #else
 597 #define new_XPV() (void*)new_xpv()
 598 #define del_XPV(p) del_xpv((XPV *)p)
 599 #endif
 600
 601 #ifdef PURIFY
 602 #  define my_safemalloc(s) safemalloc(s)
 603 #  define my_safefree(s) free(s)
 604 #else
 605 STATIC void*
 606 my_safemalloc(MEM_SIZE size)
 607 {
 608     char *p;
 609     New(717, p, size, char);
 610     return (void*)p;
 611 }
 612 #  define my_safefree(s) Safefree(s)
 613 #endif
 614
 615 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
 616 #define del_XPVIV(p) my_safefree((char*)p)
 617
 618 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
 619 #define del_XPVNV(p) my_safefree((char*)p)
 620
 621 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
 622 #define del_XPVMG(p) my_safefree((char*)p)
 623
 624 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
 625 #define del_XPVLV(p) my_safefree((char*)p)
 626
 627 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
 628 #define del_XPVAV(p) my_safefree((char*)p)
 629
 630 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
 631 #define del_XPVHV(p) my_safefree((char*)p)
 632
 633 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
 634 #define del_XPVCV(p) my_safefree((char*)p)
 635
 636 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
 637 #define del_XPVGV(p) my_safefree((char*)p)
 638
 639 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
 640 #define del_XPVBM(p) my_safefree((char*)p)
 641
 642 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
 643 #define del_XPVFM(p) my_safefree((char*)p)
 644
 645 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
 646 #define del_XPVIO(p) my_safefree((char*)p)
 647
 648 bool
 649 sv_upgrade(register SV *sv, U32 mt)
 650 {
 651     char*       pv;
 652     U32         cur;
 653     U32         len;
 654     IV          iv;
 655     double      nv;
 656     MAGIC*      magic;
 657     HV*         stash;
 658
 659     if (SvTYPE(sv) == mt)
 660         return TRUE;
 661
 662     if (mt < SVt_PVIV)
 663         (void)SvOOK_off(sv);
 664
 665     switch (SvTYPE(sv)) {
 666     case SVt_NULL:
 667         pv      = 0;
 668         cur     = 0;
 669         len     = 0;
 670         iv      = 0;
 671         nv      = 0.0;
 672         magic   = 0;
 673         stash   = 0;
 674         break;
 675     case SVt_IV:
 676         pv      = 0;
 677         cur     = 0;
 678         len     = 0;
 679         iv      = SvIVX(sv);
 680         nv      = (double)SvIVX(sv);
 681         del_XIV(SvANY(sv));
 682         magic   = 0;
 683         stash   = 0;
 684         if (mt == SVt_NV)
 685             mt = SVt_PVNV;
 686         else if (mt < SVt_PVIV)
 687             mt = SVt_PVIV;
 688         break;
 689     case SVt_NV:
 690         pv      = 0;
 691         cur     = 0;
 692         len     = 0;
 693         nv      = SvNVX(sv);
 694         iv      = I_32(nv);
 695         magic   = 0;
 696         stash   = 0;
 697         del_XNV(SvANY(sv));
 698         SvANY(sv) = 0;
 699         if (mt < SVt_PVNV)
 700             mt = SVt_PVNV;
 701         break;
 702     case SVt_RV:
 703         pv      = (char*)SvRV(sv);
 704         cur     = 0;
 705         len     = 0;
 706         iv      = (IV)pv;
 707         nv      = (double)(unsigned long)pv;
 708         del_XRV(SvANY(sv));
 709         magic   = 0;
 710         stash   = 0;
 711         break;
 712     case SVt_PV:
 713         pv      = SvPVX(sv);
 714         cur     = SvCUR(sv);
 715         len     = SvLEN(sv);
 716         iv      = 0;
 717         nv      = 0.0;
 718         magic   = 0;
 719         stash   = 0;
 720         del_XPV(SvANY(sv));
 721         if (mt <= SVt_IV)
 722             mt = SVt_PVIV;
 723         else if (mt == SVt_NV)
 724             mt = SVt_PVNV;
 725         break;
 726     case SVt_PVIV:
 727         pv      = SvPVX(sv);
 728         cur     = SvCUR(sv);
 729         len     = SvLEN(sv);
 730         iv      = SvIVX(sv);
 731         nv      = 0.0;
 732         magic   = 0;
 733         stash   = 0;
 734         del_XPVIV(SvANY(sv));
 735         break;
 736     case SVt_PVNV:
 737         pv      = SvPVX(sv);
 738         cur     = SvCUR(sv);
 739         len     = SvLEN(sv);
 740         iv      = SvIVX(sv);
 741         nv      = SvNVX(sv);
 742         magic   = 0;
 743         stash   = 0;
 744         del_XPVNV(SvANY(sv));
 745         break;
 746     case SVt_PVMG:
 747         pv      = SvPVX(sv);
 748         cur     = SvCUR(sv);
 749         len     = SvLEN(sv);
 750         iv      = SvIVX(sv);
 751         nv      = SvNVX(sv);
 752         magic   = SvMAGIC(sv);
 753         stash   = SvSTASH(sv);
 754         del_XPVMG(SvANY(sv));
 755         break;
 756     default:
 757         croak("Can't upgrade that kind of scalar");
 758     }
 759
 760     switch (mt) {
 761     case SVt_NULL:
 762         croak("Can't upgrade to undef");
 763     case SVt_IV:
 764         SvANY(sv) = new_XIV();
 765         SvIVX(sv)       = iv;
 766         break;
 767     case SVt_NV:
 768         SvANY(sv) = new_XNV();
 769         SvNVX(sv)       = nv;
 770         break;
 771     case SVt_RV:
 772         SvANY(sv) = new_XRV();
 773         SvRV(sv) = (SV*)pv;
 774         break;
 775     case SVt_PV:
 776         SvANY(sv) = new_XPV();
 777         SvPVX(sv)       = pv;
 778         SvCUR(sv)       = cur;
 779         SvLEN(sv)       = len;
 780         break;
 781     case SVt_PVIV:
 782         SvANY(sv) = new_XPVIV();
 783         SvPVX(sv)       = pv;
 784         SvCUR(sv)       = cur;
 785         SvLEN(sv)       = len;
 786         SvIVX(sv)       = iv;
 787         if (SvNIOK(sv))
 788             (void)SvIOK_on(sv);
 789         SvNOK_off(sv);
 790         break;
 791     case SVt_PVNV:
 792         SvANY(sv) = new_XPVNV();
 793         SvPVX(sv)       = pv;
 794         SvCUR(sv)       = cur;
 795         SvLEN(sv)       = len;
 796         SvIVX(sv)       = iv;
 797         SvNVX(sv)       = nv;
 798         break;
 799     case SVt_PVMG:
 800         SvANY(sv) = new_XPVMG();
 801         SvPVX(sv)       = pv;
 802         SvCUR(sv)       = cur;
 803         SvLEN(sv)       = len;
 804         SvIVX(sv)       = iv;
 805         SvNVX(sv)       = nv;
 806         SvMAGIC(sv)     = magic;
 807         SvSTASH(sv)     = stash;
 808         break;
 809     case SVt_PVLV:
 810         SvANY(sv) = new_XPVLV();
 811         SvPVX(sv)       = pv;
 812         SvCUR(sv)       = cur;
 813         SvLEN(sv)       = len;
 814         SvIVX(sv)       = iv;
 815         SvNVX(sv)       = nv;
 816         SvMAGIC(sv)     = magic;
 817         SvSTASH(sv)     = stash;
 818         LvTARGOFF(sv)   = 0;
 819         LvTARGLEN(sv)   = 0;
 820         LvTARG(sv)      = 0;
 821         LvTYPE(sv)      = 0;
 822         break;
 823     case SVt_PVAV:
 824         SvANY(sv) = new_XPVAV();
 825         if (pv)
 826             Safefree(pv);
 827         SvPVX(sv)       = 0;
 828         AvMAX(sv)       = -1;
 829         AvFILLp(sv)     = -1;
 830         SvIVX(sv)       = 0;
 831         SvNVX(sv)       = 0.0;
 832         SvMAGIC(sv)     = magic;
 833         SvSTASH(sv)     = stash;
 834         AvALLOC(sv)     = 0;
 835         AvARYLEN(sv)    = 0;
 836         AvFLAGS(sv)     = 0;
 837         break;
 838     case SVt_PVHV:
 839         SvANY(sv) = new_XPVHV();
 840         if (pv)
 841             Safefree(pv);
 842         SvPVX(sv)       = 0;
 843         HvFILL(sv)      = 0;
 844         HvMAX(sv)       = 0;
 845         HvKEYS(sv)      = 0;
 846         SvNVX(sv)       = 0.0;
 847         SvMAGIC(sv)     = magic;
 848         SvSTASH(sv)     = stash;
 849         HvRITER(sv)     = 0;
 850         HvEITER(sv)     = 0;
 851         HvPMROOT(sv)    = 0;
 852         HvNAME(sv)      = 0;
 853         break;
 854     case SVt_PVCV:
 855         SvANY(sv) = new_XPVCV();
 856         Zero(SvANY(sv), 1, XPVCV);
 857         SvPVX(sv)       = pv;
 858         SvCUR(sv)       = cur;
 859         SvLEN(sv)       = len;
 860         SvIVX(sv)       = iv;
 861         SvNVX(sv)       = nv;
 862         SvMAGIC(sv)     = magic;
 863         SvSTASH(sv)     = stash;
 864         break;
 865     case SVt_PVGV:
 866         SvANY(sv) = new_XPVGV();
 867         SvPVX(sv)       = pv;
 868         SvCUR(sv)       = cur;
 869         SvLEN(sv)       = len;
 870         SvIVX(sv)       = iv;
 871         SvNVX(sv)       = nv;
 872         SvMAGIC(sv)     = magic;
 873         SvSTASH(sv)     = stash;
 874         GvGP(sv)        = 0;
 875         GvNAME(sv)      = 0;
 876         GvNAMELEN(sv)   = 0;
 877         GvSTASH(sv)     = 0;
 878         GvFLAGS(sv)     = 0;
 879         break;
 880     case SVt_PVBM:
 881         SvANY(sv) = new_XPVBM();
 882         SvPVX(sv)       = pv;
 883         SvCUR(sv)       = cur;
 884         SvLEN(sv)       = len;
 885         SvIVX(sv)       = iv;
 886         SvNVX(sv)       = nv;
 887         SvMAGIC(sv)     = magic;
 888         SvSTASH(sv)     = stash;
 889         BmRARE(sv)      = 0;
 890         BmUSEFUL(sv)    = 0;
 891         BmPREVIOUS(sv)  = 0;
 892         break;
 893     case SVt_PVFM:
 894         SvANY(sv) = new_XPVFM();
 895         Zero(SvANY(sv), 1, XPVFM);
 896         SvPVX(sv)       = pv;
 897         SvCUR(sv)       = cur;
 898         SvLEN(sv)       = len;
 899         SvIVX(sv)       = iv;
 900         SvNVX(sv)       = nv;
 901         SvMAGIC(sv)     = magic;
 902         SvSTASH(sv)     = stash;
 903         break;
 904     case SVt_PVIO:
 905         SvANY(sv) = new_XPVIO();
 906         Zero(SvANY(sv), 1, XPVIO);
 907         SvPVX(sv)       = pv;
 908         SvCUR(sv)       = cur;
 909         SvLEN(sv)       = len;
 910         SvIVX(sv)       = iv;
 911         SvNVX(sv)       = nv;
 912         SvMAGIC(sv)     = magic;
 913         SvSTASH(sv)     = stash;
 914         IoPAGE_LEN(sv)  = 60;
 915         break;
 916     }
 917     SvFLAGS(sv) &= ~SVTYPEMASK;
 918     SvFLAGS(sv) |= mt;
 919     return TRUE;
 920 }
 921
 922 #ifdef DEBUGGING
 923 char *
 924 sv_peek(SV *sv)
 925 {
 926     SV *t = sv_newmortal();
 927     STRLEN prevlen;
 928     int unref = 0;
 929
 930     sv_setpvn(t, "", 0);
 931   retry:
 932     if (!sv) {
 933         sv_catpv(t, "VOID");
 934         goto finish;
 935     }
 936     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
 937         sv_catpv(t, "WILD");
 938         goto finish;
 939     }
 940     else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) {
 941         if (sv == &sv_undef) {
 942             sv_catpv(t, "SV_UNDEF");
 943             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 944                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 945                 SvREADONLY(sv))
 946                 goto finish;
 947         }
 948         else if (sv == &sv_no) {
 949             sv_catpv(t, "SV_NO");
 950             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 951                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 952                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 953                                   SVp_POK|SVp_NOK)) &&
 954                 SvCUR(sv) == 0 &&
 955                 SvNVX(sv) == 0.0)
 956                 goto finish;
 957         }
 958         else {
 959             sv_catpv(t, "SV_YES");
 960             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 961                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 962                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 963                                   SVp_POK|SVp_NOK)) &&
 964                 SvCUR(sv) == 1 &&
 965                 SvPVX(sv) && *SvPVX(sv) == '1' &&
 966                 SvNVX(sv) == 1.0)
 967                 goto finish;
 968         }
 969         sv_catpv(t, ":");
 970     }
 971     else if (SvREFCNT(sv) == 0) {
 972         sv_catpv(t, "(");
 973         unref++;
 974     }
 975     if (SvROK(sv)) {
 976         sv_catpv(t, "\\");
 977         if (SvCUR(t) + unref > 10) {
 978             SvCUR(t) = unref + 3;
 979             *SvEND(t) = '\0';
 980             sv_catpv(t, "...");
 981             goto finish;
 982         }
 983         sv = (SV*)SvRV(sv);
 984         goto retry;
 985     }
 986     switch (SvTYPE(sv)) {
 987     default:
 988         sv_catpv(t, "FREED");
 989         goto finish;
 990
 991     case SVt_NULL:
 992         sv_catpv(t, "UNDEF");
 993         goto finish;
 994     case SVt_IV:
 995         sv_catpv(t, "IV");
 996         break;
 997     case SVt_NV:
 998         sv_catpv(t, "NV");
 999         break;
1000     case SVt_RV:
1001         sv_catpv(t, "RV");
1002         break;
1003     case SVt_PV:
1004         sv_catpv(t, "PV");
1005         break;
1006     case SVt_PVIV:
1007         sv_catpv(t, "PVIV");
1008         break;
1009     case SVt_PVNV:
1010         sv_catpv(t, "PVNV");
1011         break;
1012     case SVt_PVMG:
1013         sv_catpv(t, "PVMG");
1014         break;
1015     case SVt_PVLV:
1016         sv_catpv(t, "PVLV");
1017         break;
1018     case SVt_PVAV:
1019         sv_catpv(t, "AV");
1020         break;
1021     case SVt_PVHV:
1022         sv_catpv(t, "HV");
1023         break;
1024     case SVt_PVCV:
1025         if (CvGV(sv))
1026             sv_catpvf(t, "CV(%s)", GvNAME(CvGV(sv)));
1027         else
1028             sv_catpv(t, "CV()");
1029         goto finish;
1030     case SVt_PVGV:
1031         sv_catpv(t, "GV");
1032         break;
1033     case SVt_PVBM:
1034         sv_catpv(t, "BM");
1035         break;
1036     case SVt_PVFM:
1037         sv_catpv(t, "FM");
1038         break;
1039     case SVt_PVIO:
1040         sv_catpv(t, "IO");
1041         break;
1042     }
1043
1044     if (SvPOKp(sv)) {
1045         if (!SvPVX(sv))
1046             sv_catpv(t, "(null)");
1047         if (SvOOK(sv))
1048             sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv));
1049         else
1050             sv_catpvf(t, "(\"%.127s\")",SvPVX(sv));
1051     }
1052     else if (SvNOKp(sv)) {
1053         SET_NUMERIC_STANDARD();
1054         sv_catpvf(t, "(%g)",SvNVX(sv));
1055     }
1056     else if (SvIOKp(sv))
1057         sv_catpvf(t, "(%ld)",(long)SvIVX(sv));
1058     else
1059         sv_catpv(t, "()");
1060
1061   finish:
1062     if (unref) {
1063         while (unref--)
1064             sv_catpv(t, ")");
1065     }
1066     return SvPV(t, na);
1067 }
1068 #endif
1069
1070 int
1071 sv_backoff(register SV *sv)
1072 {
1073     assert(SvOOK(sv));
1074     if (SvIVX(sv)) {
1075         char *s = SvPVX(sv);
1076         SvLEN(sv) += SvIVX(sv);
1077         SvPVX(sv) -= SvIVX(sv);
1078         SvIV_set(sv, 0);
1079         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1080     }
1081     SvFLAGS(sv) &= ~SVf_OOK;
1082     return 0;
1083 }
1084
1085 char *
1086 #ifndef DOSISH
1087 sv_grow(register SV *sv, register I32 newlen)
1088 #else
1089 sv_grow(SV* sv, unsigned long newlen)
1090 #endif
1091 {
1092     register char *s;
1093
1094 #ifdef HAS_64K_LIMIT
1095     if (newlen >= 0x10000) {
1096         PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
1097         my_exit(1);
1098     }
1099 #endif /* HAS_64K_LIMIT */
1100     if (SvROK(sv))
1101         sv_unref(sv);
1102     if (SvTYPE(sv) < SVt_PV) {
1103         sv_upgrade(sv, SVt_PV);
1104         s = SvPVX(sv);
1105     }
1106     else if (SvOOK(sv)) {       /* pv is offset? */
1107         sv_backoff(sv);
1108         s = SvPVX(sv);
1109         if (newlen > SvLEN(sv))
1110             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1111 #ifdef HAS_64K_LIMIT
1112         if (newlen >= 0x10000)
1113             newlen = 0xFFFF;
1114 #endif
1115     }
1116     else
1117         s = SvPVX(sv);
1118     if (newlen > SvLEN(sv)) {           /* need more room? */
1119         if (SvLEN(sv) && s)
1120             Renew(s,newlen,char);
1121         else
1122             New(703,s,newlen,char);
1123         SvPV_set(sv, s);
1124         SvLEN_set(sv, newlen);
1125     }
1126     return s;
1127 }
1128
1129 void
1130 sv_setiv(register SV *sv, IV i)
1131 {
1132     SV_CHECK_THINKFIRST(sv);
1133     switch (SvTYPE(sv)) {
1134     case SVt_NULL:
1135         sv_upgrade(sv, SVt_IV);
1136         break;
1137     case SVt_NV:
1138         sv_upgrade(sv, SVt_PVNV);
1139         break;
1140     case SVt_RV:
1141     case SVt_PV:
1142         sv_upgrade(sv, SVt_PVIV);
1143         break;
1144
1145     case SVt_PVGV:
1146         if (SvFAKE(sv)) {
1147             sv_unglob(sv);
1148             break;
1149         }
1150         /* FALL THROUGH */
1151     case SVt_PVAV:
1152     case SVt_PVHV:
1153     case SVt_PVCV:
1154     case SVt_PVFM:
1155     case SVt_PVIO:
1156         {
1157             dTHR;
1158             croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
1159                   op_desc[op->op_type]);
1160         }
1161     }
1162     (void)SvIOK_only(sv);                       /* validate number */
1163     SvIVX(sv) = i;
1164     SvTAINT(sv);
1165 }
1166
1167 void
1168 sv_setiv_mg(register SV *sv, IV i)
1169 {
1170     sv_setiv(sv,i);
1171     SvSETMAGIC(sv);
1172 }
1173
1174 void
1175 sv_setuv(register SV *sv, UV u)
1176 {
1177     if (u <= IV_MAX)
1178         sv_setiv(sv, u);
1179     else
1180         sv_setnv(sv, (double)u);
1181 }
1182
1183 void
1184 sv_setuv_mg(register SV *sv, UV u)
1185 {
1186     sv_setuv(sv,u);
1187     SvSETMAGIC(sv);
1188 }
1189
1190 void
1191 sv_setnv(register SV *sv, double num)
1192 {
1193     SV_CHECK_THINKFIRST(sv);
1194     switch (SvTYPE(sv)) {
1195     case SVt_NULL:
1196     case SVt_IV:
1197         sv_upgrade(sv, SVt_NV);
1198         break;
1199     case SVt_RV:
1200     case SVt_PV:
1201     case SVt_PVIV:
1202         sv_upgrade(sv, SVt_PVNV);
1203         /* FALL THROUGH */
1204     case SVt_PVNV:
1205     case SVt_PVMG:
1206     case SVt_PVBM:
1207     case SVt_PVLV:
1208         if (SvOOK(sv))
1209             (void)SvOOK_off(sv);
1210         break;
1211     case SVt_PVGV:
1212         if (SvFAKE(sv)) {
1213             sv_unglob(sv);
1214             break;
1215         }
1216         /* FALL THROUGH */
1217     case SVt_PVAV:
1218     case SVt_PVHV:
1219     case SVt_PVCV:
1220     case SVt_PVFM:
1221     case SVt_PVIO:
1222         {
1223             dTHR;
1224             croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
1225                   op_name[op->op_type]);
1226         }
1227     }
1228     SvNVX(sv) = num;
1229     (void)SvNOK_only(sv);                       /* validate number */
1230     SvTAINT(sv);
1231 }
1232
1233 void
1234 sv_setnv_mg(register SV *sv, double num)
1235 {
1236     sv_setnv(sv,num);
1237     SvSETMAGIC(sv);
1238 }
1239
1240 STATIC void
1241 not_a_number(SV *sv)
1242 {
1243     dTHR;
1244     char tmpbuf[64];
1245     char *d = tmpbuf;
1246     char *s;
1247     char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1248                   /* each *s can expand to 4 chars + "...\0",
1249                      i.e. need room for 8 chars */
1250
1251     for (s = SvPVX(sv); *s && d < limit; s++) {
1252         int ch = *s & 0xFF;
1253         if (ch & 128 && !isPRINT_LC(ch)) {
1254             *d++ = 'M';
1255             *d++ = '-';
1256             ch &= 127;
1257         }
1258         if (ch == '\n') {
1259             *d++ = '\\';
1260             *d++ = 'n';
1261         }
1262         else if (ch == '\r') {
1263             *d++ = '\\';
1264             *d++ = 'r';
1265         }
1266         else if (ch == '\f') {
1267             *d++ = '\\';
1268             *d++ = 'f';
1269         }
1270         else if (ch == '\\') {
1271             *d++ = '\\';
1272             *d++ = '\\';
1273         }
1274         else if (isPRINT_LC(ch))
1275             *d++ = ch;
1276         else {
1277             *d++ = '^';
1278             *d++ = toCTRL(ch);
1279         }
1280     }
1281     if (*s) {
1282         *d++ = '.';
1283         *d++ = '.';
1284         *d++ = '.';
1285     }
1286     *d = '\0';
1287
1288     if (op)
1289         warn("Argument \"%s\" isn't numeric in %s", tmpbuf,
1290                 op_name[op->op_type]);
1291     else
1292         warn("Argument \"%s\" isn't numeric", tmpbuf);
1293 }
1294
1295 IV
1296 sv_2iv(register SV *sv)
1297 {
1298     if (!sv)
1299         return 0;
1300     if (SvGMAGICAL(sv)) {
1301         mg_get(sv);
1302         if (SvIOKp(sv))
1303             return SvIVX(sv);
1304         if (SvNOKp(sv)) {
1305             if (SvNVX(sv) < 0.0)
1306                 return I_V(SvNVX(sv));
1307             else
1308                 return (IV) U_V(SvNVX(sv));
1309         }
1310         if (SvPOKp(sv) && SvLEN(sv))
1311             return asIV(sv);
1312         if (!SvROK(sv)) {
1313             if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1314                 dTHR;
1315                 if (!localizing)
1316                     warn(warn_uninit);
1317             }
1318             return 0;
1319         }
1320     }
1321     if (SvTHINKFIRST(sv)) {
1322         if (SvROK(sv)) {
1323 #ifdef OVERLOAD
1324           SV* tmpstr;
1325           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1326             return SvIV(tmpstr);
1327 #endif /* OVERLOAD */
1328           return (IV)SvRV(sv);
1329         }
1330         if (SvREADONLY(sv)) {
1331             if (SvNOKp(sv)) {
1332                 if (SvNVX(sv) < 0.0)
1333                     return I_V(SvNVX(sv));
1334                 else
1335                     return (IV) U_V(SvNVX(sv));
1336             }
1337             if (SvPOKp(sv) && SvLEN(sv))
1338                 return asIV(sv);
1339             if (dowarn)
1340                 warn(warn_uninit);
1341             return 0;
1342         }
1343     }
1344     switch (SvTYPE(sv)) {
1345     case SVt_NULL:
1346         sv_upgrade(sv, SVt_IV);
1347         break;
1348     case SVt_PV:
1349         sv_upgrade(sv, SVt_PVIV);
1350         break;
1351     case SVt_NV:
1352         sv_upgrade(sv, SVt_PVNV);
1353         break;
1354     }
1355     if (SvNOKp(sv)) {
1356         (void)SvIOK_on(sv);
1357         if (SvNVX(sv) < 0.0)
1358             SvIVX(sv) = I_V(SvNVX(sv));
1359         else
1360             SvUVX(sv) = U_V(SvNVX(sv));
1361     }
1362     else if (SvPOKp(sv) && SvLEN(sv)) {
1363         (void)SvIOK_on(sv);
1364         SvIVX(sv) = asIV(sv);
1365     }
1366     else  {
1367         dTHR;
1368         if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1369             warn(warn_uninit);
1370         return 0;
1371     }
1372     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1373         (unsigned long)sv,(long)SvIVX(sv)));
1374     return SvIVX(sv);
1375 }
1376
1377 UV
1378 sv_2uv(register SV *sv)
1379 {
1380     if (!sv)
1381         return 0;
1382     if (SvGMAGICAL(sv)) {
1383         mg_get(sv);
1384         if (SvIOKp(sv))
1385             return SvUVX(sv);
1386         if (SvNOKp(sv))
1387             return U_V(SvNVX(sv));
1388         if (SvPOKp(sv) && SvLEN(sv))
1389             return asUV(sv);
1390         if (!SvROK(sv)) {
1391             if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1392                 dTHR;
1393                 if (!localizing)
1394                     warn(warn_uninit);
1395             }
1396             return 0;
1397         }
1398     }
1399     if (SvTHINKFIRST(sv)) {
1400         if (SvROK(sv)) {
1401 #ifdef OVERLOAD
1402           SV* tmpstr;
1403           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1404             return SvUV(tmpstr);
1405 #endif /* OVERLOAD */
1406           return (UV)SvRV(sv);
1407         }
1408         if (SvREADONLY(sv)) {
1409             if (SvNOKp(sv)) {
1410                 return U_V(SvNVX(sv));
1411             }
1412             if (SvPOKp(sv) && SvLEN(sv))
1413                 return asUV(sv);
1414             if (dowarn)
1415                 warn(warn_uninit);
1416             return 0;
1417         }
1418     }
1419     switch (SvTYPE(sv)) {
1420     case SVt_NULL:
1421         sv_upgrade(sv, SVt_IV);
1422         break;
1423     case SVt_PV:
1424         sv_upgrade(sv, SVt_PVIV);
1425         break;
1426     case SVt_NV:
1427         sv_upgrade(sv, SVt_PVNV);
1428         break;
1429     }
1430     if (SvNOKp(sv)) {
1431         (void)SvIOK_on(sv);
1432         SvUVX(sv) = U_V(SvNVX(sv));
1433     }
1434     else if (SvPOKp(sv) && SvLEN(sv)) {
1435         (void)SvIOK_on(sv);
1436         SvUVX(sv) = asUV(sv);
1437     }
1438     else  {
1439         if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1440             dTHR;
1441             if (!localizing)
1442                 warn(warn_uninit);
1443         }
1444         return 0;
1445     }
1446     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1447         (unsigned long)sv,SvUVX(sv)));
1448     return SvUVX(sv);
1449 }
1450
1451 double
1452 sv_2nv(register SV *sv)
1453 {
1454     if (!sv)
1455         return 0.0;
1456     if (SvGMAGICAL(sv)) {
1457         mg_get(sv);
1458         if (SvNOKp(sv))
1459             return SvNVX(sv);
1460         if (SvPOKp(sv) && SvLEN(sv)) {
1461             if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
1462                 not_a_number(sv);
1463             SET_NUMERIC_STANDARD();
1464             return atof(SvPVX(sv));
1465         }
1466         if (SvIOKp(sv))
1467             return (double)SvIVX(sv);
1468         if (!SvROK(sv)) {
1469             if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1470                 dTHR;
1471                 if (!localizing)
1472                     warn(warn_uninit);
1473             }
1474             return 0;
1475         }
1476     }
1477     if (SvTHINKFIRST(sv)) {
1478         if (SvROK(sv)) {
1479 #ifdef OVERLOAD
1480           SV* tmpstr;
1481           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1482             return SvNV(tmpstr);
1483 #endif /* OVERLOAD */
1484           return (double)(unsigned long)SvRV(sv);
1485         }
1486         if (SvREADONLY(sv)) {
1487             if (SvPOKp(sv) && SvLEN(sv)) {
1488                 if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
1489                     not_a_number(sv);
1490                 SET_NUMERIC_STANDARD();
1491                 return atof(SvPVX(sv));
1492             }
1493             if (SvIOKp(sv))
1494                 return (double)SvIVX(sv);
1495             if (dowarn)
1496                 warn(warn_uninit);
1497             return 0.0;
1498         }
1499     }
1500     if (SvTYPE(sv) < SVt_NV) {
1501         if (SvTYPE(sv) == SVt_IV)
1502             sv_upgrade(sv, SVt_PVNV);
1503         else
1504             sv_upgrade(sv, SVt_NV);
1505         DEBUG_c(SET_NUMERIC_STANDARD());
1506         DEBUG_c(PerlIO_printf(Perl_debug_log,
1507                               "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
1508     }
1509     else if (SvTYPE(sv) < SVt_PVNV)
1510         sv_upgrade(sv, SVt_PVNV);
1511     if (SvIOKp(sv) &&
1512             (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1513     {
1514         SvNVX(sv) = (double)SvIVX(sv);
1515     }
1516     else if (SvPOKp(sv) && SvLEN(sv)) {
1517         if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
1518             not_a_number(sv);
1519         SET_NUMERIC_STANDARD();
1520         SvNVX(sv) = atof(SvPVX(sv));
1521     }
1522     else  {
1523         dTHR;
1524         if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1525             warn(warn_uninit);
1526         return 0.0;
1527     }
1528     SvNOK_on(sv);
1529     DEBUG_c(SET_NUMERIC_STANDARD());
1530     DEBUG_c(PerlIO_printf(Perl_debug_log,
1531                           "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
1532     return SvNVX(sv);
1533 }
1534
1535 STATIC IV
1536 asIV(SV *sv)
1537 {
1538     I32 numtype = looks_like_number(sv);
1539     double d;
1540
1541     if (numtype == 1)
1542         return atol(SvPVX(sv));
1543     if (!numtype && dowarn)
1544         not_a_number(sv);
1545     SET_NUMERIC_STANDARD();
1546     d = atof(SvPVX(sv));
1547     if (d < 0.0)
1548         return I_V(d);
1549     else
1550         return (IV) U_V(d);
1551 }
1552
1553 STATIC UV
1554 asUV(SV *sv)
1555 {
1556     I32 numtype = looks_like_number(sv);
1557
1558 #ifdef HAS_STRTOUL
1559     if (numtype == 1)
1560         return strtoul(SvPVX(sv), Null(char**), 10);
1561 #endif
1562     if (!numtype && dowarn)
1563         not_a_number(sv);
1564     SET_NUMERIC_STANDARD();
1565     return U_V(atof(SvPVX(sv)));
1566 }
1567
1568 I32
1569 looks_like_number(SV *sv)
1570 {
1571     register char *s;
1572     register char *send;
1573     register char *sbegin;
1574     I32 numtype;
1575     STRLEN len;
1576
1577     if (SvPOK(sv)) {
1578         sbegin = SvPVX(sv);
1579         len = SvCUR(sv);
1580     }
1581     else if (SvPOKp(sv))
1582         sbegin = SvPV(sv, len);
1583     else
1584         return 1;
1585     send = sbegin + len;
1586
1587     s = sbegin;
1588     while (isSPACE(*s))
1589         s++;
1590     if (*s == '+' || *s == '-')
1591         s++;
1592
1593     /* next must be digit or '.' */
1594     if (isDIGIT(*s)) {
1595         do {
1596             s++;
1597         } while (isDIGIT(*s));
1598         if (*s == '.') {
1599             s++;
1600             while (isDIGIT(*s))  /* optional digits after "." */
1601                 s++;
1602         }
1603     }
1604     else if (*s == '.') {
1605         s++;
1606         /* no digits before '.' means we need digits after it */
1607         if (isDIGIT(*s)) {
1608             do {
1609                 s++;
1610             } while (isDIGIT(*s));
1611         }
1612         else
1613             return 0;
1614     }
1615     else
1616         return 0;
1617
1618     /*
1619      * we return 1 if the number can be converted to _integer_ with atol()
1620      * and 2 if you need (int)atof().
1621      */
1622     numtype = 1;
1623
1624     /* we can have an optional exponent part */
1625     if (*s == 'e' || *s == 'E') {
1626         numtype = 2;
1627         s++;
1628         if (*s == '+' || *s == '-')
1629             s++;
1630         if (isDIGIT(*s)) {
1631             do {
1632                 s++;
1633             } while (isDIGIT(*s));
1634         }
1635         else
1636             return 0;
1637     }
1638     while (isSPACE(*s))
1639         s++;
1640     if (s >= send)
1641         return numtype;
1642     if (len == 10 && memEQ(sbegin, "0 but true", 10))
1643         return 1;
1644     return 0;
1645 }
1646
1647 char *
1648 sv_2pv(register SV *sv, STRLEN *lp)
1649 {
1650     register char *s;
1651     int olderrno;
1652     SV *tsv;
1653     char tmpbuf[64];    /* Must fit sprintf/Gconvert of longest IV/NV */
1654
1655     if (!sv) {
1656         *lp = 0;
1657         return "";
1658     }
1659     if (SvGMAGICAL(sv)) {
1660         mg_get(sv);
1661         if (SvPOKp(sv)) {
1662             *lp = SvCUR(sv);
1663             return SvPVX(sv);
1664         }
1665         if (SvIOKp(sv)) {
1666             (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1667             tsv = Nullsv;
1668             goto tokensave;
1669         }
1670         if (SvNOKp(sv)) {
1671             SET_NUMERIC_STANDARD();
1672             Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1673             tsv = Nullsv;
1674             goto tokensave;
1675         }
1676         if (!SvROK(sv)) {
1677             if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1678                 dTHR;
1679                 if (!localizing)
1680                     warn(warn_uninit);
1681             }
1682             *lp = 0;
1683             return "";
1684         }
1685     }
1686     if (SvTHINKFIRST(sv)) {
1687         if (SvROK(sv)) {
1688 #ifdef OVERLOAD
1689             SV* tmpstr;
1690             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1691               return SvPV(tmpstr,*lp);
1692 #endif /* OVERLOAD */
1693             sv = (SV*)SvRV(sv);
1694             if (!sv)
1695                 s = "NULLREF";
1696             else {
1697                 switch (SvTYPE(sv)) {
1698                 case SVt_NULL:
1699                 case SVt_IV:
1700                 case SVt_NV:
1701                 case SVt_RV:
1702                 case SVt_PV:
1703                 case SVt_PVIV:
1704                 case SVt_PVNV:
1705                 case SVt_PVBM:
1706                 case SVt_PVMG:  s = "SCALAR";                   break;
1707                 case SVt_PVLV:  s = "LVALUE";                   break;
1708                 case SVt_PVAV:  s = "ARRAY";                    break;
1709                 case SVt_PVHV:  s = "HASH";                     break;
1710                 case SVt_PVCV:  s = "CODE";                     break;
1711                 case SVt_PVGV:  s = "GLOB";                     break;
1712                 case SVt_PVFM:  s = "FORMLINE";                 break;
1713                 case SVt_PVIO:  s = "IO";                       break;
1714                 default:        s = "UNKNOWN";                  break;
1715                 }
1716                 tsv = NEWSV(0,0);
1717                 if (SvOBJECT(sv))
1718                     sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1719                 else
1720                     sv_setpv(tsv, s);
1721                 sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
1722                 goto tokensaveref;
1723             }
1724             *lp = strlen(s);
1725             return s;
1726         }
1727         if (SvREADONLY(sv)) {
1728             if (SvNOKp(sv)) {
1729                 SET_NUMERIC_STANDARD();
1730                 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1731                 tsv = Nullsv;
1732                 goto tokensave;
1733             }
1734             if (SvIOKp(sv)) {
1735                 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1736                 tsv = Nullsv;
1737                 goto tokensave;
1738             }
1739             if (dowarn)
1740                 warn(warn_uninit);
1741             *lp = 0;
1742             return "";
1743         }
1744     }
1745     (void)SvUPGRADE(sv, SVt_PV);
1746     if (SvNOKp(sv)) {
1747         if (SvTYPE(sv) < SVt_PVNV)
1748             sv_upgrade(sv, SVt_PVNV);
1749         SvGROW(sv, 28);
1750         s = SvPVX(sv);
1751         olderrno = errno;       /* some Xenix systems wipe out errno here */
1752 #ifdef apollo
1753         if (SvNVX(sv) == 0.0)
1754             (void)strcpy(s,"0");
1755         else
1756 #endif /*apollo*/
1757         {
1758             SET_NUMERIC_STANDARD();
1759             Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1760         }
1761         errno = olderrno;
1762 #ifdef FIXNEGATIVEZERO
1763         if (*s == '-' && s[1] == '0' && !s[2])
1764             strcpy(s,"0");
1765 #endif
1766         while (*s) s++;
1767 #ifdef hcx
1768         if (s[-1] == '.')
1769             *--s = '\0';
1770 #endif
1771     }
1772     else if (SvIOKp(sv)) {
1773         U32 oldIOK = SvIOK(sv);
1774         if (SvTYPE(sv) < SVt_PVIV)
1775             sv_upgrade(sv, SVt_PVIV);
1776         olderrno = errno;       /* some Xenix systems wipe out errno here */
1777         sv_setpviv(sv, SvIVX(sv));
1778         errno = olderrno;
1779         s = SvEND(sv);
1780         if (oldIOK)
1781             SvIOK_on(sv);
1782         else
1783             SvIOKp_on(sv);
1784     }
1785     else {
1786         dTHR;
1787         if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1788             warn(warn_uninit);
1789         *lp = 0;
1790         return "";
1791     }
1792     *lp = s - SvPVX(sv);
1793     SvCUR_set(sv, *lp);
1794     SvPOK_on(sv);
1795     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1796     return SvPVX(sv);
1797
1798   tokensave:
1799     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
1800         /* Sneaky stuff here */
1801
1802       tokensaveref:
1803         if (!tsv)
1804             tsv = newSVpv(tmpbuf, 0);
1805         sv_2mortal(tsv);
1806         *lp = SvCUR(tsv);
1807         return SvPVX(tsv);
1808     }
1809     else {
1810         STRLEN len;
1811         char *t;
1812
1813         if (tsv) {
1814             sv_2mortal(tsv);
1815             t = SvPVX(tsv);
1816             len = SvCUR(tsv);
1817         }
1818         else {
1819             t = tmpbuf;
1820             len = strlen(tmpbuf);
1821         }
1822 #ifdef FIXNEGATIVEZERO
1823         if (len == 2 && t[0] == '-' && t[1] == '0') {
1824             t = "0";
1825             len = 1;
1826         }
1827 #endif
1828         (void)SvUPGRADE(sv, SVt_PV);
1829         *lp = len;
1830         s = SvGROW(sv, len + 1);
1831         SvCUR_set(sv, len);
1832         (void)strcpy(s, t);
1833         SvPOKp_on(sv);
1834         return s;
1835     }
1836 }
1837
1838 /* This function is only called on magical items */
1839 bool
1840 sv_2bool(register SV *sv)
1841 {
1842     if (SvGMAGICAL(sv))
1843         mg_get(sv);
1844
1845     if (!SvOK(sv))
1846         return 0;
1847     if (SvROK(sv)) {
1848 #ifdef OVERLOAD
1849       {
1850         dTHR;
1851         SV* tmpsv;
1852         if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1853           return SvTRUE(tmpsv);
1854       }
1855 #endif /* OVERLOAD */
1856       return SvRV(sv) != 0;
1857     }
1858     if (SvPOKp(sv)) {
1859         register XPV* Xpvtmp;
1860         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1861                 (*Xpvtmp->xpv_pv > '0' ||
1862                 Xpvtmp->xpv_cur > 1 ||
1863                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
1864             return 1;
1865         else
1866             return 0;
1867     }
1868     else {
1869         if (SvIOKp(sv))
1870             return SvIVX(sv) != 0;
1871         else {
1872             if (SvNOKp(sv))
1873                 return SvNVX(sv) != 0.0;
1874             else
1875                 return FALSE;
1876         }
1877     }
1878 }
1879
1880 /* Note: sv_setsv() should not be called with a source string that needs
1881  * to be reused, since it may destroy the source string if it is marked
1882  * as temporary.
1883  */
1884
1885 void
1886 sv_setsv(SV *dstr, register SV *sstr)
1887 {
1888     dTHR;
1889     register U32 sflags;
1890     register int dtype;
1891     register int stype;
1892
1893     if (sstr == dstr)
1894         return;
1895     SV_CHECK_THINKFIRST(dstr);
1896     if (!sstr)
1897         sstr = &sv_undef;
1898     stype = SvTYPE(sstr);
1899     dtype = SvTYPE(dstr);
1900
1901     if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) {
1902         sv_unglob(dstr);     /* so fake GLOB won't perpetuate */
1903         sv_setpvn(dstr, "", 0);
1904         (void)SvPOK_only(dstr);
1905         dtype = SvTYPE(dstr);
1906     }
1907
1908 #ifdef OVERLOAD
1909     SvAMAGIC_off(dstr);
1910 #endif /* OVERLOAD */
1911     /* There's a lot of redundancy below but we're going for speed here */
1912
1913     switch (stype) {
1914     case SVt_NULL:
1915         (void)SvOK_off(dstr);
1916         return;
1917     case SVt_IV:
1918         if (dtype != SVt_IV && dtype < SVt_PVIV) {
1919             if (dtype < SVt_IV)
1920                 sv_upgrade(dstr, SVt_IV);
1921             else if (dtype == SVt_NV)
1922                 sv_upgrade(dstr, SVt_PVNV);
1923             else
1924                 sv_upgrade(dstr, SVt_PVIV);
1925         }
1926         break;
1927     case SVt_NV:
1928         if (dtype != SVt_NV && dtype < SVt_PVNV) {
1929             if (dtype < SVt_NV)
1930                 sv_upgrade(dstr, SVt_NV);
1931             else
1932                 sv_upgrade(dstr, SVt_PVNV);
1933         }
1934         break;
1935     case SVt_RV:
1936         if (dtype < SVt_RV)
1937             sv_upgrade(dstr, SVt_RV);
1938         else if (dtype == SVt_PVGV &&
1939                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
1940             sstr = SvRV(sstr);
1941             if (sstr == dstr) {
1942                 if (curcop->cop_stash != GvSTASH(dstr))
1943                     GvIMPORTED_on(dstr);
1944                 GvMULTI_on(dstr);
1945                 return;
1946             }
1947             goto glob_assign;
1948         }
1949         break;
1950     case SVt_PV:
1951     case SVt_PVFM:
1952         if (dtype < SVt_PV)
1953             sv_upgrade(dstr, SVt_PV);
1954         break;
1955     case SVt_PVIV:
1956         if (dtype < SVt_PVIV)
1957             sv_upgrade(dstr, SVt_PVIV);
1958         break;
1959     case SVt_PVNV:
1960         if (dtype < SVt_PVNV)
1961             sv_upgrade(dstr, SVt_PVNV);
1962         break;
1963     case SVt_PVAV:
1964     case SVt_PVHV:
1965     case SVt_PVCV:
1966     case SVt_PVIO:
1967         if (op)
1968             croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
1969                 op_name[op->op_type]);
1970         else
1971             croak("Bizarre copy of %s", sv_reftype(sstr, 0));
1972         break;
1973
1974     case SVt_PVGV:
1975         if (dtype <= SVt_PVGV) {
1976   glob_assign:
1977             if (dtype != SVt_PVGV) {
1978                 char *name = GvNAME(sstr);
1979                 STRLEN len = GvNAMELEN(sstr);
1980                 sv_upgrade(dstr, SVt_PVGV);
1981                 sv_magic(dstr, dstr, '*', name, len);
1982                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
1983                 GvNAME(dstr) = savepvn(name, len);
1984                 GvNAMELEN(dstr) = len;
1985                 SvFAKE_on(dstr);        /* can coerce to non-glob */
1986             }
1987             /* ahem, death to those who redefine active sort subs */
1988             else if (curstackinfo->si_type == SI_SORT
1989                      && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr)))
1990                 croak("Can't redefine active sort subroutine %s",
1991                       GvNAME(dstr));
1992             (void)SvOK_off(dstr);
1993             GvINTRO_off(dstr);          /* one-shot flag */
1994             gp_free((GV*)dstr);
1995             GvGP(dstr) = gp_ref(GvGP(sstr));
1996             SvTAINT(dstr);
1997             if (curcop->cop_stash != GvSTASH(dstr))
1998                 GvIMPORTED_on(dstr);
1999             GvMULTI_on(dstr);
2000             return;
2001         }
2002         /* FALL THROUGH */
2003
2004     default:
2005         if (SvGMAGICAL(sstr)) {
2006             mg_get(sstr);
2007             if (SvTYPE(sstr) != stype) {
2008                 stype = SvTYPE(sstr);
2009                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2010                     goto glob_assign;
2011             }
2012         }
2013         if (stype == SVt_PVLV)
2014             SvUPGRADE(dstr, SVt_PVNV);
2015         else
2016             SvUPGRADE(dstr, stype);
2017     }
2018
2019     sflags = SvFLAGS(sstr);
2020
2021     if (sflags & SVf_ROK) {
2022         if (dtype >= SVt_PV) {
2023             if (dtype == SVt_PVGV) {
2024                 dTHR;
2025                 SV *sref = SvREFCNT_inc(SvRV(sstr));
2026                 SV *dref = 0;
2027                 int intro = GvINTRO(dstr);
2028
2029                 if (intro) {
2030                     GP *gp;
2031                     GvGP(dstr)->gp_refcnt--;
2032                     GvINTRO_off(dstr);  /* one-shot flag */
2033                     Newz(602,gp, 1, GP);
2034                     GvGP(dstr) = gp_ref(gp);
2035                     GvSV(dstr) = NEWSV(72,0);
2036                     GvLINE(dstr) = curcop->cop_line;
2037                     GvEGV(dstr) = (GV*)dstr;
2038                 }
2039                 GvMULTI_on(dstr);
2040                 switch (SvTYPE(sref)) {
2041                 case SVt_PVAV:
2042                     if (intro)
2043                         SAVESPTR(GvAV(dstr));
2044                     else
2045                         dref = (SV*)GvAV(dstr);
2046                     GvAV(dstr) = (AV*)sref;
2047                     if (curcop->cop_stash != GvSTASH(dstr))
2048                         GvIMPORTED_AV_on(dstr);
2049                     break;
2050                 case SVt_PVHV:
2051                     if (intro)
2052                         SAVESPTR(GvHV(dstr));
2053                     else
2054                         dref = (SV*)GvHV(dstr);
2055                     GvHV(dstr) = (HV*)sref;
2056                     if (curcop->cop_stash != GvSTASH(dstr))
2057                         GvIMPORTED_HV_on(dstr);
2058                     break;
2059                 case SVt_PVCV:
2060                     if (intro) {
2061                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2062                             SvREFCNT_dec(GvCV(dstr));
2063                             GvCV(dstr) = Nullcv;
2064                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2065                             sub_generation++;
2066                         }
2067                         SAVESPTR(GvCV(dstr));
2068                     }
2069                     else
2070                         dref = (SV*)GvCV(dstr);
2071                     if (GvCV(dstr) != (CV*)sref) {
2072                         CV* cv = GvCV(dstr);
2073                         if (cv) {
2074                             if (!GvCVGEN((GV*)dstr) &&
2075                                 (CvROOT(cv) || CvXSUB(cv)))
2076                             {
2077                                 /* ahem, death to those who redefine
2078                                  * active sort subs */
2079                                 if (curstackinfo->si_type == SI_SORT &&
2080                                       sortcop == CvSTART(cv))
2081                                     croak(
2082                                     "Can't redefine active sort subroutine %s",
2083                                           GvENAME((GV*)dstr));
2084                                 if (cv_const_sv(cv))
2085                                     warn("Constant subroutine %s redefined",
2086                                          GvENAME((GV*)dstr));
2087                                 else if (dowarn) {
2088                                     if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2089                                           && HvNAME(GvSTASH(CvGV(cv)))
2090                                           && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2091                                                    "autouse")))
2092                                         warn("Subroutine %s redefined",
2093                                              GvENAME((GV*)dstr));
2094                                 }
2095                             }
2096                             cv_ckproto(cv, (GV*)dstr,
2097                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
2098                         }
2099                         GvCV(dstr) = (CV*)sref;
2100                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2101                         GvASSUMECV_on(dstr);
2102                         sub_generation++;
2103                     }
2104                     if (curcop->cop_stash != GvSTASH(dstr))
2105                         GvIMPORTED_CV_on(dstr);
2106                     break;
2107                 case SVt_PVIO:
2108                     if (intro)
2109                         SAVESPTR(GvIOp(dstr));
2110                     else
2111                         dref = (SV*)GvIOp(dstr);
2112                     GvIOp(dstr) = (IO*)sref;
2113                     break;
2114                 default:
2115                     if (intro)
2116                         SAVESPTR(GvSV(dstr));
2117                     else
2118                         dref = (SV*)GvSV(dstr);
2119                     GvSV(dstr) = sref;
2120                     if (curcop->cop_stash != GvSTASH(dstr))
2121                         GvIMPORTED_SV_on(dstr);
2122                     break;
2123                 }
2124                 if (dref)
2125                     SvREFCNT_dec(dref);
2126                 if (intro)
2127                     SAVEFREESV(sref);
2128                 SvTAINT(dstr);
2129                 return;
2130             }
2131             if (SvPVX(dstr)) {
2132                 (void)SvOOK_off(dstr);          /* backoff */
2133                 Safefree(SvPVX(dstr));
2134                 SvLEN(dstr)=SvCUR(dstr)=0;
2135             }
2136         }
2137         (void)SvOK_off(dstr);
2138         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2139         SvROK_on(dstr);
2140         if (sflags & SVp_NOK) {
2141             SvNOK_on(dstr);
2142             SvNVX(dstr) = SvNVX(sstr);
2143         }
2144         if (sflags & SVp_IOK) {
2145             (void)SvIOK_on(dstr);
2146             SvIVX(dstr) = SvIVX(sstr);
2147         }
2148 #ifdef OVERLOAD
2149         if (SvAMAGIC(sstr)) {
2150             SvAMAGIC_on(dstr);
2151         }
2152 #endif /* OVERLOAD */
2153     }
2154     else if (sflags & SVp_POK) {
2155
2156         /*
2157          * Check to see if we can just swipe the string.  If so, it's a
2158          * possible small lose on short strings, but a big win on long ones.
2159          * It might even be a win on short strings if SvPVX(dstr)
2160          * has to be allocated and SvPVX(sstr) has to be freed.
2161          */
2162
2163         if (SvTEMP(sstr) &&             /* slated for free anyway? */
2164             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
2165             !(sflags & SVf_OOK))        /* and not involved in OOK hack? */
2166         {
2167             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
2168                 if (SvOOK(dstr)) {
2169                     SvFLAGS(dstr) &= ~SVf_OOK;
2170                     Safefree(SvPVX(dstr) - SvIVX(dstr));
2171                 }
2172                 else
2173                     Safefree(SvPVX(dstr));
2174             }
2175             (void)SvPOK_only(dstr);
2176             SvPV_set(dstr, SvPVX(sstr));
2177             SvLEN_set(dstr, SvLEN(sstr));
2178             SvCUR_set(dstr, SvCUR(sstr));
2179             SvTEMP_off(dstr);
2180             (void)SvOK_off(sstr);
2181             SvPV_set(sstr, Nullch);
2182             SvLEN_set(sstr, 0);
2183             SvCUR_set(sstr, 0);
2184             SvTEMP_off(sstr);
2185         }
2186         else {                                  /* have to copy actual string */
2187             STRLEN len = SvCUR(sstr);
2188
2189             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
2190             Move(SvPVX(sstr),SvPVX(dstr),len,char);
2191             SvCUR_set(dstr, len);
2192             *SvEND(dstr) = '\0';
2193             (void)SvPOK_only(dstr);
2194         }
2195         /*SUPPRESS 560*/
2196         if (sflags & SVp_NOK) {
2197             SvNOK_on(dstr);
2198             SvNVX(dstr) = SvNVX(sstr);
2199         }
2200         if (sflags & SVp_IOK) {
2201             (void)SvIOK_on(dstr);
2202             SvIVX(dstr) = SvIVX(sstr);
2203         }
2204     }
2205     else if (sflags & SVp_NOK) {
2206         SvNVX(dstr) = SvNVX(sstr);
2207         (void)SvNOK_only(dstr);
2208         if (SvIOK(sstr)) {
2209             (void)SvIOK_on(dstr);
2210             SvIVX(dstr) = SvIVX(sstr);
2211         }
2212     }
2213     else if (sflags & SVp_IOK) {
2214         (void)SvIOK_only(dstr);
2215         SvIVX(dstr) = SvIVX(sstr);
2216     }
2217     else {
2218         (void)SvOK_off(dstr);
2219     }
2220     SvTAINT(dstr);
2221 }
2222
2223 void
2224 sv_setsv_mg(SV *dstr, register SV *sstr)
2225 {
2226     sv_setsv(dstr,sstr);
2227     SvSETMAGIC(dstr);
2228 }
2229
2230 void
2231 sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len)
2232 {
2233     register char *dptr;
2234     assert(len >= 0);  /* STRLEN is probably unsigned, so this may
2235                           elicit a warning, but it won't hurt. */
2236     SV_CHECK_THINKFIRST(sv);
2237     if (!ptr) {
2238         (void)SvOK_off(sv);
2239         return;
2240     }
2241     if (SvTYPE(sv) >= SVt_PV) {
2242         if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2243             sv_unglob(sv);
2244     }
2245     else
2246         sv_upgrade(sv, SVt_PV);
2247
2248     SvGROW(sv, len + 1);
2249     dptr = SvPVX(sv);
2250     Move(ptr,dptr,len,char);
2251     dptr[len] = '\0';
2252     SvCUR_set(sv, len);
2253     (void)SvPOK_only(sv);               /* validate pointer */
2254     SvTAINT(sv);
2255 }
2256
2257 void
2258 sv_setpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
2259 {
2260     sv_setpvn(sv,ptr,len);
2261     SvSETMAGIC(sv);
2262 }
2263
2264 void
2265 sv_setpv(register SV *sv, register const char *ptr)
2266 {
2267     register STRLEN len;
2268
2269     SV_CHECK_THINKFIRST(sv);
2270     if (!ptr) {
2271         (void)SvOK_off(sv);
2272         return;
2273     }
2274     len = strlen(ptr);
2275     if (SvTYPE(sv) >= SVt_PV) {
2276         if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2277             sv_unglob(sv);
2278     }
2279     else
2280         sv_upgrade(sv, SVt_PV);
2281
2282     SvGROW(sv, len + 1);
2283     Move(ptr,SvPVX(sv),len+1,char);
2284     SvCUR_set(sv, len);
2285     (void)SvPOK_only(sv);               /* validate pointer */
2286     SvTAINT(sv);
2287 }
2288
2289 void
2290 sv_setpv_mg(register SV *sv, register const char *ptr)
2291 {
2292     sv_setpv(sv,ptr);
2293     SvSETMAGIC(sv);
2294 }
2295
2296 void
2297 sv_usepvn(register SV *sv, register char *ptr, register STRLEN len)
2298 {
2299     SV_CHECK_THINKFIRST(sv);
2300     (void)SvUPGRADE(sv, SVt_PV);
2301     if (!ptr) {
2302         (void)SvOK_off(sv);
2303         return;
2304     }
2305     if (SvPVX(sv))
2306         Safefree(SvPVX(sv));
2307     Renew(ptr, len+1, char);
2308     SvPVX(sv) = ptr;
2309     SvCUR_set(sv, len);
2310     SvLEN_set(sv, len+1);
2311     *SvEND(sv) = '\0';
2312     (void)SvPOK_only(sv);               /* validate pointer */
2313     SvTAINT(sv);
2314 }
2315
2316 void
2317 sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len)
2318 {
2319     sv_usepvn(sv,ptr,len);
2320     SvSETMAGIC(sv);
2321 }
2322
2323 STATIC void
2324 sv_check_thinkfirst(register SV *sv)
2325 {
2326     if (SvREADONLY(sv)) {
2327         dTHR;
2328         if (curcop != &compiling)
2329             croak(no_modify);
2330     }
2331     if (SvROK(sv))
2332         sv_unref(sv);
2333 }
2334
2335 void
2336 sv_chop(register SV *sv, register char *ptr)    /* like set but assuming ptr is in sv */
2337
2338
2339 {
2340     register STRLEN delta;
2341
2342     if (!ptr || !SvPOKp(sv))
2343         return;
2344     SV_CHECK_THINKFIRST(sv);
2345     if (SvTYPE(sv) < SVt_PVIV)
2346         sv_upgrade(sv,SVt_PVIV);
2347
2348     if (!SvOOK(sv)) {
2349         SvIVX(sv) = 0;
2350         SvFLAGS(sv) |= SVf_OOK;
2351     }
2352     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK);
2353     delta = ptr - SvPVX(sv);
2354     SvLEN(sv) -= delta;
2355     SvCUR(sv) -= delta;
2356     SvPVX(sv) += delta;
2357     SvIVX(sv) += delta;
2358 }
2359
2360 void
2361 sv_catpvn(register SV *sv, register char *ptr, register STRLEN len)
2362 {
2363     STRLEN tlen;
2364     char *junk;
2365
2366     junk = SvPV_force(sv, tlen);
2367     SvGROW(sv, tlen + len + 1);
2368     if (ptr == junk)
2369         ptr = SvPVX(sv);
2370     Move(ptr,SvPVX(sv)+tlen,len,char);
2371     SvCUR(sv) += len;
2372     *SvEND(sv) = '\0';
2373     (void)SvPOK_only(sv);               /* validate pointer */
2374     SvTAINT(sv);
2375 }
2376
2377 void
2378 sv_catpvn_mg(register SV *sv, register char *ptr, register STRLEN len)
2379 {
2380     sv_catpvn(sv,ptr,len);
2381     SvSETMAGIC(sv);
2382 }
2383
2384 void
2385 sv_catsv(SV *dstr, register SV *sstr)
2386 {
2387     char *s;
2388     STRLEN len;
2389     if (!sstr)
2390         return;
2391     if (s = SvPV(sstr, len))
2392         sv_catpvn(dstr,s,len);
2393 }
2394
2395 void
2396 sv_catsv_mg(SV *dstr, register SV *sstr)
2397 {
2398     sv_catsv(dstr,sstr);
2399     SvSETMAGIC(dstr);
2400 }
2401
2402 void
2403 sv_catpv(register SV *sv, register char *ptr)
2404 {
2405     register STRLEN len;
2406     STRLEN tlen;
2407     char *junk;
2408
2409     if (!ptr)
2410         return;
2411     junk = SvPV_force(sv, tlen);
2412     len = strlen(ptr);
2413     SvGROW(sv, tlen + len + 1);
2414     if (ptr == junk)
2415         ptr = SvPVX(sv);
2416     Move(ptr,SvPVX(sv)+tlen,len+1,char);
2417     SvCUR(sv) += len;
2418     (void)SvPOK_only(sv);               /* validate pointer */
2419     SvTAINT(sv);
2420 }
2421
2422 void
2423 sv_catpv_mg(register SV *sv, register char *ptr)
2424 {
2425     sv_catpv(sv,ptr);
2426     SvSETMAGIC(sv);
2427 }
2428
2429 SV *
2430 #ifdef LEAKTEST
2431 newSV(I32 x, STRLEN len)
2432 #else
2433 newSV(STRLEN len)
2434 #endif
2435 {
2436     register SV *sv;
2437
2438     new_SV(sv);
2439     SvANY(sv) = 0;
2440     SvREFCNT(sv) = 1;
2441     SvFLAGS(sv) = 0;
2442     if (len) {
2443         sv_upgrade(sv, SVt_PV);
2444         SvGROW(sv, len + 1);
2445     }
2446     return sv;
2447 }
2448
2449 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2450
2451 void
2452 sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen)
2453 {
2454     MAGIC* mg;
2455
2456     if (SvREADONLY(sv)) {
2457         dTHR;
2458         if (curcop != &compiling && !strchr("gBf", how))
2459             croak(no_modify);
2460     }
2461     if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2462         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2463             if (how == 't')
2464                 mg->mg_len |= 1;
2465             return;
2466         }
2467     }
2468     else {
2469         (void)SvUPGRADE(sv, SVt_PVMG);
2470     }
2471     Newz(702,mg, 1, MAGIC);
2472     mg->mg_moremagic = SvMAGIC(sv);
2473
2474     SvMAGIC(sv) = mg;
2475     if (!obj || obj == sv || how == '#' || how == 'r')
2476         mg->mg_obj = obj;
2477     else {
2478         dTHR;
2479         mg->mg_obj = SvREFCNT_inc(obj);
2480         mg->mg_flags |= MGf_REFCOUNTED;
2481     }
2482     mg->mg_type = how;
2483     mg->mg_len = namlen;
2484     if (name)
2485         if (namlen >= 0)
2486             mg->mg_ptr = savepvn(name, namlen);
2487         else if (namlen == HEf_SVKEY)
2488             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2489
2490     switch (how) {
2491     case 0:
2492         mg->mg_virtual = &vtbl_sv;
2493         break;
2494 #ifdef OVERLOAD
2495     case 'A':
2496         mg->mg_virtual = &vtbl_amagic;
2497         break;
2498     case 'a':
2499         mg->mg_virtual = &vtbl_amagicelem;
2500         break;
2501     case 'c':
2502         mg->mg_virtual = 0;
2503         break;
2504 #endif /* OVERLOAD */
2505     case 'B':
2506         mg->mg_virtual = &vtbl_bm;
2507         break;
2508     case 'E':
2509         mg->mg_virtual = &vtbl_env;
2510         break;
2511     case 'f':
2512         mg->mg_virtual = &vtbl_fm;
2513         break;
2514     case 'e':
2515         mg->mg_virtual = &vtbl_envelem;
2516         break;
2517     case 'g':
2518         mg->mg_virtual = &vtbl_mglob;
2519         break;
2520     case 'I':
2521         mg->mg_virtual = &vtbl_isa;
2522         break;
2523     case 'i':
2524         mg->mg_virtual = &vtbl_isaelem;
2525         break;
2526     case 'k':
2527         mg->mg_virtual = &vtbl_nkeys;
2528         break;
2529     case 'L':
2530         SvRMAGICAL_on(sv);
2531         mg->mg_virtual = 0;
2532         break;
2533     case 'l':
2534         mg->mg_virtual = &vtbl_dbline;
2535         break;
2536 #ifdef USE_THREADS
2537     case 'm':
2538         mg->mg_virtual = &vtbl_mutex;
2539         break;
2540 #endif /* USE_THREADS */
2541 #ifdef USE_LOCALE_COLLATE
2542     case 'o':
2543         mg->mg_virtual = &vtbl_collxfrm;
2544         break;
2545 #endif /* USE_LOCALE_COLLATE */
2546     case 'P':
2547         mg->mg_virtual = &vtbl_pack;
2548         break;
2549     case 'p':
2550     case 'q':
2551         mg->mg_virtual = &vtbl_packelem;
2552         break;
2553     case 'r':
2554         mg->mg_virtual = &vtbl_regexp;
2555         break;
2556     case 'S':
2557         mg->mg_virtual = &vtbl_sig;
2558         break;
2559     case 's':
2560         mg->mg_virtual = &vtbl_sigelem;
2561         break;
2562     case 't':
2563         mg->mg_virtual = &vtbl_taint;
2564         mg->mg_len = 1;
2565         break;
2566     case 'U':
2567         mg->mg_virtual = &vtbl_uvar;
2568         break;
2569     case 'v':
2570         mg->mg_virtual = &vtbl_vec;
2571         break;
2572     case 'x':
2573         mg->mg_virtual = &vtbl_substr;
2574         break;
2575     case 'y':
2576         mg->mg_virtual = &vtbl_defelem;
2577         break;
2578     case '*':
2579         mg->mg_virtual = &vtbl_glob;
2580         break;
2581     case '#':
2582         mg->mg_virtual = &vtbl_arylen;
2583         break;
2584     case '.':
2585         mg->mg_virtual = &vtbl_pos;
2586         break;
2587     case '~':   /* Reserved for use by extensions not perl internals.   */
2588         /* Useful for attaching extension internal data to perl vars.   */
2589         /* Note that multiple extensions may clash if magical scalars   */
2590         /* etc holding private data from one are passed to another.     */
2591         SvRMAGICAL_on(sv);
2592         break;
2593     default:
2594         croak("Don't know how to handle magic of type '%c'", how);
2595     }
2596     mg_magical(sv);
2597     if (SvGMAGICAL(sv))
2598         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2599 }
2600
2601 int
2602 sv_unmagic(SV *sv, int type)
2603 {
2604     MAGIC* mg;
2605     MAGIC** mgp;
2606     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2607         return 0;
2608     mgp = &SvMAGIC(sv);
2609     for (mg = *mgp; mg; mg = *mgp) {
2610         if (mg->mg_type == type) {
2611             MGVTBL* vtbl = mg->mg_virtual;
2612             *mgp = mg->mg_moremagic;
2613             if (vtbl && (vtbl->svt_free != NULL))
2614                 (VTBL->svt_free)(sv, mg);
2615             if (mg->mg_ptr && mg->mg_type != 'g')
2616                 if (mg->mg_len >= 0)
2617                     Safefree(mg->mg_ptr);
2618                 else if (mg->mg_len == HEf_SVKEY)
2619                     SvREFCNT_dec((SV*)mg->mg_ptr);
2620             if (mg->mg_flags & MGf_REFCOUNTED)
2621                 SvREFCNT_dec(mg->mg_obj);
2622             Safefree(mg);
2623         }
2624         else
2625             mgp = &mg->mg_moremagic;
2626     }
2627     if (!SvMAGIC(sv)) {
2628         SvMAGICAL_off(sv);
2629         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2630     }
2631
2632     return 0;
2633 }
2634
2635 void
2636 sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2637 {
2638     register char *big;
2639     register char *mid;
2640     register char *midend;
2641     register char *bigend;
2642     register I32 i;
2643
2644     if (!bigstr)
2645         croak("Can't modify non-existent substring");
2646     SvPV_force(bigstr, na);
2647
2648     i = littlelen - len;
2649     if (i > 0) {                        /* string might grow */
2650         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2651         mid = big + offset + len;
2652         midend = bigend = big + SvCUR(bigstr);
2653         bigend += i;
2654         *bigend = '\0';
2655         while (midend > mid)            /* shove everything down */
2656             *--bigend = *--midend;
2657         Move(little,big+offset,littlelen,char);
2658         SvCUR(bigstr) += i;
2659         SvSETMAGIC(bigstr);
2660         return;
2661     }
2662     else if (i == 0) {
2663         Move(little,SvPVX(bigstr)+offset,len,char);
2664         SvSETMAGIC(bigstr);
2665         return;
2666     }
2667
2668     big = SvPVX(bigstr);
2669     mid = big + offset;
2670     midend = mid + len;
2671     bigend = big + SvCUR(bigstr);
2672
2673     if (midend > bigend)
2674         croak("panic: sv_insert");
2675
2676     if (mid - big > bigend - midend) {  /* faster to shorten from end */
2677         if (littlelen) {
2678             Move(little, mid, littlelen,char);
2679             mid += littlelen;
2680         }
2681         i = bigend - midend;
2682         if (i > 0) {
2683             Move(midend, mid, i,char);
2684             mid += i;
2685         }
2686         *mid = '\0';
2687         SvCUR_set(bigstr, mid - big);
2688     }
2689     /*SUPPRESS 560*/
2690     else if (i = mid - big) {   /* faster from front */
2691         midend -= littlelen;
2692         mid = midend;
2693         sv_chop(bigstr,midend-i);
2694         big += i;
2695         while (i--)
2696             *--midend = *--big;
2697         if (littlelen)
2698             Move(little, mid, littlelen,char);
2699     }
2700     else if (littlelen) {
2701         midend -= littlelen;
2702         sv_chop(bigstr,midend);
2703         Move(little,midend,littlelen,char);
2704     }
2705     else {
2706         sv_chop(bigstr,midend);
2707     }
2708     SvSETMAGIC(bigstr);
2709 }
2710
2711 /* make sv point to what nstr did */
2712
2713 void
2714 sv_replace(register SV *sv, register SV *nsv)
2715 {
2716     U32 refcnt = SvREFCNT(sv);
2717     SV_CHECK_THINKFIRST(sv);
2718     if (SvREFCNT(nsv) != 1)
2719         warn("Reference miscount in sv_replace()");
2720     if (SvMAGICAL(sv)) {
2721         if (SvMAGICAL(nsv))
2722             mg_free(nsv);
2723         else
2724             sv_upgrade(nsv, SVt_PVMG);
2725         SvMAGIC(nsv) = SvMAGIC(sv);
2726         SvFLAGS(nsv) |= SvMAGICAL(sv);
2727         SvMAGICAL_off(sv);
2728         SvMAGIC(sv) = 0;
2729     }
2730     SvREFCNT(sv) = 0;
2731     sv_clear(sv);
2732     assert(!SvREFCNT(sv));
2733     StructCopy(nsv,sv,SV);
2734     SvREFCNT(sv) = refcnt;
2735     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
2736     del_SV(nsv);
2737 }
2738
2739 void
2740 sv_clear(register SV *sv)
2741 {
2742     HV* stash;
2743     assert(sv);
2744     assert(SvREFCNT(sv) == 0);
2745
2746     if (SvOBJECT(sv)) {
2747         dTHR;
2748         if (defstash) {         /* Still have a symbol table? */
2749             djSP;
2750             GV* destructor;
2751             SV tmpref;
2752
2753             Zero(&tmpref, 1, SV);
2754             sv_upgrade(&tmpref, SVt_RV);
2755             SvROK_on(&tmpref);
2756             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
2757             SvREFCNT(&tmpref) = 1;
2758
2759             do {
2760                 stash = SvSTASH(sv);
2761                 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2762                 if (destructor) {
2763                     ENTER;
2764                     PUSHSTACK(SI_DESTROY);
2765                     SvRV(&tmpref) = SvREFCNT_inc(sv);
2766                     EXTEND(SP, 2);
2767                     PUSHMARK(SP);
2768                     PUSHs(&tmpref);
2769                     PUTBACK;
2770                     perl_call_sv((SV*)GvCV(destructor),
2771                                  G_DISCARD|G_EVAL|G_KEEPERR);
2772                     SvREFCNT(sv)--;
2773                     POPSTACK();
2774                     LEAVE;
2775                 }
2776             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
2777
2778             del_XRV(SvANY(&tmpref));
2779         }
2780
2781         if (SvOBJECT(sv)) {
2782             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
2783             SvOBJECT_off(sv);   /* Curse the object. */
2784             if (SvTYPE(sv) != SVt_PVIO)
2785                 --sv_objcount;  /* XXX Might want something more general */
2786         }
2787         if (SvREFCNT(sv)) {
2788                 if (in_clean_objs)
2789                     croak("DESTROY created new reference to dead object");
2790                 /* DESTROY gave object new lease on life */
2791                 return;
2792         }
2793     }
2794     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2795         mg_free(sv);
2796     stash = NULL;
2797     switch (SvTYPE(sv)) {
2798     case SVt_PVIO:
2799         if (IoIFP(sv) != PerlIO_stdin() &&
2800             IoIFP(sv) != PerlIO_stdout() &&
2801             IoIFP(sv) != PerlIO_stderr())
2802           io_close((IO*)sv);
2803         Safefree(IoTOP_NAME(sv));
2804         Safefree(IoFMT_NAME(sv));
2805         Safefree(IoBOTTOM_NAME(sv));
2806         /* FALL THROUGH */
2807     case SVt_PVBM:
2808         goto freescalar;
2809     case SVt_PVCV:
2810     case SVt_PVFM:
2811         cv_undef((CV*)sv);
2812         goto freescalar;
2813     case SVt_PVHV:
2814         hv_undef((HV*)sv);
2815         break;
2816     case SVt_PVAV:
2817         av_undef((AV*)sv);
2818         break;
2819     case SVt_PVGV:
2820         gp_free((GV*)sv);
2821         Safefree(GvNAME(sv));
2822         /* cannot decrease stash refcount yet, as we might recursively delete
2823            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
2824            of stash until current sv is completely gone.
2825            -- JohnPC, 27 Mar 1998 */
2826         stash = GvSTASH(sv);
2827         /* FALL THROUGH */
2828     case SVt_PVLV:
2829     case SVt_PVMG:
2830     case SVt_PVNV:
2831     case SVt_PVIV:
2832       freescalar:
2833         (void)SvOOK_off(sv);
2834         /* FALL THROUGH */
2835     case SVt_PV:
2836     case SVt_RV:
2837         if (SvROK(sv))
2838             SvREFCNT_dec(SvRV(sv));
2839         else if (SvPVX(sv) && SvLEN(sv))
2840             Safefree(SvPVX(sv));
2841         break;
2842 /*
2843     case SVt_NV:
2844     case SVt_IV:
2845     case SVt_NULL:
2846         break;
2847 */
2848     }
2849
2850     switch (SvTYPE(sv)) {
2851     case SVt_NULL:
2852         break;
2853     case SVt_IV:
2854         del_XIV(SvANY(sv));
2855         break;
2856     case SVt_NV:
2857         del_XNV(SvANY(sv));
2858         break;
2859     case SVt_RV:
2860         del_XRV(SvANY(sv));
2861         break;
2862     case SVt_PV:
2863         del_XPV(SvANY(sv));
2864         break;
2865     case SVt_PVIV:
2866         del_XPVIV(SvANY(sv));
2867         break;
2868     case SVt_PVNV:
2869         del_XPVNV(SvANY(sv));
2870         break;
2871     case SVt_PVMG:
2872         del_XPVMG(SvANY(sv));
2873         break;
2874     case SVt_PVLV:
2875         del_XPVLV(SvANY(sv));
2876         break;
2877     case SVt_PVAV:
2878         del_XPVAV(SvANY(sv));
2879         break;
2880     case SVt_PVHV:
2881         del_XPVHV(SvANY(sv));
2882         break;
2883     case SVt_PVCV:
2884         del_XPVCV(SvANY(sv));
2885         break;
2886     case SVt_PVGV:
2887         del_XPVGV(SvANY(sv));
2888         /* code duplication for increased performance. */
2889         SvFLAGS(sv) &= SVf_BREAK;
2890         SvFLAGS(sv) |= SVTYPEMASK;
2891         /* decrease refcount of the stash that owns this GV, if any */
2892         if (stash)
2893             SvREFCNT_dec(stash);
2894         return; /* not break, SvFLAGS reset already happened */
2895     case SVt_PVBM:
2896         del_XPVBM(SvANY(sv));
2897         break;
2898     case SVt_PVFM:
2899         del_XPVFM(SvANY(sv));
2900         break;
2901     case SVt_PVIO:
2902         del_XPVIO(SvANY(sv));
2903         break;
2904     }
2905     SvFLAGS(sv) &= SVf_BREAK;
2906     SvFLAGS(sv) |= SVTYPEMASK;
2907 }
2908
2909 SV *
2910 sv_newref(SV *sv)
2911 {
2912     if (sv)
2913         ATOMIC_INC(SvREFCNT(sv));
2914     return sv;
2915 }
2916
2917 void
2918 sv_free(SV *sv)
2919 {
2920     int refcount_is_zero;
2921
2922     if (!sv)
2923         return;
2924     if (SvREADONLY(sv)) {
2925         if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no)
2926             return;
2927     }
2928     if (SvREFCNT(sv) == 0) {
2929         if (SvFLAGS(sv) & SVf_BREAK)
2930             return;
2931         if (in_clean_all) /* All is fair */
2932             return;
2933         warn("Attempt to free unreferenced scalar");
2934         return;
2935     }
2936     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
2937     if (!refcount_is_zero)
2938         return;
2939 #ifdef DEBUGGING
2940     if (SvTEMP(sv)) {
2941         warn("Attempt to free temp prematurely: %s", SvPEEK(sv));
2942         return;
2943     }
2944 #endif
2945     sv_clear(sv);
2946     if (! SvREFCNT(sv))
2947         del_SV(sv);
2948 }
2949
2950 STRLEN
2951 sv_len(register SV *sv)
2952 {
2953     char *junk;
2954     STRLEN len;
2955
2956     if (!sv)
2957         return 0;
2958
2959     if (SvGMAGICAL(sv))
2960         len = mg_length(sv);
2961     else
2962         junk = SvPV(sv, len);
2963     return len;
2964 }
2965
2966 I32
2967 sv_eq(register SV *str1, register SV *str2)
2968 {
2969     char *pv1;
2970     STRLEN cur1;
2971     char *pv2;
2972     STRLEN cur2;
2973
2974     if (!str1) {
2975         pv1 = "";
2976         cur1 = 0;
2977     }
2978     else
2979         pv1 = SvPV(str1, cur1);
2980
2981     if (!str2)
2982         return !cur1;
2983     else
2984         pv2 = SvPV(str2, cur2);
2985
2986     if (cur1 != cur2)
2987         return 0;
2988
2989     return memEQ(pv1, pv2, cur1);
2990 }
2991
2992 I32
2993 sv_cmp(register SV *str1, register SV *str2)
2994 {
2995     STRLEN cur1 = 0;
2996     char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
2997     STRLEN cur2 = 0;
2998     char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
2999     I32 retval;
3000
3001     if (!cur1)
3002         return cur2 ? -1 : 0;
3003
3004     if (!cur2)
3005         return 1;
3006
3007     retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3008
3009     if (retval)
3010         return retval < 0 ? -1 : 1;
3011
3012     if (cur1 == cur2)
3013         return 0;
3014     else
3015         return cur1 < cur2 ? -1 : 1;
3016 }
3017
3018 I32
3019 sv_cmp_locale(register SV *sv1, register SV *sv2)
3020 {
3021 #ifdef USE_LOCALE_COLLATE
3022
3023     char *pv1, *pv2;
3024     STRLEN len1, len2;
3025     I32 retval;
3026
3027     if (collation_standard)
3028         goto raw_compare;
3029
3030     len1 = 0;
3031     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3032     len2 = 0;
3033     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3034
3035     if (!pv1 || !len1) {
3036         if (pv2 && len2)
3037             return -1;
3038         else
3039             goto raw_compare;
3040     }
3041     else {
3042         if (!pv2 || !len2)
3043             return 1;
3044     }
3045
3046     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3047
3048     if (retval)
3049         return retval < 0 ? -1 : 1;
3050
3051     /*
3052      * When the result of collation is equality, that doesn't mean
3053      * that there are no differences -- some locales exclude some
3054      * characters from consideration.  So to avoid false equalities,
3055      * we use the raw string as a tiebreaker.
3056      */
3057
3058   raw_compare:
3059     /* FALL THROUGH */
3060
3061 #endif /* USE_LOCALE_COLLATE */
3062
3063     return sv_cmp(sv1, sv2);
3064 }
3065
3066 #ifdef USE_LOCALE_COLLATE
3067 /*
3068  * Any scalar variable may carry an 'o' magic that contains the
3069  * scalar data of the variable transformed to such a format that
3070  * a normal memory comparison can be used to compare the data
3071  * according to the locale settings.
3072  */
3073 char *
3074 sv_collxfrm(SV *sv, STRLEN *nxp)
3075 {
3076     MAGIC *mg;
3077
3078     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3079     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) {
3080         char *s, *xf;
3081         STRLEN len, xlen;
3082
3083         if (mg)
3084             Safefree(mg->mg_ptr);
3085         s = SvPV(sv, len);
3086         if ((xf = mem_collxfrm(s, len, &xlen))) {
3087             if (SvREADONLY(sv)) {
3088                 SAVEFREEPV(xf);
3089                 *nxp = xlen;
3090                 return xf + sizeof(collation_ix);
3091             }
3092             if (! mg) {
3093                 sv_magic(sv, 0, 'o', 0, 0);
3094                 mg = mg_find(sv, 'o');
3095                 assert(mg);
3096             }
3097             mg->mg_ptr = xf;
3098             mg->mg_len = xlen;
3099         }
3100         else {
3101             if (mg) {
3102                 mg->mg_ptr = NULL;
3103                 mg->mg_len = -1;
3104             }
3105         }
3106     }
3107     if (mg && mg->mg_ptr) {
3108         *nxp = mg->mg_len;
3109         return mg->mg_ptr + sizeof(collation_ix);
3110     }
3111     else {
3112         *nxp = 0;
3113         return NULL;
3114     }
3115 }
3116
3117 #endif /* USE_LOCALE_COLLATE */
3118
3119 char *
3120 sv_gets(register SV *sv, register PerlIO *fp, I32 append)
3121 {
3122     dTHR;
3123     char *rsptr;
3124     STRLEN rslen;
3125     register STDCHAR rslast;
3126     register STDCHAR *bp;
3127     register I32 cnt;
3128     I32 i;
3129
3130     SV_CHECK_THINKFIRST(sv);
3131     (void)SvUPGRADE(sv, SVt_PV);
3132     SvSCREAM_off(sv);
3133
3134     if (RsSNARF(rs)) {
3135         rsptr = NULL;
3136         rslen = 0;
3137     }
3138     else if (RsPARA(rs)) {
3139         rsptr = "\n\n";
3140         rslen = 2;
3141     }
3142     else
3143         rsptr = SvPV(rs, rslen);
3144     rslast = rslen ? rsptr[rslen - 1] : '\0';
3145
3146     if (RsPARA(rs)) {           /* have to do this both before and after */
3147         do {                    /* to make sure file boundaries work right */
3148             if (PerlIO_eof(fp))
3149                 return 0;
3150             i = PerlIO_getc(fp);
3151             if (i != '\n') {
3152                 if (i == -1)
3153                     return 0;
3154                 PerlIO_ungetc(fp,i);
3155                 break;
3156             }
3157         } while (i != EOF);
3158     }
3159
3160     /* See if we know enough about I/O mechanism to cheat it ! */
3161
3162     /* This used to be #ifdef test - it is made run-time test for ease
3163        of abstracting out stdio interface. One call should be cheap
3164        enough here - and may even be a macro allowing compile
3165        time optimization.
3166      */
3167
3168     if (PerlIO_fast_gets(fp)) {
3169
3170     /*
3171      * We're going to steal some values from the stdio struct
3172      * and put EVERYTHING in the innermost loop into registers.
3173      */
3174     register STDCHAR *ptr;
3175     STRLEN bpx;
3176     I32 shortbuffered;
3177
3178 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3179     /* An ungetc()d char is handled separately from the regular
3180      * buffer, so we getc() it back out and stuff it in the buffer.
3181      */
3182     i = PerlIO_getc(fp);
3183     if (i == EOF) return 0;
3184     *(--((*fp)->_ptr)) = (unsigned char) i;
3185     (*fp)->_cnt++;
3186 #endif
3187
3188     /* Here is some breathtakingly efficient cheating */
3189
3190     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
3191     (void)SvPOK_only(sv);               /* validate pointer */
3192     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3193         if (cnt > 80 && SvLEN(sv) > append) {
3194             shortbuffered = cnt - SvLEN(sv) + append + 1;
3195             cnt -= shortbuffered;
3196         }
3197         else {
3198             shortbuffered = 0;
3199             /* remember that cnt can be negative */
3200             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3201         }
3202     }
3203     else
3204         shortbuffered = 0;
3205     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
3206     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3207     DEBUG_P(PerlIO_printf(Perl_debug_log,
3208         "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3209     DEBUG_P(PerlIO_printf(Perl_debug_log,
3210         "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3211                (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3212                (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3213     for (;;) {
3214       screamer:
3215         if (cnt > 0) {
3216             if (rslen) {
3217                 while (cnt > 0) {                    /* this     |  eat */
3218                     cnt--;
3219                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
3220                         goto thats_all_folks;        /* screams  |  sed :-) */
3221                 }
3222             }
3223             else {
3224                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
3225                 bp += cnt;                           /* screams  |  dust */
3226                 ptr += cnt;                          /* louder   |  sed :-) */
3227                 cnt = 0;
3228             }
3229         }
3230
3231         if (shortbuffered) {            /* oh well, must extend */
3232             cnt = shortbuffered;
3233             shortbuffered = 0;
3234             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3235             SvCUR_set(sv, bpx);
3236             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3237             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3238             continue;
3239         }
3240
3241         DEBUG_P(PerlIO_printf(Perl_debug_log,
3242             "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3243         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3244         DEBUG_P(PerlIO_printf(Perl_debug_log,
3245             "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3246             (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3247             (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3248         /* This used to call 'filbuf' in stdio form, but as that behaves like
3249            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3250            another abstraction.  */
3251         i   = PerlIO_getc(fp);          /* get more characters */
3252         DEBUG_P(PerlIO_printf(Perl_debug_log,
3253             "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3254             (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3255             (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3256         cnt = PerlIO_get_cnt(fp);
3257         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
3258         DEBUG_P(PerlIO_printf(Perl_debug_log,
3259             "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3260
3261         if (i == EOF)                   /* all done for ever? */
3262             goto thats_really_all_folks;
3263
3264         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3265         SvCUR_set(sv, bpx);
3266         SvGROW(sv, bpx + cnt + 2);
3267         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3268
3269         *bp++ = i;                      /* store character from PerlIO_getc */
3270
3271         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
3272             goto thats_all_folks;
3273     }
3274
3275 thats_all_folks:
3276     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3277           memNE((char*)bp - rslen, rsptr, rslen))
3278         goto screamer;                          /* go back to the fray */
3279 thats_really_all_folks:
3280     if (shortbuffered)
3281         cnt += shortbuffered;
3282         DEBUG_P(PerlIO_printf(Perl_debug_log,
3283             "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3284     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
3285     DEBUG_P(PerlIO_printf(Perl_debug_log,
3286         "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3287         (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3288         (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3289     *bp = '\0';
3290     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
3291     DEBUG_P(PerlIO_printf(Perl_debug_log,
3292         "Screamer: done, len=%ld, string=|%.*s|\n",
3293         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3294     }
3295    else
3296     {
3297        /*The big, slow, and stupid way */
3298         STDCHAR buf[8192];
3299
3300 screamer2:
3301         if (rslen) {
3302             register STDCHAR *bpe = buf + sizeof(buf);
3303             bp = buf;
3304             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3305                 ; /* keep reading */
3306             cnt = bp - buf;
3307         }
3308         else {
3309             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3310             /* Accomodate broken VAXC compiler, which applies U8 cast to
3311              * both args of ?: operator, causing EOF to change into 255
3312              */
3313             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3314         }
3315
3316         if (append)
3317             sv_catpvn(sv, (char *) buf, cnt);
3318         else
3319             sv_setpvn(sv, (char *) buf, cnt);
3320
3321         if (i != EOF &&                 /* joy */
3322             (!rslen ||
3323              SvCUR(sv) < rslen ||
3324              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3325         {
3326             append = -1;
3327             /*
3328              * If we're reading from a TTY and we get a short read,
3329              * indicating that the user hit his EOF character, we need
3330              * to notice it now, because if we try to read from the TTY
3331              * again, the EOF condition will disappear.
3332              *
3333              * The comparison of cnt to sizeof(buf) is an optimization
3334              * that prevents unnecessary calls to feof().
3335              *
3336              * - jik 9/25/96
3337              */
3338             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3339                 goto screamer2;
3340         }
3341     }
3342
3343     if (RsPARA(rs)) {           /* have to do this both before and after */
3344         while (i != EOF) {      /* to make sure file boundaries work right */
3345             i = PerlIO_getc(fp);
3346             if (i != '\n') {
3347                 PerlIO_ungetc(fp,i);
3348                 break;
3349             }
3350         }
3351     }
3352
3353 #ifdef WIN32
3354     win32_strip_return(sv);
3355 #endif
3356
3357     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3358 }
3359
3360
3361 void
3362 sv_inc(register SV *sv)
3363 {
3364     register char *d;
3365     int flags;
3366
3367     if (!sv)
3368         return;
3369     if (SvTHINKFIRST(sv)) {
3370         if (SvREADONLY(sv)) {
3371             dTHR;
3372             if (curcop != &compiling)
3373                 croak(no_modify);
3374         }
3375         if (SvROK(sv)) {
3376 #ifdef OVERLOAD
3377           if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
3378 #endif /* OVERLOAD */
3379           sv_unref(sv);
3380         }
3381     }
3382     if (SvGMAGICAL(sv))
3383         mg_get(sv);
3384     flags = SvFLAGS(sv);
3385     if (flags & SVp_NOK) {
3386         (void)SvNOK_only(sv);
3387         SvNVX(sv) += 1.0;
3388         return;
3389     }
3390     if (flags & SVp_IOK) {
3391         if (SvIVX(sv) == IV_MAX)
3392             sv_setnv(sv, (double)IV_MAX + 1.0);
3393         else {
3394             (void)SvIOK_only(sv);
3395             ++SvIVX(sv);
3396         }
3397         return;
3398     }
3399     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3400         if ((flags & SVTYPEMASK) < SVt_PVNV)
3401             sv_upgrade(sv, SVt_NV);
3402         SvNVX(sv) = 1.0;
3403         (void)SvNOK_only(sv);
3404         return;
3405     }
3406     d = SvPVX(sv);
3407     while (isALPHA(*d)) d++;
3408     while (isDIGIT(*d)) d++;
3409     if (*d) {
3410         SET_NUMERIC_STANDARD();
3411         sv_setnv(sv,atof(SvPVX(sv)) + 1.0);  /* punt */
3412         return;
3413     }
3414     d--;
3415     while (d >= SvPVX(sv)) {
3416         if (isDIGIT(*d)) {
3417             if (++*d <= '9')
3418                 return;
3419             *(d--) = '0';
3420         }
3421         else {
3422             ++*d;
3423             if (isALPHA(*d))
3424                 return;
3425             *(d--) -= 'z' - 'a' + 1;
3426         }
3427     }
3428     /* oh,oh, the number grew */
3429     SvGROW(sv, SvCUR(sv) + 2);
3430     SvCUR(sv)++;
3431     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3432         *d = d[-1];
3433     if (isDIGIT(d[1]))
3434         *d = '1';
3435     else
3436         *d = d[1];
3437 }
3438
3439 void
3440 sv_dec(register SV *sv)
3441 {
3442     int flags;
3443
3444     if (!sv)
3445         return;
3446     if (SvTHINKFIRST(sv)) {
3447         if (SvREADONLY(sv)) {
3448             dTHR;
3449             if (curcop != &compiling)
3450                 croak(no_modify);
3451         }
3452         if (SvROK(sv)) {
3453 #ifdef OVERLOAD
3454           if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
3455 #endif /* OVERLOAD */
3456           sv_unref(sv);
3457         }
3458     }
3459     if (SvGMAGICAL(sv))
3460         mg_get(sv);
3461     flags = SvFLAGS(sv);
3462     if (flags & SVp_NOK) {
3463         SvNVX(sv) -= 1.0;
3464         (void)SvNOK_only(sv);
3465         return;
3466     }
3467     if (flags & SVp_IOK) {
3468         if (SvIVX(sv) == IV_MIN)
3469             sv_setnv(sv, (double)IV_MIN - 1.0);
3470         else {
3471             (void)SvIOK_only(sv);
3472             --SvIVX(sv);
3473         }
3474         return;
3475     }
3476     if (!(flags & SVp_POK)) {
3477         if ((flags & SVTYPEMASK) < SVt_PVNV)
3478             sv_upgrade(sv, SVt_NV);
3479         SvNVX(sv) = -1.0;
3480         (void)SvNOK_only(sv);
3481         return;
3482     }
3483     SET_NUMERIC_STANDARD();
3484     sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
3485 }
3486
3487 /* Make a string that will exist for the duration of the expression
3488  * evaluation.  Actually, it may have to last longer than that, but
3489  * hopefully we won't free it until it has been assigned to a
3490  * permanent location. */
3491
3492 STATIC void
3493 sv_mortalgrow(void)
3494 {
3495     dTHR;
3496     tmps_max += (tmps_max < 512) ? 128 : 512;
3497     Renew(tmps_stack, tmps_max, SV*);
3498 }
3499
3500 SV *
3501 sv_mortalcopy(SV *oldstr)
3502 {
3503     dTHR;
3504     register SV *sv;
3505
3506     new_SV(sv);
3507     SvANY(sv) = 0;
3508     SvREFCNT(sv) = 1;
3509     SvFLAGS(sv) = 0;
3510     sv_setsv(sv,oldstr);
3511     if (++tmps_ix >= tmps_max)
3512         sv_mortalgrow();
3513     tmps_stack[tmps_ix] = sv;
3514     SvTEMP_on(sv);
3515     return sv;
3516 }
3517
3518 SV *
3519 sv_newmortal(void)
3520 {
3521     dTHR;
3522     register SV *sv;
3523
3524     new_SV(sv);
3525     SvANY(sv) = 0;
3526     SvREFCNT(sv) = 1;
3527     SvFLAGS(sv) = SVs_TEMP;
3528     if (++tmps_ix >= tmps_max)
3529         sv_mortalgrow();
3530     tmps_stack[tmps_ix] = sv;
3531     return sv;
3532 }
3533
3534 /* same thing without the copying */
3535
3536 SV *
3537 sv_2mortal(register SV *sv)
3538 {
3539     dTHR;
3540     if (!sv)
3541         return sv;
3542     if (SvREADONLY(sv) && curcop != &compiling)
3543         croak(no_modify);
3544     if (++tmps_ix >= tmps_max)
3545         sv_mortalgrow();
3546     tmps_stack[tmps_ix] = sv;
3547     SvTEMP_on(sv);
3548     return sv;
3549 }
3550
3551 SV *
3552 newSVpv(char *s, STRLEN len)
3553 {
3554     register SV *sv;
3555
3556     new_SV(sv);
3557     SvANY(sv) = 0;
3558     SvREFCNT(sv) = 1;
3559     SvFLAGS(sv) = 0;
3560     if (!len)
3561         len = strlen(s);
3562     sv_setpvn(sv,s,len);
3563     return sv;
3564 }
3565
3566 SV *
3567 newSVpvn(char *s, STRLEN len)
3568 {
3569     register SV *sv;
3570
3571     new_SV(sv);
3572     SvANY(sv) = 0;
3573     SvREFCNT(sv) = 1;
3574     SvFLAGS(sv) = 0;
3575     sv_setpvn(sv,s,len);
3576     return sv;
3577 }
3578
3579 #ifdef I_STDARG
3580 SV *
3581 newSVpvf(const char* pat, ...)
3582 #else
3583 /*VARARGS0*/
3584 SV *
3585 newSVpvf(pat, va_alist)
3586 const char *pat;
3587 va_dcl
3588 #endif
3589 {
3590     register SV *sv;
3591     va_list args;
3592
3593     new_SV(sv);
3594     SvANY(sv) = 0;
3595     SvREFCNT(sv) = 1;
3596     SvFLAGS(sv) = 0;
3597 #ifdef I_STDARG
3598     va_start(args, pat);
3599 #else
3600     va_start(args);
3601 #endif
3602     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3603     va_end(args);
3604     return sv;
3605 }
3606
3607
3608 SV *
3609 newSVnv(double n)
3610 {
3611     register SV *sv;
3612
3613     new_SV(sv);
3614     SvANY(sv) = 0;
3615     SvREFCNT(sv) = 1;
3616     SvFLAGS(sv) = 0;
3617     sv_setnv(sv,n);
3618     return sv;
3619 }
3620
3621 SV *
3622 newSViv(IV i)
3623 {
3624     register SV *sv;
3625
3626     new_SV(sv);
3627     SvANY(sv) = 0;
3628     SvREFCNT(sv) = 1;
3629     SvFLAGS(sv) = 0;
3630     sv_setiv(sv,i);
3631     return sv;
3632 }
3633
3634 SV *
3635 newRV(SV *tmpRef)
3636 {
3637     dTHR;
3638     register SV *sv;
3639
3640     new_SV(sv);
3641     SvANY(sv) = 0;
3642     SvREFCNT(sv) = 1;
3643     SvFLAGS(sv) = 0;
3644     sv_upgrade(sv, SVt_RV);
3645     SvTEMP_off(tmpRef);
3646     SvRV(sv) = SvREFCNT_inc(tmpRef);
3647     SvROK_on(sv);
3648     return sv;
3649 }
3650
3651
3652
3653 SV *
3654 Perl_newRV_noinc(SV *tmpRef)
3655 {
3656     register SV *sv;
3657
3658     sv = newRV(tmpRef);
3659     SvREFCNT_dec(tmpRef);
3660     return sv;
3661 }
3662
3663 /* make an exact duplicate of old */
3664
3665 SV *
3666 newSVsv(register SV *old)
3667 {
3668     register SV *sv;
3669
3670     if (!old)
3671         return Nullsv;
3672     if (SvTYPE(old) == SVTYPEMASK) {
3673         warn("semi-panic: attempt to dup freed string");
3674         return Nullsv;
3675     }
3676     new_SV(sv);
3677     SvANY(sv) = 0;
3678     SvREFCNT(sv) = 1;
3679     SvFLAGS(sv) = 0;
3680     if (SvTEMP(old)) {
3681         SvTEMP_off(old);
3682         sv_setsv(sv,old);
3683         SvTEMP_on(old);
3684     }
3685     else
3686         sv_setsv(sv,old);
3687     return sv;
3688 }
3689
3690 void
3691 sv_reset(register char *s, HV *stash)
3692 {
3693     register HE *entry;
3694     register GV *gv;
3695     register SV *sv;
3696     register I32 i;
3697     register PMOP *pm;
3698     register I32 max;
3699     char todo[256];
3700
3701     if (!stash)
3702         return;
3703
3704     if (!*s) {          /* reset ?? searches */
3705         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
3706             pm->op_pmflags &= ~PMf_USED;
3707         }
3708         return;
3709     }
3710
3711     /* reset variables */
3712
3713     if (!HvARRAY(stash))
3714         return;
3715
3716     Zero(todo, 256, char);
3717     while (*s) {
3718         i = *s;
3719         if (s[1] == '-') {
3720             s += 2;
3721         }
3722         max = *s++;
3723         for ( ; i <= max; i++) {
3724             todo[i] = 1;
3725         }
3726         for (i = 0; i <= (I32) HvMAX(stash); i++) {
3727             for (entry = HvARRAY(stash)[i];
3728               entry;
3729               entry = HeNEXT(entry)) {
3730                 if (!todo[(U8)*HeKEY(entry)])
3731                     continue;
3732                 gv = (GV*)HeVAL(entry);
3733                 sv = GvSV(gv);
3734                 (void)SvOK_off(sv);
3735                 if (SvTYPE(sv) >= SVt_PV) {
3736                     SvCUR_set(sv, 0);
3737                     if (SvPVX(sv) != Nullch)
3738                         *SvPVX(sv) = '\0';
3739                     SvTAINT(sv);
3740                 }
3741                 if (GvAV(gv)) {
3742                     av_clear(GvAV(gv));
3743                 }
3744                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
3745                     hv_clear(GvHV(gv));
3746 #ifndef VMS  /* VMS has no environ array */
3747                     if (gv == envgv)
3748                         environ[0] = Nullch;
3749 #endif
3750                 }
3751             }
3752         }
3753     }
3754 }
3755
3756 IO*
3757 sv_2io(SV *sv)
3758 {
3759     IO* io;
3760     GV* gv;
3761
3762     switch (SvTYPE(sv)) {
3763     case SVt_PVIO:
3764         io = (IO*)sv;
3765         break;
3766     case SVt_PVGV:
3767         gv = (GV*)sv;
3768         io = GvIO(gv);
3769         if (!io)
3770             croak("Bad filehandle: %s", GvNAME(gv));
3771         break;
3772     default:
3773         if (!SvOK(sv))
3774             croak(no_usym, "filehandle");
3775         if (SvROK(sv))
3776             return sv_2io(SvRV(sv));
3777         gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO);
3778         if (gv)
3779             io = GvIO(gv);
3780         else
3781             io = 0;
3782         if (!io)
3783             croak("Bad filehandle: %s", SvPV(sv,na));
3784         break;
3785     }
3786     return io;
3787 }
3788
3789 CV *
3790 sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref)
3791 {
3792     GV *gv;
3793     CV *cv;
3794
3795     if (!sv)
3796         return *gvp = Nullgv, Nullcv;
3797     switch (SvTYPE(sv)) {
3798     case SVt_PVCV:
3799         *st = CvSTASH(sv);
3800         *gvp = Nullgv;
3801         return (CV*)sv;
3802     case SVt_PVHV:
3803     case SVt_PVAV:
3804         *gvp = Nullgv;
3805         return Nullcv;
3806     case SVt_PVGV:
3807         gv = (GV*)sv;
3808         *gvp = gv;
3809         *st = GvESTASH(gv);
3810         goto fix_gv;
3811
3812     default:
3813         if (SvGMAGICAL(sv))
3814             mg_get(sv);
3815         if (SvROK(sv)) {
3816             cv = (CV*)SvRV(sv);
3817             if (SvTYPE(cv) != SVt_PVCV)
3818                 croak("Not a subroutine reference");
3819             *gvp = Nullgv;
3820             *st = CvSTASH(cv);
3821             return cv;
3822         }
3823         if (isGV(sv))
3824             gv = (GV*)sv;
3825         else
3826             gv = gv_fetchpv(SvPV(sv, na), lref, SVt_PVCV);
3827         *gvp = gv;
3828         if (!gv)
3829             return Nullcv;
3830         *st = GvESTASH(gv);
3831     fix_gv:
3832         if (lref && !GvCVu(gv)) {
3833             SV *tmpsv;
3834             ENTER;
3835             tmpsv = NEWSV(704,0);
3836             gv_efullname3(tmpsv, gv, Nullch);
3837             newSUB(start_subparse(FALSE, 0),
3838                    newSVOP(OP_CONST, 0, tmpsv),
3839                    Nullop,
3840                    Nullop);
3841             LEAVE;
3842             if (!GvCVu(gv))
3843                 croak("Unable to create sub named \"%s\"", SvPV(sv,na));
3844         }
3845         return GvCVu(gv);
3846     }
3847 }
3848
3849 I32
3850 sv_true(register SV *sv)
3851 {
3852     dTHR;
3853     if (!sv)
3854         return 0;
3855     if (SvPOK(sv)) {
3856         register XPV* tXpv;
3857         if ((tXpv = (XPV*)SvANY(sv)) &&
3858                 (*tXpv->xpv_pv > '0' ||
3859                 tXpv->xpv_cur > 1 ||
3860                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
3861             return 1;
3862         else
3863             return 0;
3864     }
3865     else {
3866         if (SvIOK(sv))
3867             return SvIVX(sv) != 0;
3868         else {
3869             if (SvNOK(sv))
3870                 return SvNVX(sv) != 0.0;
3871             else
3872                 return sv_2bool(sv);
3873         }
3874     }
3875 }
3876
3877 IV
3878 sv_iv(register SV *sv)
3879 {
3880     if (SvIOK(sv))
3881         return SvIVX(sv);
3882     return sv_2iv(sv);
3883 }
3884
3885 UV
3886 sv_uv(register SV *sv)
3887 {
3888     if (SvIOK(sv))
3889         return SvUVX(sv);
3890     return sv_2uv(sv);
3891 }
3892
3893 double
3894 sv_nv(register SV *sv)
3895 {
3896     if (SvNOK(sv))
3897         return SvNVX(sv);
3898     return sv_2nv(sv);
3899 }
3900
3901 char *
3902 sv_pvn(SV *sv, STRLEN *lp)
3903 {
3904     if (SvPOK(sv)) {
3905         *lp = SvCUR(sv);
3906         return SvPVX(sv);
3907     }
3908     return sv_2pv(sv, lp);
3909 }
3910
3911 char *
3912 sv_pvn_force(SV *sv, STRLEN *lp)
3913 {
3914     char *s;
3915
3916     if (SvREADONLY(sv)) {
3917         dTHR;
3918         if (curcop != &compiling)
3919             croak(no_modify);
3920     }
3921
3922     if (SvPOK(sv)) {
3923         *lp = SvCUR(sv);
3924     }
3925     else {
3926         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
3927             if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) {
3928                 sv_unglob(sv);
3929                 s = SvPVX(sv);
3930                 *lp = SvCUR(sv);
3931             }
3932             else {
3933                 dTHR;
3934                 croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
3935                     op_name[op->op_type]);
3936             }
3937         }
3938         else
3939             s = sv_2pv(sv, lp);
3940         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
3941             STRLEN len = *lp;
3942
3943             if (SvROK(sv))
3944                 sv_unref(sv);
3945             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
3946             SvGROW(sv, len + 1);
3947             Move(s,SvPVX(sv),len,char);
3948             SvCUR_set(sv, len);
3949             *SvEND(sv) = '\0';
3950         }
3951         if (!SvPOK(sv)) {
3952             SvPOK_on(sv);               /* validate pointer */
3953             SvTAINT(sv);
3954             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
3955                 (unsigned long)sv,SvPVX(sv)));
3956         }
3957     }
3958     return SvPVX(sv);
3959 }
3960
3961 char *
3962 sv_reftype(SV *sv, int ob)
3963 {
3964     if (ob && SvOBJECT(sv))
3965         return HvNAME(SvSTASH(sv));
3966     else {
3967         switch (SvTYPE(sv)) {
3968         case SVt_NULL:
3969         case SVt_IV:
3970         case SVt_NV:
3971         case SVt_RV:
3972         case SVt_PV:
3973         case SVt_PVIV:
3974         case SVt_PVNV:
3975         case SVt_PVMG:
3976         case SVt_PVBM:
3977                                 if (SvROK(sv))
3978                                     return "REF";
3979                                 else
3980                                     return "SCALAR";
3981         case SVt_PVLV:          return "LVALUE";
3982         case SVt_PVAV:          return "ARRAY";
3983         case SVt_PVHV:          return "HASH";
3984         case SVt_PVCV:          return "CODE";
3985         case SVt_PVGV:          return "GLOB";
3986         case SVt_PVFM:          return "FORMLINE";
3987         default:                return "UNKNOWN";
3988         }
3989     }
3990 }
3991
3992 int
3993 sv_isobject(SV *sv)
3994 {
3995     if (!sv)
3996         return 0;
3997     if (SvGMAGICAL(sv))
3998         mg_get(sv);
3999     if (!SvROK(sv))
4000         return 0;
4001     sv = (SV*)SvRV(sv);
4002     if (!SvOBJECT(sv))
4003         return 0;
4004     return 1;
4005 }
4006
4007 int
4008 sv_isa(SV *sv, char *name)
4009 {
4010     if (!sv)
4011         return 0;
4012     if (SvGMAGICAL(sv))
4013         mg_get(sv);
4014     if (!SvROK(sv))
4015         return 0;
4016     sv = (SV*)SvRV(sv);
4017     if (!SvOBJECT(sv))
4018         return 0;
4019
4020     return strEQ(HvNAME(SvSTASH(sv)), name);
4021 }
4022
4023 SV*
4024 newSVrv(SV *rv, char *classname)
4025 {
4026     dTHR;
4027     SV *sv;
4028
4029     new_SV(sv);
4030     SvANY(sv) = 0;
4031     SvREFCNT(sv) = 0;
4032     SvFLAGS(sv) = 0;
4033
4034     SV_CHECK_THINKFIRST(rv);
4035 #ifdef OVERLOAD
4036     SvAMAGIC_off(rv);
4037 #endif /* OVERLOAD */
4038
4039     if (SvTYPE(rv) < SVt_RV)
4040       sv_upgrade(rv, SVt_RV);
4041
4042     (void)SvOK_off(rv);
4043     SvRV(rv) = SvREFCNT_inc(sv);
4044     SvROK_on(rv);
4045
4046     if (classname) {
4047         HV* stash = gv_stashpv(classname, TRUE);
4048         (void)sv_bless(rv, stash);
4049     }
4050     return sv;
4051 }
4052
4053 SV*
4054 sv_setref_pv(SV *rv, char *classname, void *pv)
4055 {
4056     if (!pv) {
4057         sv_setsv(rv, &sv_undef);
4058         SvSETMAGIC(rv);
4059     }
4060     else
4061         sv_setiv(newSVrv(rv,classname), (IV)pv);
4062     return rv;
4063 }
4064
4065 SV*
4066 sv_setref_iv(SV *rv, char *classname, IV iv)
4067 {
4068     sv_setiv(newSVrv(rv,classname), iv);
4069     return rv;
4070 }
4071
4072 SV*
4073 sv_setref_nv(SV *rv, char *classname, double nv)
4074 {
4075     sv_setnv(newSVrv(rv,classname), nv);
4076     return rv;
4077 }
4078
4079 SV*
4080 sv_setref_pvn(SV *rv, char *classname, char *pv, I32 n)
4081 {
4082     sv_setpvn(newSVrv(rv,classname), pv, n);
4083     return rv;
4084 }
4085
4086 SV*
4087 sv_bless(SV *sv, HV *stash)
4088 {
4089     dTHR;
4090     SV *tmpRef;
4091     if (!SvROK(sv))
4092         croak("Can't bless non-reference value");
4093     tmpRef = SvRV(sv);
4094     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4095         if (SvREADONLY(tmpRef))
4096             croak(no_modify);
4097         if (SvOBJECT(tmpRef)) {
4098             if (SvTYPE(tmpRef) != SVt_PVIO)
4099                 --sv_objcount;
4100             SvREFCNT_dec(SvSTASH(tmpRef));
4101         }
4102     }
4103     SvOBJECT_on(tmpRef);
4104     if (SvTYPE(tmpRef) != SVt_PVIO)
4105         ++sv_objcount;
4106     (void)SvUPGRADE(tmpRef, SVt_PVMG);
4107     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4108
4109 #ifdef OVERLOAD
4110     if (Gv_AMG(stash))
4111         SvAMAGIC_on(sv);
4112     else
4113         SvAMAGIC_off(sv);
4114 #endif /* OVERLOAD */
4115
4116     return sv;
4117 }
4118
4119 STATIC void
4120 sv_unglob(SV *sv)
4121 {
4122     assert(SvTYPE(sv) == SVt_PVGV);
4123     SvFAKE_off(sv);
4124     if (GvGP(sv))
4125         gp_free((GV*)sv);
4126     if (GvSTASH(sv)) {
4127         SvREFCNT_dec(GvSTASH(sv));
4128         GvSTASH(sv) = Nullhv;
4129     }
4130     sv_unmagic(sv, '*');
4131     Safefree(GvNAME(sv));
4132     GvMULTI_off(sv);
4133     SvFLAGS(sv) &= ~SVTYPEMASK;
4134     SvFLAGS(sv) |= SVt_PVMG;
4135 }
4136
4137 void
4138 sv_unref(SV *sv)
4139 {
4140     SV* rv = SvRV(sv);
4141
4142     SvRV(sv) = 0;
4143     SvROK_off(sv);
4144     if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4145         SvREFCNT_dec(rv);
4146     else
4147         sv_2mortal(rv);         /* Schedule for freeing later */
4148 }
4149
4150 void
4151 sv_taint(SV *sv)
4152 {
4153     sv_magic((sv), Nullsv, 't', Nullch, 0);
4154 }
4155
4156 void
4157 sv_untaint(SV *sv)
4158 {
4159     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4160         MAGIC *mg = mg_find(sv, 't');
4161         if (mg)
4162             mg->mg_len &= ~1;
4163     }
4164 }
4165
4166 bool
4167 sv_tainted(SV *sv)
4168 {
4169     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4170         MAGIC *mg = mg_find(sv, 't');
4171         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4172             return TRUE;
4173     }
4174     return FALSE;
4175 }
4176
4177 void
4178 sv_setpviv(SV *sv, IV iv)
4179 {
4180     STRLEN len;
4181     char buf[TYPE_DIGITS(UV)];
4182     char *ptr = buf + sizeof(buf);
4183     int sign;
4184     UV uv;
4185     char *p;
4186
4187     sv_setpvn(sv, "", 0);
4188     if (iv >= 0) {
4189         uv = iv;
4190         sign = 0;
4191     } else {
4192         uv = -iv;
4193         sign = 1;
4194     }
4195     do {
4196         *--ptr = '0' + (uv % 10);
4197     } while (uv /= 10);
4198     len = (buf + sizeof(buf)) - ptr;
4199     /* taking advantage of SvCUR(sv) == 0 */
4200     SvGROW(sv, sign + len + 1);
4201     p = SvPVX(sv);
4202     if (sign)
4203         *p++ = '-';
4204     memcpy(p, ptr, len);
4205     p += len;
4206     *p = '\0';
4207     SvCUR(sv) = p - SvPVX(sv);
4208 }
4209
4210
4211 void
4212 sv_setpviv_mg(SV *sv, IV iv)
4213 {
4214     sv_setpviv(sv,iv);
4215     SvSETMAGIC(sv);
4216 }
4217
4218 #ifdef I_STDARG
4219 void
4220 sv_setpvf(SV *sv, const char* pat, ...)
4221 #else
4222 /*VARARGS0*/
4223 void
4224 sv_setpvf(sv, pat, va_alist)
4225     SV *sv;
4226     const char *pat;
4227     va_dcl
4228 #endif
4229 {
4230     va_list args;
4231 #ifdef I_STDARG
4232     va_start(args, pat);
4233 #else
4234     va_start(args);
4235 #endif
4236     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4237     va_end(args);
4238 }
4239
4240
4241 #ifdef I_STDARG
4242 void
4243 sv_setpvf_mg(SV *sv, const char* pat, ...)
4244 #else
4245 /*VARARGS0*/
4246 void
4247 sv_setpvf_mg(sv, pat, va_alist)
4248     SV *sv;
4249     const char *pat;
4250     va_dcl
4251 #endif
4252 {
4253     va_list args;
4254 #ifdef I_STDARG
4255     va_start(args, pat);
4256 #else
4257     va_start(args);
4258 #endif
4259     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4260     va_end(args);
4261     SvSETMAGIC(sv);
4262 }
4263
4264 #ifdef I_STDARG
4265 void
4266 sv_catpvf(SV *sv, const char* pat, ...)
4267 #else
4268 /*VARARGS0*/
4269 void
4270 sv_catpvf(sv, pat, va_alist)
4271     SV *sv;
4272     const char *pat;
4273     va_dcl
4274 #endif
4275 {
4276     va_list args;
4277 #ifdef I_STDARG
4278     va_start(args, pat);
4279 #else
4280     va_start(args);
4281 #endif
4282     sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4283     va_end(args);
4284 }
4285
4286 #ifdef I_STDARG
4287 void
4288 sv_catpvf_mg(SV *sv, const char* pat, ...)
4289 #else
4290 /*VARARGS0*/
4291 void
4292 sv_catpvf_mg(sv, pat, va_alist)
4293     SV *sv;
4294     const char *pat;
4295     va_dcl
4296 #endif
4297 {
4298     va_list args;
4299 #ifdef I_STDARG
4300     va_start(args, pat);
4301 #else
4302     va_start(args);
4303 #endif
4304     sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4305     va_end(args);
4306     SvSETMAGIC(sv);
4307 }
4308
4309 void
4310 sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4311 {
4312     sv_setpvn(sv, "", 0);
4313     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4314 }
4315
4316 void
4317 sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4318 {
4319     dTHR;
4320     char *p;
4321     char *q;
4322     char *patend;
4323     STRLEN origlen;
4324     I32 svix = 0;
4325     static char nullstr[] = "(null)";
4326
4327     /* no matter what, this is a string now */
4328     (void)SvPV_force(sv, origlen);
4329
4330     /* special-case "", "%s", and "%_" */
4331     if (patlen == 0)
4332         return;
4333     if (patlen == 2 && pat[0] == '%') {
4334         switch (pat[1]) {
4335         case 's':
4336             if (args) {
4337                 char *s = va_arg(*args, char*);
4338                 sv_catpv(sv, s ? s : nullstr);
4339             }
4340             else if (svix < svmax)
4341                 sv_catsv(sv, *svargs);
4342             return;
4343         case '_':
4344             if (args) {
4345                 sv_catsv(sv, va_arg(*args, SV*));
4346                 return;
4347             }
4348             /* See comment on '_' below */
4349             break;
4350         }
4351     }
4352
4353     patend = (char*)pat + patlen;
4354     for (p = (char*)pat; p < patend; p = q) {
4355         bool alt = FALSE;
4356         bool left = FALSE;
4357         char fill = ' ';
4358         char plus = 0;
4359         char intsize = 0;
4360         STRLEN width = 0;
4361         STRLEN zeros = 0;
4362         bool has_precis = FALSE;
4363         STRLEN precis = 0;
4364
4365         char esignbuf[4];
4366         STRLEN esignlen = 0;
4367
4368         char *eptr = Nullch;
4369         STRLEN elen = 0;
4370         char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4371
4372         static char *efloatbuf = Nullch;
4373         static STRLEN efloatsize = 0;
4374
4375         char c;
4376         int i;
4377         unsigned base;
4378         IV iv;
4379         UV uv;
4380         double nv;
4381         STRLEN have;
4382         STRLEN need;
4383         STRLEN gap;
4384
4385         for (q = p; q < patend && *q != '%'; ++q) ;
4386         if (q > p) {
4387             sv_catpvn(sv, p, q - p);
4388             p = q;
4389         }
4390         if (q++ >= patend)
4391             break;
4392
4393         /* FLAGS */
4394
4395         while (*q) {
4396             switch (*q) {
4397             case ' ':
4398             case '+':
4399                 plus = *q++;
4400                 continue;
4401
4402             case '-':
4403                 left = TRUE;
4404                 q++;
4405                 continue;
4406
4407             case '0':
4408                 fill = *q++;
4409                 continue;
4410
4411             case '#':
4412                 alt = TRUE;
4413                 q++;
4414                 continue;
4415
4416             default:
4417                 break;
4418             }
4419             break;
4420         }
4421
4422         /* WIDTH */
4423
4424         switch (*q) {
4425         case '1': case '2': case '3':
4426         case '4': case '5': case '6':
4427         case '7': case '8': case '9':
4428             width = 0;
4429             while (isDIGIT(*q))
4430                 width = width * 10 + (*q++ - '0');
4431             break;
4432
4433         case '*':
4434             if (args)
4435                 i = va_arg(*args, int);
4436             else
4437                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4438             left |= (i < 0);
4439             width = (i < 0) ? -i : i;
4440             q++;
4441             break;
4442         }
4443
4444         /* PRECISION */
4445
4446         if (*q == '.') {
4447             q++;
4448             if (*q == '*') {
4449                 if (args)
4450                     i = va_arg(*args, int);
4451                 else
4452                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4453                 precis = (i < 0) ? 0 : i;
4454                 q++;
4455             }
4456             else {
4457                 precis = 0;
4458                 while (isDIGIT(*q))
4459                     precis = precis * 10 + (*q++ - '0');
4460             }
4461             has_precis = TRUE;
4462         }
4463
4464         /* SIZE */
4465
4466         switch (*q) {
4467         case 'l':
4468 #if 0  /* when quads have better support within Perl */
4469             if (*(q + 1) == 'l') {
4470                 intsize = 'q';
4471                 q += 2;
4472                 break;
4473             }
4474 #endif
4475             /* FALL THROUGH */
4476         case 'h':
4477         case 'V':
4478             intsize = *q++;
4479             break;
4480         }
4481
4482         /* CONVERSION */
4483
4484         switch (c = *q++) {
4485
4486             /* STRINGS */
4487
4488         case '%':
4489             eptr = q - 1;
4490             elen = 1;
4491             goto string;
4492
4493         case 'c':
4494             if (args)
4495                 c = va_arg(*args, int);
4496             else
4497                 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4498             eptr = &c;
4499             elen = 1;
4500             goto string;
4501
4502         case 's':
4503             if (args) {
4504                 eptr = va_arg(*args, char*);
4505                 if (eptr)
4506                     elen = strlen(eptr);
4507                 else {
4508                     eptr = nullstr;
4509                     elen = sizeof nullstr - 1;
4510                 }
4511             }
4512             else if (svix < svmax)
4513                 eptr = SvPVx(svargs[svix++], elen);
4514             goto string;
4515
4516         case '_':
4517             /*
4518              * The "%_" hack might have to be changed someday,
4519              * if ISO or ANSI decide to use '_' for something.
4520              * So we keep it hidden from users' code.
4521              */
4522             if (!args)
4523                 goto unknown;
4524             eptr = SvPVx(va_arg(*args, SV*), elen);
4525
4526         string:
4527             if (has_precis && elen > precis)
4528                 elen = precis;
4529             break;
4530
4531             /* INTEGERS */
4532
4533         case 'p':
4534             if (args)
4535                 uv = (UV)va_arg(*args, void*);
4536             else
4537                 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4538             base = 16;
4539             goto integer;
4540
4541         case 'D':
4542             intsize = 'l';
4543             /* FALL THROUGH */
4544         case 'd':
4545         case 'i':
4546             if (args) {
4547                 switch (intsize) {
4548                 case 'h':       iv = (short)va_arg(*args, int); break;
4549                 default:        iv = va_arg(*args, int); break;
4550                 case 'l':       iv = va_arg(*args, long); break;
4551                 case 'V':       iv = va_arg(*args, IV); break;
4552                 }
4553             }
4554             else {
4555                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4556                 switch (intsize) {
4557                 case 'h':       iv = (short)iv; break;
4558                 default:        iv = (int)iv; break;
4559                 case 'l':       iv = (long)iv; break;
4560                 case 'V':       break;
4561                 }
4562             }
4563             if (iv >= 0) {
4564                 uv = iv;
4565                 if (plus)
4566                     esignbuf[esignlen++] = plus;
4567             }
4568             else {
4569                 uv = -iv;
4570                 esignbuf[esignlen++] = '-';
4571             }
4572             base = 10;
4573             goto integer;
4574
4575         case 'U':
4576             intsize = 'l';
4577             /* FALL THROUGH */
4578         case 'u':
4579             base = 10;
4580             goto uns_integer;
4581
4582         case 'O':
4583             intsize = 'l';
4584             /* FALL THROUGH */
4585         case 'o':
4586             base = 8;
4587             goto uns_integer;
4588
4589         case 'X':
4590         case 'x':
4591             base = 16;
4592
4593         uns_integer:
4594             if (args) {
4595                 switch (intsize) {
4596                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
4597                 default:   uv = va_arg(*args, unsigned); break;
4598                 case 'l':  uv = va_arg(*args, unsigned long); break;
4599                 case 'V':  uv = va_arg(*args, UV); break;
4600                 }
4601             }
4602             else {
4603                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4604                 switch (intsize) {
4605                 case 'h':       uv = (unsigned short)uv; break;
4606                 default:        uv = (unsigned)uv; break;
4607                 case 'l':       uv = (unsigned long)uv; break;
4608                 case 'V':       break;
4609                 }
4610             }
4611
4612         integer:
4613             eptr = ebuf + sizeof ebuf;
4614             switch (base) {
4615                 unsigned dig;
4616             case 16:
4617                 if (!uv)
4618                     alt = FALSE;
4619                 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4620                 do {
4621                     dig = uv & 15;
4622                     *--eptr = p[dig];
4623                 } while (uv >>= 4);
4624                 if (alt) {
4625                     esignbuf[esignlen++] = '0';
4626                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
4627                 }
4628                 break;
4629             case 8:
4630                 do {
4631                     dig = uv & 7;
4632                     *--eptr = '0' + dig;
4633                 } while (uv >>= 3);
4634                 if (alt && *eptr != '0')
4635                     *--eptr = '0';
4636                 break;
4637             default:            /* it had better be ten or less */
4638                 do {
4639                     dig = uv % base;
4640                     *--eptr = '0' + dig;
4641                 } while (uv /= base);
4642                 break;
4643             }
4644             elen = (ebuf + sizeof ebuf) - eptr;
4645             if (has_precis) {
4646                 if (precis > elen)
4647                     zeros = precis - elen;
4648                 else if (precis == 0 && elen == 1 && *eptr == '0')
4649                     elen = 0;
4650             }
4651             break;
4652
4653             /* FLOATING POINT */
4654
4655         case 'F':
4656             c = 'f';            /* maybe %F isn't supported here */
4657             /* FALL THROUGH */
4658         case 'e': case 'E':
4659         case 'f':
4660         case 'g': case 'G':
4661
4662             /* This is evil, but floating point is even more evil */
4663
4664             if (args)
4665                 nv = va_arg(*args, double);
4666             else
4667                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
4668
4669             need = 0;
4670             if (c != 'e' && c != 'E') {
4671                 i = PERL_INT_MIN;
4672                 (void)frexp(nv, &i);
4673                 if (i == PERL_INT_MIN)
4674                     die("panic: frexp");
4675                 if (i > 0)
4676                     need = BIT_DIGITS(i);
4677             }
4678             need += has_precis ? precis : 6; /* known default */
4679             if (need < width)
4680                 need = width;
4681
4682             need += 20; /* fudge factor */
4683             if (efloatsize < need) {
4684                 Safefree(efloatbuf);
4685                 efloatsize = need + 20; /* more fudge */
4686                 New(906, efloatbuf, efloatsize, char);
4687             }
4688
4689             eptr = ebuf + sizeof ebuf;
4690             *--eptr = '\0';
4691             *--eptr = c;
4692             if (has_precis) {
4693                 base = precis;
4694                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
4695                 *--eptr = '.';
4696             }
4697             if (width) {
4698                 base = width;
4699                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
4700             }
4701             if (fill == '0')
4702                 *--eptr = fill;
4703             if (left)
4704                 *--eptr = '-';
4705             if (plus)
4706                 *--eptr = plus;
4707             if (alt)
4708                 *--eptr = '#';
4709             *--eptr = '%';
4710
4711             (void)sprintf(efloatbuf, eptr, nv);
4712
4713             eptr = efloatbuf;
4714             elen = strlen(efloatbuf);
4715
4716 #ifdef LC_NUMERIC
4717             /*
4718              * User-defined locales may include arbitrary characters.
4719              * And, unfortunately, some system may alloc the "C" locale
4720              * to be overridden by a malicious user.
4721              */
4722             if (used_locale)
4723                 *used_locale = TRUE;
4724 #endif /* LC_NUMERIC */
4725
4726             break;
4727
4728             /* SPECIAL */
4729
4730         case 'n':
4731             i = SvCUR(sv) - origlen;
4732             if (args) {
4733                 switch (intsize) {
4734                 case 'h':       *(va_arg(*args, short*)) = i; break;
4735                 default:        *(va_arg(*args, int*)) = i; break;
4736                 case 'l':       *(va_arg(*args, long*)) = i; break;
4737                 case 'V':       *(va_arg(*args, IV*)) = i; break;
4738                 }
4739             }
4740             else if (svix < svmax)
4741                 sv_setuv(svargs[svix++], (UV)i);
4742             continue;   /* not "break" */
4743
4744             /* UNKNOWN */
4745
4746         default:
4747       unknown:
4748             if (!args && dowarn &&
4749                   (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) {
4750                 SV *msg = sv_newmortal();
4751                 sv_setpvf(msg, "Invalid conversion in %s: ",
4752                           (op->op_type == OP_PRTF) ? "printf" : "sprintf");
4753                 if (c)
4754                     sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
4755                               c & 0xFF);
4756                 else
4757                     sv_catpv(msg, "end of string");
4758                 warn("%_", msg); /* yes, this is reentrant */
4759             }
4760
4761             /* output mangled stuff ... */
4762             if (c == '\0')
4763                 --q;
4764             eptr = p;
4765             elen = q - p;
4766
4767             /* ... right here, because formatting flags should not apply */
4768             SvGROW(sv, SvCUR(sv) + elen + 1);
4769             p = SvEND(sv);
4770             memcpy(p, eptr, elen);
4771             p += elen;
4772             *p = '\0';
4773             SvCUR(sv) = p - SvPVX(sv);
4774             continue;   /* not "break" */
4775         }
4776
4777         have = esignlen + zeros + elen;
4778         need = (have > width ? have : width);
4779         gap = need - have;
4780
4781         SvGROW(sv, SvCUR(sv) + need + 1);
4782         p = SvEND(sv);
4783         if (esignlen && fill == '0') {
4784             for (i = 0; i < esignlen; i++)
4785                 *p++ = esignbuf[i];
4786         }
4787         if (gap && !left) {
4788             memset(p, fill, gap);
4789             p += gap;
4790         }
4791         if (esignlen && fill != '0') {
4792             for (i = 0; i < esignlen; i++)
4793                 *p++ = esignbuf[i];
4794         }
4795         if (zeros) {
4796             for (i = zeros; i; i--)
4797                 *p++ = '0';
4798         }
4799         if (elen) {
4800             memcpy(p, eptr, elen);
4801             p += elen;
4802         }
4803         if (gap && left) {
4804             memset(p, ' ', gap);
4805             p += gap;
4806         }
4807         *p = '\0';
4808         SvCUR(sv) = p - SvPVX(sv);
4809     }
4810 }
4811
4812 #ifdef DEBUGGING
4813 void
4814 sv_dump(SV *sv)
4815 {
4816     SV *d = sv_newmortal();
4817     char *s;
4818     U32 flags;
4819     U32 type;
4820
4821     if (!sv) {
4822         PerlIO_printf(Perl_debug_log, "SV = 0\n");
4823         return;
4824     }
4825
4826     flags = SvFLAGS(sv);
4827     type = SvTYPE(sv);
4828
4829     sv_setpvf(d, "(0x%lx)\n  REFCNT = %ld\n  FLAGS = (",
4830               (unsigned long)SvANY(sv), (long)SvREFCNT(sv));
4831     if (flags & SVs_PADBUSY)    sv_catpv(d, "PADBUSY,");
4832     if (flags & SVs_PADTMP)     sv_catpv(d, "PADTMP,");
4833     if (flags & SVs_PADMY)      sv_catpv(d, "PADMY,");
4834     if (flags & SVs_TEMP)       sv_catpv(d, "TEMP,");
4835     if (flags & SVs_OBJECT)     sv_catpv(d, "OBJECT,");
4836     if (flags & SVs_GMG)        sv_catpv(d, "GMG,");
4837     if (flags & SVs_SMG)        sv_catpv(d, "SMG,");
4838     if (flags & SVs_RMG)        sv_catpv(d, "RMG,");
4839
4840     if (flags & SVf_IOK)        sv_catpv(d, "IOK,");
4841     if (flags & SVf_NOK)        sv_catpv(d, "NOK,");
4842     if (flags & SVf_POK)        sv_catpv(d, "POK,");
4843     if (flags & SVf_ROK)        sv_catpv(d, "ROK,");
4844     if (flags & SVf_OOK)        sv_catpv(d, "OOK,");
4845     if (flags & SVf_FAKE)       sv_catpv(d, "FAKE,");
4846     if (flags & SVf_READONLY)   sv_catpv(d, "READONLY,");
4847
4848 #ifdef OVERLOAD
4849     if (flags & SVf_AMAGIC)     sv_catpv(d, "OVERLOAD,");
4850 #endif /* OVERLOAD */
4851     if (flags & SVp_IOK)        sv_catpv(d, "pIOK,");
4852     if (flags & SVp_NOK)        sv_catpv(d, "pNOK,");
4853     if (flags & SVp_POK)        sv_catpv(d, "pPOK,");
4854     if (flags & SVp_SCREAM)     sv_catpv(d, "SCREAM,");
4855
4856     switch (type) {
4857     case SVt_PVCV:
4858     case SVt_PVFM:
4859         if (CvANON(sv))         sv_catpv(d, "ANON,");
4860         if (CvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
4861         if (CvCLONE(sv))        sv_catpv(d, "CLONE,");
4862         if (CvCLONED(sv))       sv_catpv(d, "CLONED,");
4863         if (CvNODEBUG(sv))      sv_catpv(d, "NODEBUG,");
4864         break;
4865     case SVt_PVHV:
4866         if (HvSHAREKEYS(sv))    sv_catpv(d, "SHAREKEYS,");
4867         if (HvLAZYDEL(sv))      sv_catpv(d, "LAZYDEL,");
4868         break;
4869     case SVt_PVGV:
4870         if (GvINTRO(sv))        sv_catpv(d, "INTRO,");
4871         if (GvMULTI(sv))        sv_catpv(d, "MULTI,");
4872         if (GvASSUMECV(sv))     sv_catpv(d, "ASSUMECV,");
4873         if (GvIMPORTED(sv)) {
4874             sv_catpv(d, "IMPORT");
4875             if (GvIMPORTED(sv) == GVf_IMPORTED)
4876                 sv_catpv(d, "ALL,");
4877             else {
4878                 sv_catpv(d, "(");
4879                 if (GvIMPORTED_SV(sv))  sv_catpv(d, " SV");
4880                 if (GvIMPORTED_AV(sv))  sv_catpv(d, " AV");
4881                 if (GvIMPORTED_HV(sv))  sv_catpv(d, " HV");
4882                 if (GvIMPORTED_CV(sv))  sv_catpv(d, " CV");
4883                 sv_catpv(d, " ),");
4884             }
4885         }
4886     case SVt_PVBM:
4887         if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
4888         if (SvCOMPILED(sv))     sv_catpv(d, "COMPILED,");
4889         break;
4890     }
4891
4892     if (*(SvEND(d) - 1) == ',')
4893         SvPVX(d)[--SvCUR(d)] = '\0';
4894     sv_catpv(d, ")");
4895     s = SvPVX(d);
4896
4897     PerlIO_printf(Perl_debug_log, "SV = ");
4898     switch (type) {
4899     case SVt_NULL:
4900         PerlIO_printf(Perl_debug_log, "NULL%s\n", s);
4901         return;
4902     case SVt_IV:
4903         PerlIO_printf(Perl_debug_log, "IV%s\n", s);
4904         break;
4905     case SVt_NV:
4906         PerlIO_printf(Perl_debug_log, "NV%s\n", s);
4907         break;
4908     case SVt_RV:
4909         PerlIO_printf(Perl_debug_log, "RV%s\n", s);
4910         break;
4911     case SVt_PV:
4912         PerlIO_printf(Perl_debug_log, "PV%s\n", s);
4913         break;
4914     case SVt_PVIV:
4915         PerlIO_printf(Perl_debug_log, "PVIV%s\n", s);
4916         break;
4917     case SVt_PVNV:
4918         PerlIO_printf(Perl_debug_log, "PVNV%s\n", s);
4919         break;
4920     case SVt_PVBM:
4921         PerlIO_printf(Perl_debug_log, "PVBM%s\n", s);
4922         break;
4923     case SVt_PVMG:
4924         PerlIO_printf(Perl_debug_log, "PVMG%s\n", s);
4925         break;
4926     case SVt_PVLV:
4927         PerlIO_printf(Perl_debug_log, "PVLV%s\n", s);
4928         break;
4929     case SVt_PVAV:
4930         PerlIO_printf(Perl_debug_log, "PVAV%s\n", s);
4931         break;
4932     case SVt_PVHV:
4933         PerlIO_printf(Perl_debug_log, "PVHV%s\n", s);
4934         break;
4935     case SVt_PVCV:
4936         PerlIO_printf(Perl_debug_log, "PVCV%s\n", s);
4937         break;
4938     case SVt_PVGV:
4939         PerlIO_printf(Perl_debug_log, "PVGV%s\n", s);
4940         break;
4941     case SVt_PVFM:
4942         PerlIO_printf(Perl_debug_log, "PVFM%s\n", s);
4943         break;
4944     case SVt_PVIO:
4945         PerlIO_printf(Perl_debug_log, "PVIO%s\n", s);
4946         break;
4947     default:
4948         PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", s);
4949         return;
4950     }
4951     if (type >= SVt_PVIV || type == SVt_IV)
4952         PerlIO_printf(Perl_debug_log, "  IV = %ld\n", (long)SvIVX(sv));
4953     if (type >= SVt_PVNV || type == SVt_NV) {
4954         SET_NUMERIC_STANDARD();
4955         PerlIO_printf(Perl_debug_log, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
4956     }
4957     if (SvROK(sv)) {
4958         PerlIO_printf(Perl_debug_log, "  RV = 0x%lx\n", (long)SvRV(sv));
4959         sv_dump(SvRV(sv));
4960         return;
4961     }
4962     if (type < SVt_PV)
4963         return;
4964     if (type <= SVt_PVLV) {
4965         if (SvPVX(sv))
4966             PerlIO_printf(Perl_debug_log, "  PV = 0x%lx \"%s\"\n  CUR = %ld\n  LEN = %ld\n",
4967                 (long)SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv));
4968         else
4969             PerlIO_printf(Perl_debug_log, "  PV = 0\n");
4970     }
4971     if (type >= SVt_PVMG) {
4972         if (SvMAGIC(sv)) {
4973             PerlIO_printf(Perl_debug_log, "  MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
4974         }
4975         if (SvSTASH(sv))
4976             PerlIO_printf(Perl_debug_log, "  STASH = \"%s\"\n", HvNAME(SvSTASH(sv)));
4977     }
4978     switch (type) {
4979     case SVt_PVLV:
4980         PerlIO_printf(Perl_debug_log, "  TYPE = %c\n", LvTYPE(sv));
4981         PerlIO_printf(Perl_debug_log, "  TARGOFF = %ld\n", (long)LvTARGOFF(sv));
4982         PerlIO_printf(Perl_debug_log, "  TARGLEN = %ld\n", (long)LvTARGLEN(sv));
4983         PerlIO_printf(Perl_debug_log, "  TARG = 0x%lx\n", (long)LvTARG(sv));
4984         sv_dump(LvTARG(sv));
4985         break;
4986     case SVt_PVAV:
4987         PerlIO_printf(Perl_debug_log, "  ARRAY = 0x%lx\n", (long)AvARRAY(sv));
4988         PerlIO_printf(Perl_debug_log, "  ALLOC = 0x%lx\n", (long)AvALLOC(sv));
4989         PerlIO_printf(Perl_debug_log, "  FILL = %ld\n", (long)AvFILLp(sv));
4990         PerlIO_printf(Perl_debug_log, "  MAX = %ld\n", (long)AvMAX(sv));
4991         PerlIO_printf(Perl_debug_log, "  ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
4992         flags = AvFLAGS(sv);
4993         sv_setpv(d, "");
4994         if (flags & AVf_REAL)   sv_catpv(d, ",REAL");
4995         if (flags & AVf_REIFY)  sv_catpv(d, ",REIFY");
4996         if (flags & AVf_REUSED) sv_catpv(d, ",REUSED");
4997         PerlIO_printf(Perl_debug_log, "  FLAGS = (%s)\n",
4998                       SvCUR(d) ? SvPVX(d) + 1 : "");
4999         break;
5000     case SVt_PVHV:
5001         PerlIO_printf(Perl_debug_log, "  ARRAY = 0x%lx\n",(long)HvARRAY(sv));
5002         PerlIO_printf(Perl_debug_log, "  KEYS = %ld\n", (long)HvKEYS(sv));
5003         PerlIO_printf(Perl_debug_log, "  FILL = %ld\n", (long)HvFILL(sv));
5004         PerlIO_printf(Perl_debug_log, "  MAX = %ld\n", (long)HvMAX(sv));
5005         PerlIO_printf(Perl_debug_log, "  RITER = %ld\n", (long)HvRITER(sv));
5006         PerlIO_printf(Perl_debug_log, "  EITER = 0x%lx\n",(long) HvEITER(sv));
5007         if (HvPMROOT(sv))
5008             PerlIO_printf(Perl_debug_log, "  PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
5009         if (HvNAME(sv))
5010             PerlIO_printf(Perl_debug_log, "  NAME = \"%s\"\n", HvNAME(sv));
5011         break;
5012     case SVt_PVCV:
5013         if (SvPOK(sv))
5014             PerlIO_printf(Perl_debug_log, "  PROTOTYPE = \"%s\"\n", SvPV(sv,na));
5015         /* FALL THROUGH */
5016     case SVt_PVFM:
5017         PerlIO_printf(Perl_debug_log, "  STASH = 0x%lx\n", (long)CvSTASH(sv));
5018         PerlIO_printf(Perl_debug_log, "  START = 0x%lx\n", (long)CvSTART(sv));
5019         PerlIO_printf(Perl_debug_log, "  ROOT = 0x%lx\n", (long)CvROOT(sv));
5020         PerlIO_printf(Perl_debug_log, "  XSUB = 0x%lx\n", (long)CvXSUB(sv));
5021         PerlIO_printf(Perl_debug_log, "  XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32);
5022         PerlIO_printf(Perl_debug_log, "  GV = 0x%lx", (long)CvGV(sv));
5023         if (CvGV(sv) && GvNAME(CvGV(sv))) {
5024             PerlIO_printf(Perl_debug_log, "  \"%s\"\n", GvNAME(CvGV(sv)));
5025         } else {
5026             PerlIO_printf(Perl_debug_log, "\n");
5027         }
5028         PerlIO_printf(Perl_debug_log, "  FILEGV = 0x%lx\n", (long)CvFILEGV(sv));
5029         PerlIO_printf(Perl_debug_log, "  DEPTH = %ld\n", (long)CvDEPTH(sv));
5030         PerlIO_printf(Perl_debug_log, "  PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
5031         PerlIO_printf(Perl_debug_log, "  OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv));
5032 #ifdef USE_THREADS
5033         PerlIO_printf(Perl_debug_log, "  MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv));
5034         PerlIO_printf(Perl_debug_log, "  OWNER = 0x%lx\n", (long)CvOWNER(sv));
5035 #endif /* USE_THREADS */
5036         PerlIO_printf(Perl_debug_log, "  FLAGS = 0x%lx\n",
5037                       (unsigned long)CvFLAGS(sv));
5038         if (type == SVt_PVFM)
5039             PerlIO_printf(Perl_debug_log, "  LINES = %ld\n", (long)FmLINES(sv));
5040         break;
5041     case SVt_PVGV:
5042         PerlIO_printf(Perl_debug_log, "  NAME = \"%s\"\n", GvNAME(sv));
5043         PerlIO_printf(Perl_debug_log, "  NAMELEN = %ld\n", (long)GvNAMELEN(sv));
5044         PerlIO_printf(Perl_debug_log, "  STASH = \"%s\"\n",
5045             SvTYPE(GvSTASH(sv)) == SVt_PVHV ? HvNAME(GvSTASH(sv)) : "(deleted)");
5046         PerlIO_printf(Perl_debug_log, "  GP = 0x%lx\n", (long)GvGP(sv));
5047         PerlIO_printf(Perl_debug_log, "    SV = 0x%lx\n", (long)GvSV(sv));
5048         PerlIO_printf(Perl_debug_log, "    REFCNT = %ld\n", (long)GvREFCNT(sv));
5049         PerlIO_printf(Perl_debug_log, "    IO = 0x%lx\n", (long)GvIOp(sv));
5050         PerlIO_printf(Perl_debug_log, "    FORM = 0x%lx\n", (long)GvFORM(sv));
5051         PerlIO_printf(Perl_debug_log, "    AV = 0x%lx\n", (long)GvAV(sv));
5052         PerlIO_printf(Perl_debug_log, "    HV = 0x%lx\n", (long)GvHV(sv));
5053         PerlIO_printf(Perl_debug_log, "    CV = 0x%lx\n", (long)GvCV(sv));
5054         PerlIO_printf(Perl_debug_log, "    CVGEN = 0x%lx\n", (long)GvCVGEN(sv));
5055         PerlIO_printf(Perl_debug_log, "    LASTEXPR = %ld\n", (long)GvLASTEXPR(sv));
5056         PerlIO_printf(Perl_debug_log, "    LINE = %ld\n", (long)GvLINE(sv));
5057         PerlIO_printf(Perl_debug_log, "    FILEGV = 0x%lx\n", (long)GvFILEGV(sv));
5058         PerlIO_printf(Perl_debug_log, "    EGV = 0x%lx\n", (long)GvEGV(sv));
5059         break;
5060     case SVt_PVIO:
5061         PerlIO_printf(Perl_debug_log, "  IFP = 0x%lx\n", (long)IoIFP(sv));
5062         PerlIO_printf(Perl_debug_log, "  OFP = 0x%lx\n", (long)IoOFP(sv));
5063         PerlIO_printf(Perl_debug_log, "  DIRP = 0x%lx\n", (long)IoDIRP(sv));
5064         PerlIO_printf(Perl_debug_log, "  LINES = %ld\n", (long)IoLINES(sv));
5065         PerlIO_printf(Perl_debug_log, "  PAGE = %ld\n", (long)IoPAGE(sv));
5066         PerlIO_printf(Perl_debug_log, "  PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv));
5067         PerlIO_printf(Perl_debug_log, "  LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv));
5068         PerlIO_printf(Perl_debug_log, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
5069         PerlIO_printf(Perl_debug_log, "  TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv));
5070         PerlIO_printf(Perl_debug_log, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
5071         PerlIO_printf(Perl_debug_log, "  FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv));
5072         PerlIO_printf(Perl_debug_log, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
5073         PerlIO_printf(Perl_debug_log, "  BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv));
5074         PerlIO_printf(Perl_debug_log, "  SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv));
5075         PerlIO_printf(Perl_debug_log, "  TYPE = %c\n", IoTYPE(sv));
5076         PerlIO_printf(Perl_debug_log, "  FLAGS = 0x%lx\n", (long)IoFLAGS(sv));
5077         break;
5078     }
5079 }
5080 #else
5081 void
5082 sv_dump(SV *sv)
5083 {
5084 }
5085 #endif
5086
5087
5088
5089