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