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