sv.c

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