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             DEBUG_c(PerlIO_printf(Perl_debug_log,
1221 #if defined(USE_LONG_DOUBLE)
1222                                   "0x%lx 2nv(%Lg)\n",
1223 #else
1224                                   "0x%lx 2nv(%g)\n",
1225 #endif
1226                                   (unsigned long)sv,
1227                                   SvNVX(sv)));
1228             if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1229                 SvIVX(sv) = I_V(SvNVX(sv));
1230             else {
1231                 SvUVX(sv) = U_V(SvNVX(sv));
1232                 SvIsUV_on(sv);
1233                 goto ret_iv_max;
1234             }
1235         }
1236         else if (numtype) {
1237             /* The NV may be reconstructed from IV - safe to cache IV,
1238                which may be calculated by atol(). */
1239             if (SvTYPE(sv) == SVt_PV)
1240                 sv_upgrade(sv, SVt_PVIV);
1241             (void)SvIOK_on(sv);
1242             SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1243         }
1244         else {                          /* Not a number.  Cache 0. */
1245             dTHR;
1246
1247             if (SvTYPE(sv) < SVt_PVIV)
1248                 sv_upgrade(sv, SVt_PVIV);
1249             SvIVX(sv) = 0;
1250             (void)SvIOK_on(sv);
1251             if (ckWARN(WARN_NUMERIC))
1252                 not_a_number(sv);
1253         }
1254     }
1255     else  {
1256         dTHR;
1257         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1258             Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1259         if (SvTYPE(sv) < SVt_IV)
1260             /* Typically the caller expects that sv_any is not NULL now.  */
1261             sv_upgrade(sv, SVt_IV);
1262         return 0;
1263     }
1264     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1265         (unsigned long)sv,(long)SvIVX(sv)));
1266     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1267 }
1268
1269 UV
1270 Perl_sv_2uv(pTHX_ register SV *sv)
1271 {
1272     if (!sv)
1273         return 0;
1274     if (SvGMAGICAL(sv)) {
1275         mg_get(sv);
1276         if (SvIOKp(sv))
1277             return SvUVX(sv);
1278         if (SvNOKp(sv))
1279             return U_V(SvNVX(sv));
1280         if (SvPOKp(sv) && SvLEN(sv))
1281             return asUV(sv);
1282         if (!SvROK(sv)) {
1283             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1284                 dTHR;
1285                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1286                     Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1287             }
1288             return 0;
1289         }
1290     }
1291     if (SvTHINKFIRST(sv)) {
1292         if (SvROK(sv)) {
1293           SV* tmpstr;
1294           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1295               return SvUV(tmpstr);
1296           return (UV)SvRV(sv);
1297         }
1298         if (SvREADONLY(sv)) {
1299             if (SvNOKp(sv)) {
1300                 return U_V(SvNVX(sv));
1301             }
1302             if (SvPOKp(sv) && SvLEN(sv))
1303                 return asUV(sv);
1304             {
1305                 dTHR;
1306                 if (ckWARN(WARN_UNINITIALIZED))
1307                     Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1308             }
1309             return 0;
1310         }
1311     }
1312     if (SvIOKp(sv)) {
1313         if (SvIsUV(sv)) {
1314             return SvUVX(sv);
1315         }
1316         else {
1317             return (UV)SvIVX(sv);
1318         }
1319     }
1320     if (SvNOKp(sv)) {
1321         /* We can cache the IV/UV value even if it not good enough
1322          * to reconstruct NV, since the conversion to PV will prefer
1323          * NV over IV/UV.                               XXXX 64-bit?
1324          */
1325         if (SvTYPE(sv) == SVt_NV)
1326             sv_upgrade(sv, SVt_PVNV);
1327         (void)SvIOK_on(sv);
1328         if (SvNVX(sv) >= -0.5) {
1329             SvIsUV_on(sv);
1330             SvUVX(sv) = U_V(SvNVX(sv));
1331         }
1332         else {
1333             SvIVX(sv) = I_V(SvNVX(sv));
1334           ret_zero:
1335             DEBUG_c(PerlIO_printf(Perl_debug_log,
1336                                   "0x%lx 2uv(%ld => %lu) (as signed)\n",
1337                                   (unsigned long)sv,(long)SvIVX(sv),
1338                                   (long)(UV)SvIVX(sv)));
1339             return (UV)SvIVX(sv);
1340         }
1341     }
1342     else if (SvPOKp(sv) && SvLEN(sv)) {
1343         I32 numtype = looks_like_number(sv);
1344
1345         /* We want to avoid a possible problem when we cache a UV which
1346            may be later translated to an NV, and the resulting NV is not
1347            the translation of the initial data.
1348
1349            This means that if we cache such a UV, we need to cache the
1350            NV as well.  Moreover, we trade speed for space, and do not
1351            cache the NV if not needed.
1352          */
1353         if (numtype & IS_NUMBER_NOT_IV) {
1354             /* May be not an integer.  Need to cache NV if we cache IV
1355              * - otherwise future conversion to NV will be wrong.  */
1356             NV d;
1357
1358             d = Atof(SvPVX(sv));        /* XXXX 64-bit? */
1359
1360             if (SvTYPE(sv) < SVt_PVNV)
1361                 sv_upgrade(sv, SVt_PVNV);
1362             SvNVX(sv) = d;
1363             (void)SvNOK_on(sv);
1364             (void)SvIOK_on(sv);
1365             DEBUG_c(PerlIO_printf(Perl_debug_log,
1366 #if defined(USE_LONG_DOUBLE)
1367                                   "0x%lx 2nv(%Lg)\n",
1368 #else
1369                                   "0x%lx 2nv(%g)\n",
1370 #endif
1371                                   (unsigned long)sv,
1372                                   SvNVX(sv)));
1373             if (SvNVX(sv) < -0.5) {
1374                 SvIVX(sv) = I_V(SvNVX(sv));
1375                 goto ret_zero;
1376             } else {
1377                 SvUVX(sv) = U_V(SvNVX(sv));
1378                 SvIsUV_on(sv);
1379             }
1380         }
1381         else if (numtype & IS_NUMBER_NEG) {
1382             /* The NV may be reconstructed from IV - safe to cache IV,
1383                which may be calculated by atol(). */
1384             if (SvTYPE(sv) == SVt_PV)
1385                 sv_upgrade(sv, SVt_PVIV);
1386             (void)SvIOK_on(sv);
1387             SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1388         }
1389         else if (numtype) {             /* Non-negative */
1390             /* The NV may be reconstructed from UV - safe to cache UV,
1391                which may be calculated by strtoul()/atol. */
1392             if (SvTYPE(sv) == SVt_PV)
1393                 sv_upgrade(sv, SVt_PVIV);
1394             (void)SvIOK_on(sv);
1395             (void)SvIsUV_on(sv);
1396 #ifdef HAS_STRTOUL
1397             SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1398 #else                   /* no atou(), but we know the number fits into IV... */
1399                         /* The only problem may be if it is negative... */
1400             SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1401 #endif
1402         }
1403         else {                          /* Not a number.  Cache 0. */
1404             dTHR;
1405
1406             if (SvTYPE(sv) < SVt_PVIV)
1407                 sv_upgrade(sv, SVt_PVIV);
1408             SvUVX(sv) = 0;              /* We assume that 0s have the
1409                                            same bitmap in IV and UV. */
1410             (void)SvIOK_on(sv);
1411             (void)SvIsUV_on(sv);
1412             if (ckWARN(WARN_NUMERIC))
1413                 not_a_number(sv);
1414         }
1415     }
1416     else  {
1417         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1418             dTHR;
1419             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1420                 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1421         }
1422         if (SvTYPE(sv) < SVt_IV)
1423             /* Typically the caller expects that sv_any is not NULL now.  */
1424             sv_upgrade(sv, SVt_IV);
1425         return 0;
1426     }
1427
1428     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1429         (unsigned long)sv,SvUVX(sv)));
1430     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1431 }
1432
1433 NV
1434 Perl_sv_2nv(pTHX_ register SV *sv)
1435 {
1436     if (!sv)
1437         return 0.0;
1438     if (SvGMAGICAL(sv)) {
1439         mg_get(sv);
1440         if (SvNOKp(sv))
1441             return SvNVX(sv);
1442         if (SvPOKp(sv) && SvLEN(sv)) {
1443             dTHR;
1444             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1445                 not_a_number(sv);
1446             return Atof(SvPVX(sv));
1447         }
1448         if (SvIOKp(sv)) {
1449             if (SvIsUV(sv))
1450                 return (NV)SvUVX(sv);
1451             else
1452                 return (NV)SvIVX(sv);
1453         }
1454         if (!SvROK(sv)) {
1455             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1456                 dTHR;
1457                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1458                     Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1459             }
1460             return 0;
1461         }
1462     }
1463     if (SvTHINKFIRST(sv)) {
1464         if (SvROK(sv)) {
1465           SV* tmpstr;
1466           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1467               return SvNV(tmpstr);
1468           return (NV)(unsigned long)SvRV(sv);
1469         }
1470         if (SvREADONLY(sv)) {
1471             dTHR;
1472             if (SvPOKp(sv) && SvLEN(sv)) {
1473                 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1474                     not_a_number(sv);
1475                 return Atof(SvPVX(sv));
1476             }
1477             if (SvIOKp(sv)) {
1478                 if (SvIsUV(sv))
1479                     return (NV)SvUVX(sv);
1480                 else
1481                     return (NV)SvIVX(sv);
1482             }
1483             if (ckWARN(WARN_UNINITIALIZED))
1484                 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1485             return 0.0;
1486         }
1487     }
1488     if (SvTYPE(sv) < SVt_NV) {
1489         if (SvTYPE(sv) == SVt_IV)
1490             sv_upgrade(sv, SVt_PVNV);
1491         else
1492             sv_upgrade(sv, SVt_NV);
1493         DEBUG_c({
1494             RESTORE_NUMERIC_STANDARD();
1495             PerlIO_printf(Perl_debug_log,
1496 #if defined(USE_LONG_DOUBLE)
1497                           "0x%lx num(%Lg)\n",
1498 #else
1499                           "0x%lx num(%g)\n",
1500 #endif
1501                           (unsigned long)sv,SvNVX(sv)));
1502             RESTORE_NUMERIC_LOCAL();
1503         });
1504     }
1505     else if (SvTYPE(sv) < SVt_PVNV)
1506         sv_upgrade(sv, SVt_PVNV);
1507     if (SvIOKp(sv) &&
1508             (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1509     {
1510         SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1511     }
1512     else if (SvPOKp(sv) && SvLEN(sv)) {
1513         dTHR;
1514         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1515             not_a_number(sv);
1516         SvNVX(sv) = Atof(SvPVX(sv));
1517     }
1518     else  {
1519         dTHR;
1520         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1521             Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1522         if (SvTYPE(sv) < SVt_NV)
1523             /* Typically the caller expects that sv_any is not NULL now.  */
1524             sv_upgrade(sv, SVt_NV);
1525         return 0.0;
1526     }
1527     SvNOK_on(sv);
1528     DEBUG_c({
1529         RESTORE_NUMERIC_STANDARD();
1530         PerlIO_printf(Perl_debug_log,
1531 #if defined(USE_LONG_DOUBLE)
1532                       "0x%lx 2nv(%Lg)\n",
1533 #else
1534                       "0x%lx 1nv(%g)\n",
1535 #endif
1536                       (unsigned long)sv,SvNVX(sv)));
1537         RESTORE_NUMERIC_LOCAL();
1538     });
1539     return SvNVX(sv);
1540 }
1541
1542 STATIC IV
1543 S_asIV(pTHX_ SV *sv)
1544 {
1545     I32 numtype = looks_like_number(sv);
1546     NV d;
1547
1548     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1549         return atol(SvPVX(sv));         /* XXXX 64-bit? */
1550     if (!numtype) {
1551         dTHR;
1552         if (ckWARN(WARN_NUMERIC))
1553             not_a_number(sv);
1554     }
1555     d = Atof(SvPVX(sv));
1556     return I_V(d);
1557 }
1558
1559 STATIC UV
1560 S_asUV(pTHX_ SV *sv)
1561 {
1562     I32 numtype = looks_like_number(sv);
1563
1564 #ifdef HAS_STRTOUL
1565     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1566         return strtoul(SvPVX(sv), Null(char**), 10);
1567 #endif
1568     if (!numtype) {
1569         dTHR;
1570         if (ckWARN(WARN_NUMERIC))
1571             not_a_number(sv);
1572     }
1573     return U_V(Atof(SvPVX(sv)));
1574 }
1575
1576 /*
1577  * Returns a combination of (advisory only - can get false negatives)
1578  *      IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1579  *      IS_NUMBER_NEG
1580  * 0 if does not look like number.
1581  *
1582  * In fact possible values are 0 and
1583  * IS_NUMBER_TO_INT_BY_ATOL                             123
1584  * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV          123.1
1585  * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV          123e0
1586  * with a possible addition of IS_NUMBER_NEG.
1587  */
1588
1589 I32
1590 Perl_looks_like_number(pTHX_ SV *sv)
1591 {
1592     /* XXXX 64-bit?  It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1593      * using atof() may lose precision. */
1594     register char *s;
1595     register char *send;
1596     register char *sbegin;
1597     register char *nbegin;
1598     I32 numtype = 0;
1599     STRLEN len;
1600
1601     if (SvPOK(sv)) {
1602         sbegin = SvPVX(sv);
1603         len = SvCUR(sv);
1604     }
1605     else if (SvPOKp(sv))
1606         sbegin = SvPV(sv, len);
1607     else
1608         return 1;
1609     send = sbegin + len;
1610
1611     s = sbegin;
1612     while (isSPACE(*s))
1613         s++;
1614     if (*s == '-') {
1615         s++;
1616         numtype = IS_NUMBER_NEG;
1617     }
1618     else if (*s == '+')
1619         s++;
1620
1621     nbegin = s;
1622     /*
1623      * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1624      * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1625      * (int)atof().
1626      */
1627
1628     /* next must be digit or the radix separator */
1629     if (isDIGIT(*s)) {
1630         do {
1631             s++;
1632         } while (isDIGIT(*s));
1633
1634         if (s - nbegin >= TYPE_DIGITS(IV))      /* Cannot cache ato[ul]() */
1635             numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1636         else
1637             numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1638
1639         if (*s == '.'
1640 #ifdef USE_LOCALE_NUMERIC
1641             || IS_NUMERIC_RADIX(*s)
1642 #endif
1643             ) {
1644             s++;
1645             numtype |= IS_NUMBER_NOT_IV;
1646             while (isDIGIT(*s))  /* optional digits after the radix */
1647                 s++;
1648         }
1649     }
1650     else if (*s == '.'
1651 #ifdef USE_LOCALE_NUMERIC
1652             || IS_NUMERIC_RADIX(*s)
1653 #endif
1654             ) {
1655         s++;
1656         numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1657         /* no digits before the radix means we need digits after it */
1658         if (isDIGIT(*s)) {
1659             do {
1660                 s++;
1661             } while (isDIGIT(*s));
1662         }
1663         else
1664             return 0;
1665     }
1666     else
1667         return 0;
1668
1669     /* we can have an optional exponent part */
1670     if (*s == 'e' || *s == 'E') {
1671         numtype &= ~IS_NUMBER_NEG;
1672         numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1673         s++;
1674         if (*s == '+' || *s == '-')
1675             s++;
1676         if (isDIGIT(*s)) {
1677             do {
1678                 s++;
1679             } while (isDIGIT(*s));
1680         }
1681         else
1682             return 0;
1683     }
1684     while (isSPACE(*s))
1685         s++;
1686     if (s >= send)
1687         return numtype;
1688     if (len == 10 && memEQ(sbegin, "0 but true", 10))
1689         return IS_NUMBER_TO_INT_BY_ATOL;
1690     return 0;
1691 }
1692
1693 char *
1694 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1695 {
1696     STRLEN n_a;
1697     return sv_2pv(sv, &n_a);
1698 }
1699
1700 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1701 static char *
1702 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1703 {
1704     STRLEN len;
1705     char *ptr = buf + TYPE_CHARS(UV);
1706     char *ebuf = ptr;
1707     int sign;
1708     char *p;
1709
1710     if (is_uv)
1711         sign = 0;
1712     else if (iv >= 0) {
1713         uv = iv;
1714         sign = 0;
1715     } else {
1716         uv = -iv;
1717         sign = 1;
1718     }
1719     do {
1720         *--ptr = '0' + (uv % 10);
1721     } while (uv /= 10);
1722     if (sign)
1723         *--ptr = '-';
1724     *peob = ebuf;
1725     return ptr;
1726 }
1727
1728 char *
1729 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1730 {
1731     register char *s;
1732     int olderrno;
1733     SV *tsv;
1734     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
1735     char *tmpbuf = tbuf;
1736
1737     if (!sv) {
1738         *lp = 0;
1739         return "";
1740     }
1741     if (SvGMAGICAL(sv)) {
1742         mg_get(sv);
1743         if (SvPOKp(sv)) {
1744             *lp = SvCUR(sv);
1745             return SvPVX(sv);
1746         }
1747         if (SvIOKp(sv)) {               /* XXXX 64-bit? */
1748             if (SvIsUV(sv))
1749                 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1750             else
1751                 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1752             tsv = Nullsv;
1753             goto tokensave;
1754         }
1755         if (SvNOKp(sv)) {
1756             Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1757             tsv = Nullsv;
1758             goto tokensave;
1759         }
1760         if (!SvROK(sv)) {
1761             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1762                 dTHR;
1763                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1764                     Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1765             }
1766             *lp = 0;
1767             return "";
1768         }
1769     }
1770     if (SvTHINKFIRST(sv)) {
1771         if (SvROK(sv)) {
1772             SV* tmpstr;
1773             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1774                 return SvPV(tmpstr,*lp);
1775             sv = (SV*)SvRV(sv);
1776             if (!sv)
1777                 s = "NULLREF";
1778             else {
1779                 MAGIC *mg;
1780
1781                 switch (SvTYPE(sv)) {
1782                 case SVt_PVMG:
1783                     if ( ((SvFLAGS(sv) &
1784                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1785                           == (SVs_OBJECT|SVs_RMG))
1786                          && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1787                          && (mg = mg_find(sv, 'r'))) {
1788                         dTHR;
1789                         regexp *re = (regexp *)mg->mg_obj;
1790
1791                         if (!mg->mg_ptr) {
1792                             char *fptr = "msix";
1793                             char reflags[6];
1794                             char ch;
1795                             int left = 0;
1796                             int right = 4;
1797                             U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1798
1799                             while(ch = *fptr++) {
1800                                 if(reganch & 1) {
1801                                     reflags[left++] = ch;
1802                                 }
1803                                 else {
1804                                     reflags[right--] = ch;
1805                                 }
1806                                 reganch >>= 1;
1807                             }
1808                             if(left != 4) {
1809                                 reflags[left] = '-';
1810                                 left = 5;
1811                             }
1812
1813                             mg->mg_len = re->prelen + 4 + left;
1814                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1815                             Copy("(?", mg->mg_ptr, 2, char);
1816                             Copy(reflags, mg->mg_ptr+2, left, char);
1817                             Copy(":", mg->mg_ptr+left+2, 1, char);
1818                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1819                             mg->mg_ptr[mg->mg_len - 1] = ')';
1820                             mg->mg_ptr[mg->mg_len] = 0;
1821                         }
1822                         PL_reginterp_cnt += re->program[0].next_off;
1823                         *lp = mg->mg_len;
1824                         return mg->mg_ptr;
1825                     }
1826                                         /* Fall through */
1827                 case SVt_NULL:
1828                 case SVt_IV:
1829                 case SVt_NV:
1830                 case SVt_RV:
1831                 case SVt_PV:
1832                 case SVt_PVIV:
1833                 case SVt_PVNV:
1834                 case SVt_PVBM:  s = "SCALAR";                   break;
1835                 case SVt_PVLV:  s = "LVALUE";                   break;
1836                 case SVt_PVAV:  s = "ARRAY";                    break;
1837                 case SVt_PVHV:  s = "HASH";                     break;
1838                 case SVt_PVCV:  s = "CODE";                     break;
1839                 case SVt_PVGV:  s = "GLOB";                     break;
1840                 case SVt_PVFM:  s = "FORMAT";                   break;
1841                 case SVt_PVIO:  s = "IO";                       break;
1842                 default:        s = "UNKNOWN";                  break;
1843                 }
1844                 tsv = NEWSV(0,0);
1845                 if (SvOBJECT(sv))
1846                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1847                 else
1848                     sv_setpv(tsv, s);
1849                 /* XXXX 64-bit? */
1850                 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1851                 goto tokensaveref;
1852             }
1853             *lp = strlen(s);
1854             return s;
1855         }
1856         if (SvREADONLY(sv)) {
1857             if (SvNOKp(sv)) {           /* See note in sv_2uv() */
1858                 /* XXXX 64-bit?  IV may have better precision... */
1859                 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1860                 tsv = Nullsv;
1861                 goto tokensave;
1862             }
1863             if (SvIOKp(sv)) {
1864                 char *ebuf;
1865
1866                 if (SvIsUV(sv))
1867                     tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
1868                 else
1869                     tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
1870                 *ebuf = 0;
1871                 tsv = Nullsv;
1872                 goto tokensave;
1873             }
1874             {
1875                 dTHR;
1876                 if (ckWARN(WARN_UNINITIALIZED))
1877                     Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1878             }
1879             *lp = 0;
1880             return "";
1881         }
1882     }
1883     if (SvNOKp(sv)) {                   /* See note in sv_2uv() */
1884         /* XXXX 64-bit?  IV may have better precision... */
1885         if (SvTYPE(sv) < SVt_PVNV)
1886             sv_upgrade(sv, SVt_PVNV);
1887         SvGROW(sv, 28);
1888         s = SvPVX(sv);
1889         olderrno = errno;       /* some Xenix systems wipe out errno here */
1890 #ifdef apollo
1891         if (SvNVX(sv) == 0.0)
1892             (void)strcpy(s,"0");
1893         else
1894 #endif /*apollo*/
1895         {
1896             Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1897         }
1898         errno = olderrno;
1899 #ifdef FIXNEGATIVEZERO
1900         if (*s == '-' && s[1] == '0' && !s[2])
1901             strcpy(s,"0");
1902 #endif
1903         while (*s) s++;
1904 #ifdef hcx
1905         if (s[-1] == '.')
1906             *--s = '\0';
1907 #endif
1908     }
1909     else if (SvIOKp(sv)) {
1910         U32 isIOK = SvIOK(sv);
1911         char buf[TYPE_CHARS(UV)];
1912         char *ebuf, *ptr;
1913
1914         if (SvTYPE(sv) < SVt_PVIV)
1915             sv_upgrade(sv, SVt_PVIV);
1916         if (SvIsUV(sv)) {
1917             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1918             sv_setpvn(sv, ptr, ebuf - ptr);
1919             SvIsUV_on(sv);
1920         }
1921         else {
1922             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1923             sv_setpvn(sv, ptr, ebuf - ptr);
1924         }
1925         s = SvEND(sv);
1926         if (isIOK)
1927             SvIOK_on(sv);
1928         else
1929             SvIOKp_on(sv);
1930     }
1931     else {
1932         dTHR;
1933         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1934             Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1935         *lp = 0;
1936         if (SvTYPE(sv) < SVt_PV)
1937             /* Typically the caller expects that sv_any is not NULL now.  */
1938             sv_upgrade(sv, SVt_PV);
1939         return "";
1940     }
1941     *lp = s - SvPVX(sv);
1942     SvCUR_set(sv, *lp);
1943     SvPOK_on(sv);
1944     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1945     return SvPVX(sv);
1946
1947   tokensave:
1948     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
1949         /* Sneaky stuff here */
1950
1951       tokensaveref:
1952         if (!tsv)
1953             tsv = newSVpv(tmpbuf, 0);
1954         sv_2mortal(tsv);
1955         *lp = SvCUR(tsv);
1956         return SvPVX(tsv);
1957     }
1958     else {
1959         STRLEN len;
1960         char *t;
1961
1962         if (tsv) {
1963             sv_2mortal(tsv);
1964             t = SvPVX(tsv);
1965             len = SvCUR(tsv);
1966         }
1967         else {
1968             t = tmpbuf;
1969             len = strlen(tmpbuf);
1970         }
1971 #ifdef FIXNEGATIVEZERO
1972         if (len == 2 && t[0] == '-' && t[1] == '0') {
1973             t = "0";
1974             len = 1;
1975         }
1976 #endif
1977         (void)SvUPGRADE(sv, SVt_PV);
1978         *lp = len;
1979         s = SvGROW(sv, len + 1);
1980         SvCUR_set(sv, len);
1981         (void)strcpy(s, t);
1982         SvPOKp_on(sv);
1983         return s;
1984     }
1985 }
1986
1987 /* This function is only called on magical items */
1988 bool
1989 Perl_sv_2bool(pTHX_ register SV *sv)
1990 {
1991     if (SvGMAGICAL(sv))
1992         mg_get(sv);
1993
1994     if (!SvOK(sv))
1995         return 0;
1996     if (SvROK(sv)) {
1997         dTHR;
1998         SV* tmpsv;
1999         if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2000             return SvTRUE(tmpsv);
2001       return SvRV(sv) != 0;
2002     }
2003     if (SvPOKp(sv)) {
2004         register XPV* Xpvtmp;
2005         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2006                 (*Xpvtmp->xpv_pv > '0' ||
2007                 Xpvtmp->xpv_cur > 1 ||
2008                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2009             return 1;
2010         else
2011             return 0;
2012     }
2013     else {
2014         if (SvIOKp(sv))
2015             return SvIVX(sv) != 0;
2016         else {
2017             if (SvNOKp(sv))
2018                 return SvNVX(sv) != 0.0;
2019             else
2020                 return FALSE;
2021         }
2022     }
2023 }
2024
2025 /* Note: sv_setsv() should not be called with a source string that needs
2026  * to be reused, since it may destroy the source string if it is marked
2027  * as temporary.
2028  */
2029
2030 void
2031 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2032 {
2033     dTHR;
2034     register U32 sflags;
2035     register int dtype;
2036     register int stype;
2037
2038     if (sstr == dstr)
2039         return;
2040     SV_CHECK_THINKFIRST(dstr);
2041     if (!sstr)
2042         sstr = &PL_sv_undef;
2043     stype = SvTYPE(sstr);
2044     dtype = SvTYPE(dstr);
2045
2046     SvAMAGIC_off(dstr);
2047
2048     /* There's a lot of redundancy below but we're going for speed here */
2049
2050     switch (stype) {
2051     case SVt_NULL:
2052       undef_sstr:
2053         if (dtype != SVt_PVGV) {
2054             (void)SvOK_off(dstr);
2055             return;
2056         }
2057         break;
2058     case SVt_IV:
2059         if (SvIOK(sstr)) {
2060             switch (dtype) {
2061             case SVt_NULL:
2062                 sv_upgrade(dstr, SVt_IV);
2063                 break;
2064             case SVt_NV:
2065                 sv_upgrade(dstr, SVt_PVNV);
2066                 break;
2067             case SVt_RV:
2068             case SVt_PV:
2069                 sv_upgrade(dstr, SVt_PVIV);
2070                 break;
2071             }
2072             (void)SvIOK_only(dstr);
2073             SvIVX(dstr) = SvIVX(sstr);
2074             if (SvIsUV(sstr))
2075                 SvIsUV_on(dstr);
2076             SvTAINT(dstr);
2077             return;
2078         }
2079         goto undef_sstr;
2080
2081     case SVt_NV:
2082         if (SvNOK(sstr)) {
2083             switch (dtype) {
2084             case SVt_NULL:
2085             case SVt_IV:
2086                 sv_upgrade(dstr, SVt_NV);
2087                 break;
2088             case SVt_RV:
2089             case SVt_PV:
2090             case SVt_PVIV:
2091                 sv_upgrade(dstr, SVt_PVNV);
2092                 break;
2093             }
2094             SvNVX(dstr) = SvNVX(sstr);
2095             (void)SvNOK_only(dstr);
2096             SvTAINT(dstr);
2097             return;
2098         }
2099         goto undef_sstr;
2100
2101     case SVt_RV:
2102         if (dtype < SVt_RV)
2103             sv_upgrade(dstr, SVt_RV);
2104         else if (dtype == SVt_PVGV &&
2105                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2106             sstr = SvRV(sstr);
2107             if (sstr == dstr) {
2108                 if (PL_curcop->cop_stash != GvSTASH(dstr))
2109                     GvIMPORTED_on(dstr);
2110                 GvMULTI_on(dstr);
2111                 return;
2112             }
2113             goto glob_assign;
2114         }
2115         break;
2116     case SVt_PV:
2117     case SVt_PVFM:
2118         if (dtype < SVt_PV)
2119             sv_upgrade(dstr, SVt_PV);
2120         break;
2121     case SVt_PVIV:
2122         if (dtype < SVt_PVIV)
2123             sv_upgrade(dstr, SVt_PVIV);
2124         break;
2125     case SVt_PVNV:
2126         if (dtype < SVt_PVNV)
2127             sv_upgrade(dstr, SVt_PVNV);
2128         break;
2129     case SVt_PVAV:
2130     case SVt_PVHV:
2131     case SVt_PVCV:
2132     case SVt_PVIO:
2133         if (PL_op)
2134             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2135                 PL_op_name[PL_op->op_type]);
2136         else
2137             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2138         break;
2139
2140     case SVt_PVGV:
2141         if (dtype <= SVt_PVGV) {
2142   glob_assign:
2143             if (dtype != SVt_PVGV) {
2144                 char *name = GvNAME(sstr);
2145                 STRLEN len = GvNAMELEN(sstr);
2146                 sv_upgrade(dstr, SVt_PVGV);
2147                 sv_magic(dstr, dstr, '*', name, len);
2148                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2149                 GvNAME(dstr) = savepvn(name, len);
2150                 GvNAMELEN(dstr) = len;
2151                 SvFAKE_on(dstr);        /* can coerce to non-glob */
2152             }
2153             /* ahem, death to those who redefine active sort subs */
2154             else if (PL_curstackinfo->si_type == PERLSI_SORT
2155                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2156                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2157                       GvNAME(dstr));
2158             (void)SvOK_off(dstr);
2159             GvINTRO_off(dstr);          /* one-shot flag */
2160             gp_free((GV*)dstr);
2161             GvGP(dstr) = gp_ref(GvGP(sstr));
2162             SvTAINT(dstr);
2163             if (PL_curcop->cop_stash != GvSTASH(dstr))
2164                 GvIMPORTED_on(dstr);
2165             GvMULTI_on(dstr);
2166             return;
2167         }
2168         /* FALL THROUGH */
2169
2170     default:
2171         if (SvGMAGICAL(sstr)) {
2172             mg_get(sstr);
2173             if (SvTYPE(sstr) != stype) {
2174                 stype = SvTYPE(sstr);
2175                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2176                     goto glob_assign;
2177             }
2178         }
2179         if (stype == SVt_PVLV)
2180             (void)SvUPGRADE(dstr, SVt_PVNV);
2181         else
2182             (void)SvUPGRADE(dstr, stype);
2183     }
2184
2185     sflags = SvFLAGS(sstr);
2186
2187     if (sflags & SVf_ROK) {
2188         if (dtype >= SVt_PV) {
2189             if (dtype == SVt_PVGV) {
2190                 SV *sref = SvREFCNT_inc(SvRV(sstr));
2191                 SV *dref = 0;
2192                 int intro = GvINTRO(dstr);
2193
2194                 if (intro) {
2195                     GP *gp;
2196                     GvGP(dstr)->gp_refcnt--;
2197                     GvINTRO_off(dstr);  /* one-shot flag */
2198                     Newz(602,gp, 1, GP);
2199                     GvGP(dstr) = gp_ref(gp);
2200                     GvSV(dstr) = NEWSV(72,0);
2201                     GvLINE(dstr) = PL_curcop->cop_line;
2202                     GvEGV(dstr) = (GV*)dstr;
2203                 }
2204                 GvMULTI_on(dstr);
2205                 switch (SvTYPE(sref)) {
2206                 case SVt_PVAV:
2207                     if (intro)
2208                         SAVESPTR(GvAV(dstr));
2209                     else
2210                         dref = (SV*)GvAV(dstr);
2211                     GvAV(dstr) = (AV*)sref;
2212                     if (PL_curcop->cop_stash != GvSTASH(dstr))
2213                         GvIMPORTED_AV_on(dstr);
2214                     break;
2215                 case SVt_PVHV:
2216                     if (intro)
2217                         SAVESPTR(GvHV(dstr));
2218                     else
2219                         dref = (SV*)GvHV(dstr);
2220                     GvHV(dstr) = (HV*)sref;
2221                     if (PL_curcop->cop_stash != GvSTASH(dstr))
2222                         GvIMPORTED_HV_on(dstr);
2223                     break;
2224                 case SVt_PVCV:
2225                     if (intro) {
2226                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2227                             SvREFCNT_dec(GvCV(dstr));
2228                             GvCV(dstr) = Nullcv;
2229                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2230                             PL_sub_generation++;
2231                         }
2232                         SAVESPTR(GvCV(dstr));
2233                     }
2234                     else
2235                         dref = (SV*)GvCV(dstr);
2236                     if (GvCV(dstr) != (CV*)sref) {
2237                         CV* cv = GvCV(dstr);
2238                         if (cv) {
2239                             if (!GvCVGEN((GV*)dstr) &&
2240                                 (CvROOT(cv) || CvXSUB(cv)))
2241                             {
2242                                 SV *const_sv = cv_const_sv(cv);
2243                                 bool const_changed = TRUE;
2244                                 if(const_sv)
2245                                     const_changed = sv_cmp(const_sv,
2246                                            op_const_sv(CvSTART((CV*)sref),
2247                                                        Nullcv));
2248                                 /* ahem, death to those who redefine
2249                                  * active sort subs */
2250                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2251                                       PL_sortcop == CvSTART(cv))
2252                                     Perl_croak(aTHX_
2253                                     "Can't redefine active sort subroutine %s",
2254                                           GvENAME((GV*)dstr));
2255                                 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2256                                     if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2257                                           && HvNAME(GvSTASH(CvGV(cv)))
2258                                           && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2259                                                    "autouse")))
2260                                         Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2261                                              "Constant subroutine %s redefined"
2262                                              : "Subroutine %s redefined",
2263                                              GvENAME((GV*)dstr));
2264                                 }
2265                             }
2266                             cv_ckproto(cv, (GV*)dstr,
2267                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
2268                         }
2269                         GvCV(dstr) = (CV*)sref;
2270                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2271                         GvASSUMECV_on(dstr);
2272                         PL_sub_generation++;
2273                     }
2274                     if (PL_curcop->cop_stash != GvSTASH(dstr))
2275                         GvIMPORTED_CV_on(dstr);
2276                     break;
2277                 case SVt_PVIO:
2278                     if (intro)
2279                         SAVESPTR(GvIOp(dstr));
2280                     else
2281                         dref = (SV*)GvIOp(dstr);
2282                     GvIOp(dstr) = (IO*)sref;
2283                     break;
2284                 default:
2285                     if (intro)
2286                         SAVESPTR(GvSV(dstr));
2287                     else
2288                         dref = (SV*)GvSV(dstr);
2289                     GvSV(dstr) = sref;
2290                     if (PL_curcop->cop_stash != GvSTASH(dstr))
2291                         GvIMPORTED_SV_on(dstr);
2292                     break;
2293                 }
2294                 if (dref)
2295                     SvREFCNT_dec(dref);
2296                 if (intro)
2297                     SAVEFREESV(sref);
2298                 SvTAINT(dstr);
2299                 return;
2300             }
2301             if (SvPVX(dstr)) {
2302                 (void)SvOOK_off(dstr);          /* backoff */
2303                 if (SvLEN(dstr))
2304                     Safefree(SvPVX(dstr));
2305                 SvLEN(dstr)=SvCUR(dstr)=0;
2306             }
2307         }
2308         (void)SvOK_off(dstr);
2309         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2310         SvROK_on(dstr);
2311         if (sflags & SVp_NOK) {
2312             SvNOK_on(dstr);
2313             SvNVX(dstr) = SvNVX(sstr);
2314         }
2315         if (sflags & SVp_IOK) {
2316             (void)SvIOK_on(dstr);
2317             SvIVX(dstr) = SvIVX(sstr);
2318             if (SvIsUV(sstr))
2319                 SvIsUV_on(dstr);
2320         }
2321         if (SvAMAGIC(sstr)) {
2322             SvAMAGIC_on(dstr);
2323         }
2324     }
2325     else if (sflags & SVp_POK) {
2326
2327         /*
2328          * Check to see if we can just swipe the string.  If so, it's a
2329          * possible small lose on short strings, but a big win on long ones.
2330          * It might even be a win on short strings if SvPVX(dstr)
2331          * has to be allocated and SvPVX(sstr) has to be freed.
2332          */
2333
2334         if (SvTEMP(sstr) &&             /* slated for free anyway? */
2335             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
2336             !(sflags & SVf_OOK))        /* and not involved in OOK hack? */
2337         {
2338             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
2339                 if (SvOOK(dstr)) {
2340                     SvFLAGS(dstr) &= ~SVf_OOK;
2341                     Safefree(SvPVX(dstr) - SvIVX(dstr));
2342                 }
2343                 else if (SvLEN(dstr))
2344                     Safefree(SvPVX(dstr));
2345             }
2346             (void)SvPOK_only(dstr);
2347             SvPV_set(dstr, SvPVX(sstr));
2348             SvLEN_set(dstr, SvLEN(sstr));
2349             SvCUR_set(dstr, SvCUR(sstr));
2350             SvTEMP_off(dstr);
2351             (void)SvOK_off(sstr);
2352             SvPV_set(sstr, Nullch);
2353             SvLEN_set(sstr, 0);
2354             SvCUR_set(sstr, 0);
2355             SvTEMP_off(sstr);
2356         }
2357         else {                                  /* have to copy actual string */
2358             STRLEN len = SvCUR(sstr);
2359
2360             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
2361             Move(SvPVX(sstr),SvPVX(dstr),len,char);
2362             SvCUR_set(dstr, len);
2363             *SvEND(dstr) = '\0';
2364             (void)SvPOK_only(dstr);
2365         }
2366         /*SUPPRESS 560*/
2367         if (sflags & SVp_NOK) {
2368             SvNOK_on(dstr);
2369             SvNVX(dstr) = SvNVX(sstr);
2370         }
2371         if (sflags & SVp_IOK) {
2372             (void)SvIOK_on(dstr);
2373             SvIVX(dstr) = SvIVX(sstr);
2374             if (SvIsUV(sstr))
2375                 SvIsUV_on(dstr);
2376         }
2377     }
2378     else if (sflags & SVp_NOK) {
2379         SvNVX(dstr) = SvNVX(sstr);
2380         (void)SvNOK_only(dstr);
2381         if (SvIOK(sstr)) {
2382             (void)SvIOK_on(dstr);
2383             SvIVX(dstr) = SvIVX(sstr);
2384             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
2385             if (SvIsUV(sstr))
2386                 SvIsUV_on(dstr);
2387         }
2388     }
2389     else if (sflags & SVp_IOK) {
2390         (void)SvIOK_only(dstr);
2391         SvIVX(dstr) = SvIVX(sstr);
2392         if (SvIsUV(sstr))
2393             SvIsUV_on(dstr);
2394     }
2395     else {
2396         if (dtype == SVt_PVGV) {
2397             if (ckWARN(WARN_UNSAFE))
2398                 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2399         }
2400         else
2401             (void)SvOK_off(dstr);
2402     }
2403     SvTAINT(dstr);
2404 }
2405
2406 void
2407 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2408 {
2409     sv_setsv(dstr,sstr);
2410     SvSETMAGIC(dstr);
2411 }
2412
2413 void
2414 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2415 {
2416     register char *dptr;
2417     assert(len >= 0);  /* STRLEN is probably unsigned, so this may
2418                           elicit a warning, but it won't hurt. */
2419     SV_CHECK_THINKFIRST(sv);
2420     if (!ptr) {
2421         (void)SvOK_off(sv);
2422         return;
2423     }
2424     (void)SvUPGRADE(sv, SVt_PV);
2425
2426     SvGROW(sv, len + 1);
2427     dptr = SvPVX(sv);
2428     Move(ptr,dptr,len,char);
2429     dptr[len] = '\0';
2430     SvCUR_set(sv, len);
2431     (void)SvPOK_only(sv);               /* validate pointer */
2432     SvTAINT(sv);
2433 }
2434
2435 void
2436 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2437 {
2438     sv_setpvn(sv,ptr,len);
2439     SvSETMAGIC(sv);
2440 }
2441
2442 void
2443 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2444 {
2445     register STRLEN len;
2446
2447     SV_CHECK_THINKFIRST(sv);
2448     if (!ptr) {
2449         (void)SvOK_off(sv);
2450         return;
2451     }
2452     len = strlen(ptr);
2453     (void)SvUPGRADE(sv, SVt_PV);
2454
2455     SvGROW(sv, len + 1);
2456     Move(ptr,SvPVX(sv),len+1,char);
2457     SvCUR_set(sv, len);
2458     (void)SvPOK_only(sv);               /* validate pointer */
2459     SvTAINT(sv);
2460 }
2461
2462 void
2463 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2464 {
2465     sv_setpv(sv,ptr);
2466     SvSETMAGIC(sv);
2467 }
2468
2469 void
2470 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2471 {
2472     SV_CHECK_THINKFIRST(sv);
2473     (void)SvUPGRADE(sv, SVt_PV);
2474     if (!ptr) {
2475         (void)SvOK_off(sv);
2476         return;
2477     }
2478     (void)SvOOK_off(sv);
2479     if (SvPVX(sv) && SvLEN(sv))
2480         Safefree(SvPVX(sv));
2481     Renew(ptr, len+1, char);
2482     SvPVX(sv) = ptr;
2483     SvCUR_set(sv, len);
2484     SvLEN_set(sv, len+1);
2485     *SvEND(sv) = '\0';
2486     (void)SvPOK_only(sv);               /* validate pointer */
2487     SvTAINT(sv);
2488 }
2489
2490 void
2491 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2492 {
2493     sv_usepvn(sv,ptr,len);
2494     SvSETMAGIC(sv);
2495 }
2496
2497 void
2498 Perl_sv_force_normal(pTHX_ register SV *sv)
2499 {
2500     if (SvREADONLY(sv)) {
2501         dTHR;
2502         if (PL_curcop != &PL_compiling)
2503             Perl_croak(aTHX_ PL_no_modify);
2504     }
2505     if (SvROK(sv))
2506         sv_unref(sv);
2507     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2508         sv_unglob(sv);
2509 }
2510
2511 void
2512 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2513
2514
2515 {
2516     register STRLEN delta;
2517
2518     if (!ptr || !SvPOKp(sv))
2519         return;
2520     SV_CHECK_THINKFIRST(sv);
2521     if (SvTYPE(sv) < SVt_PVIV)
2522         sv_upgrade(sv,SVt_PVIV);
2523
2524     if (!SvOOK(sv)) {
2525         if (!SvLEN(sv)) { /* make copy of shared string */
2526             char *pvx = SvPVX(sv);
2527             STRLEN len = SvCUR(sv);
2528             SvGROW(sv, len + 1);
2529             Move(pvx,SvPVX(sv),len,char);
2530             *SvEND(sv) = '\0';
2531         }
2532         SvIVX(sv) = 0;
2533         SvFLAGS(sv) |= SVf_OOK;
2534     }
2535     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2536     delta = ptr - SvPVX(sv);
2537     SvLEN(sv) -= delta;
2538     SvCUR(sv) -= delta;
2539     SvPVX(sv) += delta;
2540     SvIVX(sv) += delta;
2541 }
2542
2543 void
2544 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2545 {
2546     STRLEN tlen;
2547     char *junk;
2548
2549     junk = SvPV_force(sv, tlen);
2550     SvGROW(sv, tlen + len + 1);
2551     if (ptr == junk)
2552         ptr = SvPVX(sv);
2553     Move(ptr,SvPVX(sv)+tlen,len,char);
2554     SvCUR(sv) += len;
2555     *SvEND(sv) = '\0';
2556     (void)SvPOK_only(sv);               /* validate pointer */
2557     SvTAINT(sv);
2558 }
2559
2560 void
2561 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2562 {
2563     sv_catpvn(sv,ptr,len);
2564     SvSETMAGIC(sv);
2565 }
2566
2567 void
2568 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2569 {
2570     char *s;
2571     STRLEN len;
2572     if (!sstr)
2573         return;
2574     if (s = SvPV(sstr, len))
2575         sv_catpvn(dstr,s,len);
2576 }
2577
2578 void
2579 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2580 {
2581     sv_catsv(dstr,sstr);
2582     SvSETMAGIC(dstr);
2583 }
2584
2585 void
2586 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2587 {
2588     register STRLEN len;
2589     STRLEN tlen;
2590     char *junk;
2591
2592     if (!ptr)
2593         return;
2594     junk = SvPV_force(sv, tlen);
2595     len = strlen(ptr);
2596     SvGROW(sv, tlen + len + 1);
2597     if (ptr == junk)
2598         ptr = SvPVX(sv);
2599     Move(ptr,SvPVX(sv)+tlen,len+1,char);
2600     SvCUR(sv) += len;
2601     (void)SvPOK_only(sv);               /* validate pointer */
2602     SvTAINT(sv);
2603 }
2604
2605 void
2606 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2607 {
2608     sv_catpv(sv,ptr);
2609     SvSETMAGIC(sv);
2610 }
2611
2612 SV *
2613 Perl_newSV(pTHX_ STRLEN len)
2614 {
2615     register SV *sv;
2616
2617     new_SV(sv);
2618     if (len) {
2619         sv_upgrade(sv, SVt_PV);
2620         SvGROW(sv, len + 1);
2621     }
2622     return sv;
2623 }
2624
2625 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2626
2627 void
2628 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2629 {
2630     MAGIC* mg;
2631
2632     if (SvREADONLY(sv)) {
2633         dTHR;
2634         if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2635             Perl_croak(aTHX_ PL_no_modify);
2636     }
2637     if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2638         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2639             if (how == 't')
2640                 mg->mg_len |= 1;
2641             return;
2642         }
2643     }
2644     else {
2645         (void)SvUPGRADE(sv, SVt_PVMG);
2646     }
2647     Newz(702,mg, 1, MAGIC);
2648     mg->mg_moremagic = SvMAGIC(sv);
2649
2650     SvMAGIC(sv) = mg;
2651     if (!obj || obj == sv || how == '#' || how == 'r')
2652         mg->mg_obj = obj;
2653     else {
2654         dTHR;
2655         mg->mg_obj = SvREFCNT_inc(obj);
2656         mg->mg_flags |= MGf_REFCOUNTED;
2657     }
2658     mg->mg_type = how;
2659     mg->mg_len = namlen;
2660     if (name)
2661         if (namlen >= 0)
2662             mg->mg_ptr = savepvn(name, namlen);
2663         else if (namlen == HEf_SVKEY)
2664             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2665
2666     switch (how) {
2667     case 0:
2668         mg->mg_virtual = &PL_vtbl_sv;
2669         break;
2670     case 'A':
2671         mg->mg_virtual = &PL_vtbl_amagic;
2672         break;
2673     case 'a':
2674         mg->mg_virtual = &PL_vtbl_amagicelem;
2675         break;
2676     case 'c':
2677         mg->mg_virtual = 0;
2678         break;
2679     case 'B':
2680         mg->mg_virtual = &PL_vtbl_bm;
2681         break;
2682     case 'D':
2683         mg->mg_virtual = &PL_vtbl_regdata;
2684         break;
2685     case 'd':
2686         mg->mg_virtual = &PL_vtbl_regdatum;
2687         break;
2688     case 'E':
2689         mg->mg_virtual = &PL_vtbl_env;
2690         break;
2691     case 'f':
2692         mg->mg_virtual = &PL_vtbl_fm;
2693         break;
2694     case 'e':
2695         mg->mg_virtual = &PL_vtbl_envelem;
2696         break;
2697     case 'g':
2698         mg->mg_virtual = &PL_vtbl_mglob;
2699         break;
2700     case 'I':
2701         mg->mg_virtual = &PL_vtbl_isa;
2702         break;
2703     case 'i':
2704         mg->mg_virtual = &PL_vtbl_isaelem;
2705         break;
2706     case 'k':
2707         mg->mg_virtual = &PL_vtbl_nkeys;
2708         break;
2709     case 'L':
2710         SvRMAGICAL_on(sv);
2711         mg->mg_virtual = 0;
2712         break;
2713     case 'l':
2714         mg->mg_virtual = &PL_vtbl_dbline;
2715         break;
2716 #ifdef USE_THREADS
2717     case 'm':
2718         mg->mg_virtual = &PL_vtbl_mutex;
2719         break;
2720 #endif /* USE_THREADS */
2721 #ifdef USE_LOCALE_COLLATE
2722     case 'o':
2723         mg->mg_virtual = &PL_vtbl_collxfrm;
2724         break;
2725 #endif /* USE_LOCALE_COLLATE */
2726     case 'P':
2727         mg->mg_virtual = &PL_vtbl_pack;
2728         break;
2729     case 'p':
2730     case 'q':
2731         mg->mg_virtual = &PL_vtbl_packelem;
2732         break;
2733     case 'r':
2734         mg->mg_virtual = &PL_vtbl_regexp;
2735         break;
2736     case 'S':
2737         mg->mg_virtual = &PL_vtbl_sig;
2738         break;
2739     case 's':
2740         mg->mg_virtual = &PL_vtbl_sigelem;
2741         break;
2742     case 't':
2743         mg->mg_virtual = &PL_vtbl_taint;
2744         mg->mg_len = 1;
2745         break;
2746     case 'U':
2747         mg->mg_virtual = &PL_vtbl_uvar;
2748         break;
2749     case 'v':
2750         mg->mg_virtual = &PL_vtbl_vec;
2751         break;
2752     case 'x':
2753         mg->mg_virtual = &PL_vtbl_substr;
2754         break;
2755     case 'y':
2756         mg->mg_virtual = &PL_vtbl_defelem;
2757         break;
2758     case '*':
2759         mg->mg_virtual = &PL_vtbl_glob;
2760         break;
2761     case '#':
2762         mg->mg_virtual = &PL_vtbl_arylen;
2763         break;
2764     case '.':
2765         mg->mg_virtual = &PL_vtbl_pos;
2766         break;
2767     case '<':
2768         mg->mg_virtual = &PL_vtbl_backref;
2769         break;
2770     case '~':   /* Reserved for use by extensions not perl internals.   */
2771         /* Useful for attaching extension internal data to perl vars.   */
2772         /* Note that multiple extensions may clash if magical scalars   */
2773         /* etc holding private data from one are passed to another.     */
2774         SvRMAGICAL_on(sv);
2775         break;
2776     default:
2777         Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2778     }
2779     mg_magical(sv);
2780     if (SvGMAGICAL(sv))
2781         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2782 }
2783
2784 int
2785 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2786 {
2787     MAGIC* mg;
2788     MAGIC** mgp;
2789     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2790         return 0;
2791     mgp = &SvMAGIC(sv);
2792     for (mg = *mgp; mg; mg = *mgp) {
2793         if (mg->mg_type == type) {
2794             MGVTBL* vtbl = mg->mg_virtual;
2795             *mgp = mg->mg_moremagic;
2796             if (vtbl && (vtbl->svt_free != NULL))
2797                 (VTBL->svt_free)(aTHX_ sv, mg);
2798             if (mg->mg_ptr && mg->mg_type != 'g')
2799                 if (mg->mg_len >= 0)
2800                     Safefree(mg->mg_ptr);
2801                 else if (mg->mg_len == HEf_SVKEY)
2802                     SvREFCNT_dec((SV*)mg->mg_ptr);
2803             if (mg->mg_flags & MGf_REFCOUNTED)
2804                 SvREFCNT_dec(mg->mg_obj);
2805             Safefree(mg);
2806         }
2807         else
2808             mgp = &mg->mg_moremagic;
2809     }
2810     if (!SvMAGIC(sv)) {
2811         SvMAGICAL_off(sv);
2812         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2813     }
2814
2815     return 0;
2816 }
2817
2818 SV *
2819 Perl_sv_rvweaken(pTHX_ SV *sv)
2820 {
2821     SV *tsv;
2822     if (!SvOK(sv))  /* let undefs pass */
2823         return sv;
2824     if (!SvROK(sv))
2825         Perl_croak(aTHX_ "Can't weaken a nonreference");
2826     else if (SvWEAKREF(sv)) {
2827         dTHR;
2828         if (ckWARN(WARN_MISC))
2829             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2830         return sv;
2831     }
2832     tsv = SvRV(sv);
2833     sv_add_backref(tsv, sv);
2834     SvWEAKREF_on(sv);
2835     SvREFCNT_dec(tsv);
2836     return sv;
2837 }
2838
2839 STATIC void
2840 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2841 {
2842     AV *av;
2843     MAGIC *mg;
2844     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2845         av = (AV*)mg->mg_obj;
2846     else {
2847         av = newAV();
2848         sv_magic(tsv, (SV*)av, '<', NULL, 0);
2849         SvREFCNT_dec(av);           /* for sv_magic */
2850     }
2851     av_push(av,sv);
2852 }
2853
2854 STATIC void
2855 S_sv_del_backref(pTHX_ SV *sv)
2856 {
2857     AV *av;
2858     SV **svp;
2859     I32 i;
2860     SV *tsv = SvRV(sv);
2861     MAGIC *mg;
2862     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2863         Perl_croak(aTHX_ "panic: del_backref");
2864     av = (AV *)mg->mg_obj;
2865     svp = AvARRAY(av);
2866     i = AvFILLp(av);
2867     while (i >= 0) {
2868         if (svp[i] == sv) {
2869             svp[i] = &PL_sv_undef; /* XXX */
2870         }
2871         i--;
2872     }
2873 }
2874
2875 void
2876 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2877 {
2878     register char *big;
2879     register char *mid;
2880     register char *midend;
2881     register char *bigend;
2882     register I32 i;
2883     STRLEN curlen;
2884
2885
2886     if (!bigstr)
2887         Perl_croak(aTHX_ "Can't modify non-existent substring");
2888     SvPV_force(bigstr, curlen);
2889     if (offset + len > curlen) {
2890         SvGROW(bigstr, offset+len+1);
2891         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2892         SvCUR_set(bigstr, offset+len);
2893     }
2894
2895     i = littlelen - len;
2896     if (i > 0) {                        /* string might grow */
2897         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2898         mid = big + offset + len;
2899         midend = bigend = big + SvCUR(bigstr);
2900         bigend += i;
2901         *bigend = '\0';
2902         while (midend > mid)            /* shove everything down */
2903             *--bigend = *--midend;
2904         Move(little,big+offset,littlelen,char);
2905         SvCUR(bigstr) += i;
2906         SvSETMAGIC(bigstr);
2907         return;
2908     }
2909     else if (i == 0) {
2910         Move(little,SvPVX(bigstr)+offset,len,char);
2911         SvSETMAGIC(bigstr);
2912         return;
2913     }
2914
2915     big = SvPVX(bigstr);
2916     mid = big + offset;
2917     midend = mid + len;
2918     bigend = big + SvCUR(bigstr);
2919
2920     if (midend > bigend)
2921         Perl_croak(aTHX_ "panic: sv_insert");
2922
2923     if (mid - big > bigend - midend) {  /* faster to shorten from end */
2924         if (littlelen) {
2925             Move(little, mid, littlelen,char);
2926             mid += littlelen;
2927         }
2928         i = bigend - midend;
2929         if (i > 0) {
2930             Move(midend, mid, i,char);
2931             mid += i;
2932         }
2933         *mid = '\0';
2934         SvCUR_set(bigstr, mid - big);
2935     }
2936     /*SUPPRESS 560*/
2937     else if (i = mid - big) {   /* faster from front */
2938         midend -= littlelen;
2939         mid = midend;
2940         sv_chop(bigstr,midend-i);
2941         big += i;
2942         while (i--)
2943             *--midend = *--big;
2944         if (littlelen)
2945             Move(little, mid, littlelen,char);
2946     }
2947     else if (littlelen) {
2948         midend -= littlelen;
2949         sv_chop(bigstr,midend);
2950         Move(little,midend,littlelen,char);
2951     }
2952     else {
2953         sv_chop(bigstr,midend);
2954     }
2955     SvSETMAGIC(bigstr);
2956 }
2957
2958 /* make sv point to what nstr did */
2959
2960 void
2961 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2962 {
2963     U32 refcnt = SvREFCNT(sv);
2964     SV_CHECK_THINKFIRST(sv);
2965     if (SvREFCNT(nsv) != 1)
2966         Perl_warn(aTHX_ "Reference miscount in sv_replace()");
2967     if (SvMAGICAL(sv)) {
2968         if (SvMAGICAL(nsv))
2969             mg_free(nsv);
2970         else
2971             sv_upgrade(nsv, SVt_PVMG);
2972         SvMAGIC(nsv) = SvMAGIC(sv);
2973         SvFLAGS(nsv) |= SvMAGICAL(sv);
2974         SvMAGICAL_off(sv);
2975         SvMAGIC(sv) = 0;
2976     }
2977     SvREFCNT(sv) = 0;
2978     sv_clear(sv);
2979     assert(!SvREFCNT(sv));
2980     StructCopy(nsv,sv,SV);
2981     SvREFCNT(sv) = refcnt;
2982     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
2983     del_SV(nsv);
2984 }
2985
2986 void
2987 Perl_sv_clear(pTHX_ register SV *sv)
2988 {
2989     HV* stash;
2990     assert(sv);
2991     assert(SvREFCNT(sv) == 0);
2992
2993     if (SvOBJECT(sv)) {
2994         dTHR;
2995         if (PL_defstash) {              /* Still have a symbol table? */
2996             djSP;
2997             GV* destructor;
2998             SV tmpref;
2999
3000             Zero(&tmpref, 1, SV);
3001             sv_upgrade(&tmpref, SVt_RV);
3002             SvROK_on(&tmpref);
3003             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
3004             SvREFCNT(&tmpref) = 1;
3005
3006             do {
3007                 stash = SvSTASH(sv);
3008                 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3009                 if (destructor) {
3010                     ENTER;
3011                     PUSHSTACKi(PERLSI_DESTROY);
3012                     SvRV(&tmpref) = SvREFCNT_inc(sv);
3013                     EXTEND(SP, 2);
3014                     PUSHMARK(SP);
3015                     PUSHs(&tmpref);
3016                     PUTBACK;
3017                     call_sv((SV*)GvCV(destructor),
3018                             G_DISCARD|G_EVAL|G_KEEPERR);
3019                     SvREFCNT(sv)--;
3020                     POPSTACK;
3021                     SPAGAIN;
3022                     LEAVE;
3023                 }
3024             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3025
3026             del_XRV(SvANY(&tmpref));
3027
3028             if (SvREFCNT(sv)) {
3029                 if (PL_in_clean_objs)
3030                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3031                           HvNAME(stash));
3032                 /* DESTROY gave object new lease on life */
3033                 return;
3034             }
3035         }
3036
3037         if (SvOBJECT(sv)) {
3038             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
3039             SvOBJECT_off(sv);   /* Curse the object. */
3040             if (SvTYPE(sv) != SVt_PVIO)
3041                 --PL_sv_objcount;       /* XXX Might want something more general */
3042         }
3043     }
3044     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3045         mg_free(sv);
3046     stash = NULL;
3047     switch (SvTYPE(sv)) {
3048     case SVt_PVIO:
3049         if (IoIFP(sv) &&
3050             IoIFP(sv) != PerlIO_stdin() &&
3051             IoIFP(sv) != PerlIO_stdout() &&
3052             IoIFP(sv) != PerlIO_stderr())
3053         {
3054           io_close((IO*)sv);
3055         }
3056         if (IoDIRP(sv)) {
3057             PerlDir_close(IoDIRP(sv));
3058             IoDIRP(sv) = 0;
3059         }
3060         Safefree(IoTOP_NAME(sv));
3061         Safefree(IoFMT_NAME(sv));
3062         Safefree(IoBOTTOM_NAME(sv));
3063         /* FALL THROUGH */
3064     case SVt_PVBM:
3065         goto freescalar;
3066     case SVt_PVCV:
3067     case SVt_PVFM:
3068         cv_undef((CV*)sv);
3069         goto freescalar;
3070     case SVt_PVHV:
3071         hv_undef((HV*)sv);
3072         break;
3073     case SVt_PVAV:
3074         av_undef((AV*)sv);
3075         break;
3076     case SVt_PVLV:
3077         SvREFCNT_dec(LvTARG(sv));
3078         goto freescalar;
3079     case SVt_PVGV:
3080         gp_free((GV*)sv);
3081         Safefree(GvNAME(sv));
3082         /* cannot decrease stash refcount yet, as we might recursively delete
3083            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3084            of stash until current sv is completely gone.
3085            -- JohnPC, 27 Mar 1998 */
3086         stash = GvSTASH(sv);
3087         /* FALL THROUGH */
3088     case SVt_PVMG:
3089     case SVt_PVNV:
3090     case SVt_PVIV:
3091       freescalar:
3092         (void)SvOOK_off(sv);
3093         /* FALL THROUGH */
3094     case SVt_PV:
3095     case SVt_RV:
3096         if (SvROK(sv)) {
3097             if (SvWEAKREF(sv))
3098                 sv_del_backref(sv);
3099             else
3100                 SvREFCNT_dec(SvRV(sv));
3101         }
3102         else if (SvPVX(sv) && SvLEN(sv))
3103             Safefree(SvPVX(sv));
3104         break;
3105 /*
3106     case SVt_NV:
3107     case SVt_IV:
3108     case SVt_NULL:
3109         break;
3110 */
3111     }
3112
3113     switch (SvTYPE(sv)) {
3114     case SVt_NULL:
3115         break;
3116     case SVt_IV:
3117         del_XIV(SvANY(sv));
3118         break;
3119     case SVt_NV:
3120         del_XNV(SvANY(sv));
3121         break;
3122     case SVt_RV:
3123         del_XRV(SvANY(sv));
3124         break;
3125     case SVt_PV:
3126         del_XPV(SvANY(sv));
3127         break;
3128     case SVt_PVIV:
3129         del_XPVIV(SvANY(sv));
3130         break;
3131     case SVt_PVNV:
3132         del_XPVNV(SvANY(sv));
3133         break;
3134     case SVt_PVMG:
3135         del_XPVMG(SvANY(sv));
3136         break;
3137     case SVt_PVLV:
3138         del_XPVLV(SvANY(sv));
3139         break;
3140     case SVt_PVAV:
3141         del_XPVAV(SvANY(sv));
3142         break;
3143     case SVt_PVHV:
3144         del_XPVHV(SvANY(sv));
3145         break;
3146     case SVt_PVCV:
3147         del_XPVCV(SvANY(sv));
3148         break;
3149     case SVt_PVGV:
3150         del_XPVGV(SvANY(sv));
3151         /* code duplication for increased performance. */
3152         SvFLAGS(sv) &= SVf_BREAK;
3153         SvFLAGS(sv) |= SVTYPEMASK;
3154         /* decrease refcount of the stash that owns this GV, if any */
3155         if (stash)
3156             SvREFCNT_dec(stash);
3157         return; /* not break, SvFLAGS reset already happened */
3158     case SVt_PVBM:
3159         del_XPVBM(SvANY(sv));
3160         break;
3161     case SVt_PVFM:
3162         del_XPVFM(SvANY(sv));
3163         break;
3164     case SVt_PVIO:
3165         del_XPVIO(SvANY(sv));
3166         break;
3167     }
3168     SvFLAGS(sv) &= SVf_BREAK;
3169     SvFLAGS(sv) |= SVTYPEMASK;
3170 }
3171
3172 SV *
3173 Perl_sv_newref(pTHX_ SV *sv)
3174 {
3175     if (sv)
3176         ATOMIC_INC(SvREFCNT(sv));
3177     return sv;
3178 }
3179
3180 void
3181 Perl_sv_free(pTHX_ SV *sv)
3182 {
3183     int refcount_is_zero;
3184
3185     if (!sv)
3186         return;
3187     if (SvREFCNT(sv) == 0) {
3188         if (SvFLAGS(sv) & SVf_BREAK)
3189             return;
3190         if (PL_in_clean_all) /* All is fair */
3191             return;
3192         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3193             /* make sure SvREFCNT(sv)==0 happens very seldom */
3194             SvREFCNT(sv) = (~(U32)0)/2;
3195             return;
3196         }
3197         Perl_warn(aTHX_ "Attempt to free unreferenced scalar");
3198         return;
3199     }
3200     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3201     if (!refcount_is_zero)
3202         return;
3203 #ifdef DEBUGGING
3204     if (SvTEMP(sv)) {
3205         Perl_warn(aTHX_ "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3206         return;
3207     }
3208 #endif
3209     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3210         /* make sure SvREFCNT(sv)==0 happens very seldom */
3211         SvREFCNT(sv) = (~(U32)0)/2;
3212         return;
3213     }
3214     sv_clear(sv);
3215     if (! SvREFCNT(sv))
3216         del_SV(sv);
3217 }
3218
3219 STRLEN
3220 Perl_sv_len(pTHX_ register SV *sv)
3221 {
3222     char *junk;
3223     STRLEN len;
3224
3225     if (!sv)
3226         return 0;
3227
3228     if (SvGMAGICAL(sv))
3229         len = mg_length(sv);
3230     else
3231         junk = SvPV(sv, len);
3232     return len;
3233 }
3234
3235 STRLEN
3236 Perl_sv_len_utf8(pTHX_ register SV *sv)
3237 {
3238     U8 *s;
3239     U8 *send;
3240     STRLEN len;
3241
3242     if (!sv)
3243         return 0;
3244
3245 #ifdef NOTYET
3246     if (SvGMAGICAL(sv))
3247         len = mg_length(sv);
3248     else
3249 #endif
3250         s = (U8*)SvPV(sv, len);
3251     send = s + len;
3252     len = 0;
3253     while (s < send) {
3254         s += UTF8SKIP(s);
3255         len++;
3256     }
3257     return len;
3258 }
3259
3260 void
3261 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3262 {
3263     U8 *start;
3264     U8 *s;
3265     U8 *send;
3266     I32 uoffset = *offsetp;
3267     STRLEN len;
3268
3269     if (!sv)
3270         return;
3271
3272     start = s = (U8*)SvPV(sv, len);
3273     send = s + len;
3274     while (s < send && uoffset--)
3275         s += UTF8SKIP(s);
3276     if (s >= send)
3277         s = send;
3278     *offsetp = s - start;
3279     if (lenp) {
3280         I32 ulen = *lenp;
3281         start = s;
3282         while (s < send && ulen--)
3283             s += UTF8SKIP(s);
3284         if (s >= send)
3285             s = send;
3286         *lenp = s - start;
3287     }
3288     return;
3289 }
3290
3291 void
3292 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3293 {
3294     U8 *s;
3295     U8 *send;
3296     STRLEN len;
3297
3298     if (!sv)
3299         return;
3300
3301     s = (U8*)SvPV(sv, len);
3302     if (len < *offsetp)
3303         Perl_croak(aTHX_ "panic: bad byte offset");
3304     send = s + *offsetp;
3305     len = 0;
3306     while (s < send) {
3307         s += UTF8SKIP(s);
3308         ++len;
3309     }
3310     if (s != send) {
3311         Perl_warn(aTHX_ "Malformed UTF-8 character");
3312         --len;
3313     }
3314     *offsetp = len;
3315     return;
3316 }
3317
3318 I32
3319 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3320 {
3321     char *pv1;
3322     STRLEN cur1;
3323     char *pv2;
3324     STRLEN cur2;
3325
3326     if (!str1) {
3327         pv1 = "";
3328         cur1 = 0;
3329     }
3330     else
3331         pv1 = SvPV(str1, cur1);
3332
3333     if (!str2)
3334         return !cur1;
3335     else
3336         pv2 = SvPV(str2, cur2);
3337
3338     if (cur1 != cur2)
3339         return 0;
3340
3341     return memEQ(pv1, pv2, cur1);
3342 }
3343
3344 I32
3345 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3346 {
3347     STRLEN cur1 = 0;
3348     char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3349     STRLEN cur2 = 0;
3350     char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3351     I32 retval;
3352
3353     if (!cur1)
3354         return cur2 ? -1 : 0;
3355
3356     if (!cur2)
3357         return 1;
3358
3359     retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3360
3361     if (retval)
3362         return retval < 0 ? -1 : 1;
3363
3364     if (cur1 == cur2)
3365         return 0;
3366     else
3367         return cur1 < cur2 ? -1 : 1;
3368 }
3369
3370 I32
3371 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3372 {
3373 #ifdef USE_LOCALE_COLLATE
3374
3375     char *pv1, *pv2;
3376     STRLEN len1, len2;
3377     I32 retval;
3378
3379     if (PL_collation_standard)
3380         goto raw_compare;
3381
3382     len1 = 0;
3383     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3384     len2 = 0;
3385     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3386
3387     if (!pv1 || !len1) {
3388         if (pv2 && len2)
3389             return -1;
3390         else
3391             goto raw_compare;
3392     }
3393     else {
3394         if (!pv2 || !len2)
3395             return 1;
3396     }
3397
3398     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3399
3400     if (retval)
3401         return retval < 0 ? -1 : 1;
3402
3403     /*
3404      * When the result of collation is equality, that doesn't mean
3405      * that there are no differences -- some locales exclude some
3406      * characters from consideration.  So to avoid false equalities,
3407      * we use the raw string as a tiebreaker.
3408      */
3409
3410   raw_compare:
3411     /* FALL THROUGH */
3412
3413 #endif /* USE_LOCALE_COLLATE */
3414
3415     return sv_cmp(sv1, sv2);
3416 }
3417
3418 #ifdef USE_LOCALE_COLLATE
3419 /*
3420  * Any scalar variable may carry an 'o' magic that contains the
3421  * scalar data of the variable transformed to such a format that
3422  * a normal memory comparison can be used to compare the data
3423  * according to the locale settings.
3424  */
3425 char *
3426 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3427 {
3428     MAGIC *mg;
3429
3430     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3431     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3432         char *s, *xf;
3433         STRLEN len, xlen;
3434
3435         if (mg)
3436             Safefree(mg->mg_ptr);
3437         s = SvPV(sv, len);
3438         if ((xf = mem_collxfrm(s, len, &xlen))) {
3439             if (SvREADONLY(sv)) {
3440                 SAVEFREEPV(xf);
3441                 *nxp = xlen;
3442                 return xf + sizeof(PL_collation_ix);
3443             }
3444             if (! mg) {
3445                 sv_magic(sv, 0, 'o', 0, 0);
3446                 mg = mg_find(sv, 'o');
3447                 assert(mg);
3448             }
3449             mg->mg_ptr = xf;
3450             mg->mg_len = xlen;
3451         }
3452         else {
3453             if (mg) {
3454                 mg->mg_ptr = NULL;
3455                 mg->mg_len = -1;
3456             }
3457         }
3458     }
3459     if (mg && mg->mg_ptr) {
3460         *nxp = mg->mg_len;
3461         return mg->mg_ptr + sizeof(PL_collation_ix);
3462     }
3463     else {
3464         *nxp = 0;
3465         return NULL;
3466     }
3467 }
3468
3469 #endif /* USE_LOCALE_COLLATE */
3470
3471 char *
3472 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3473 {
3474     dTHR;
3475     char *rsptr;
3476     STRLEN rslen;
3477     register STDCHAR rslast;
3478     register STDCHAR *bp;
3479     register I32 cnt;
3480     I32 i;
3481
3482     SV_CHECK_THINKFIRST(sv);
3483     (void)SvUPGRADE(sv, SVt_PV);
3484
3485     SvSCREAM_off(sv);
3486
3487     if (RsSNARF(PL_rs)) {
3488         rsptr = NULL;
3489         rslen = 0;
3490     }
3491     else if (RsRECORD(PL_rs)) {
3492       I32 recsize, bytesread;
3493       char *buffer;
3494
3495       /* Grab the size of the record we're getting */
3496       recsize = SvIV(SvRV(PL_rs));
3497       (void)SvPOK_only(sv);    /* Validate pointer */
3498       buffer = SvGROW(sv, recsize + 1);
3499       /* Go yank in */
3500 #ifdef VMS
3501       /* VMS wants read instead of fread, because fread doesn't respect */
3502       /* RMS record boundaries. This is not necessarily a good thing to be */
3503       /* doing, but we've got no other real choice */
3504       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3505 #else
3506       bytesread = PerlIO_read(fp, buffer, recsize);
3507 #endif
3508       SvCUR_set(sv, bytesread);
3509       buffer[bytesread] = '\0';
3510       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3511     }
3512     else if (RsPARA(PL_rs)) {
3513         rsptr = "\n\n";
3514         rslen = 2;
3515     }
3516     else
3517         rsptr = SvPV(PL_rs, rslen);
3518     rslast = rslen ? rsptr[rslen - 1] : '\0';
3519
3520     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
3521         do {                    /* to make sure file boundaries work right */
3522             if (PerlIO_eof(fp))
3523                 return 0;
3524             i = PerlIO_getc(fp);
3525             if (i != '\n') {
3526                 if (i == -1)
3527                     return 0;
3528                 PerlIO_ungetc(fp,i);
3529                 break;
3530             }
3531         } while (i != EOF);
3532     }
3533
3534     /* See if we know enough about I/O mechanism to cheat it ! */
3535
3536     /* This used to be #ifdef test - it is made run-time test for ease
3537        of abstracting out stdio interface. One call should be cheap
3538        enough here - and may even be a macro allowing compile
3539        time optimization.
3540      */
3541
3542     if (PerlIO_fast_gets(fp)) {
3543
3544     /*
3545      * We're going to steal some values from the stdio struct
3546      * and put EVERYTHING in the innermost loop into registers.
3547      */
3548     register STDCHAR *ptr;
3549     STRLEN bpx;
3550     I32 shortbuffered;
3551
3552 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3553     /* An ungetc()d char is handled separately from the regular
3554      * buffer, so we getc() it back out and stuff it in the buffer.
3555      */
3556     i = PerlIO_getc(fp);
3557     if (i == EOF) return 0;
3558     *(--((*fp)->_ptr)) = (unsigned char) i;
3559     (*fp)->_cnt++;
3560 #endif
3561
3562     /* Here is some breathtakingly efficient cheating */
3563
3564     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
3565     (void)SvPOK_only(sv);               /* validate pointer */
3566     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3567         if (cnt > 80 && SvLEN(sv) > append) {
3568             shortbuffered = cnt - SvLEN(sv) + append + 1;
3569             cnt -= shortbuffered;
3570         }
3571         else {
3572             shortbuffered = 0;
3573             /* remember that cnt can be negative */
3574             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3575         }
3576     }
3577     else
3578         shortbuffered = 0;
3579     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
3580     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3581     DEBUG_P(PerlIO_printf(Perl_debug_log,
3582         "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3583     DEBUG_P(PerlIO_printf(Perl_debug_log,
3584         "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3585                (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3586                (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3587     for (;;) {
3588       screamer:
3589         if (cnt > 0) {
3590             if (rslen) {
3591                 while (cnt > 0) {                    /* this     |  eat */
3592                     cnt--;
3593                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
3594                         goto thats_all_folks;        /* screams  |  sed :-) */
3595                 }
3596             }
3597             else {
3598                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
3599                 bp += cnt;                           /* screams  |  dust */
3600                 ptr += cnt;                          /* louder   |  sed :-) */
3601                 cnt = 0;
3602             }
3603         }
3604
3605         if (shortbuffered) {            /* oh well, must extend */
3606             cnt = shortbuffered;
3607             shortbuffered = 0;
3608             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3609             SvCUR_set(sv, bpx);
3610             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3611             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3612             continue;
3613         }
3614
3615         DEBUG_P(PerlIO_printf(Perl_debug_log,
3616             "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3617         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3618         DEBUG_P(PerlIO_printf(Perl_debug_log,
3619             "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3620             (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3621             (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3622         /* This used to call 'filbuf' in stdio form, but as that behaves like
3623            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3624            another abstraction.  */
3625         i   = PerlIO_getc(fp);          /* get more characters */
3626         DEBUG_P(PerlIO_printf(Perl_debug_log,
3627             "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3628             (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3629             (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3630         cnt = PerlIO_get_cnt(fp);
3631         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
3632         DEBUG_P(PerlIO_printf(Perl_debug_log,
3633             "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3634
3635         if (i == EOF)                   /* all done for ever? */
3636             goto thats_really_all_folks;
3637
3638         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3639         SvCUR_set(sv, bpx);
3640         SvGROW(sv, bpx + cnt + 2);
3641         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3642
3643         *bp++ = i;                      /* store character from PerlIO_getc */
3644
3645         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
3646             goto thats_all_folks;
3647     }
3648
3649 thats_all_folks:
3650     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3651           memNE((char*)bp - rslen, rsptr, rslen))
3652         goto screamer;                          /* go back to the fray */
3653 thats_really_all_folks:
3654     if (shortbuffered)
3655         cnt += shortbuffered;
3656         DEBUG_P(PerlIO_printf(Perl_debug_log,
3657             "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3658     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
3659     DEBUG_P(PerlIO_printf(Perl_debug_log,
3660         "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3661         (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3662         (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3663     *bp = '\0';
3664     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
3665     DEBUG_P(PerlIO_printf(Perl_debug_log,
3666         "Screamer: done, len=%ld, string=|%.*s|\n",
3667         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3668     }
3669    else
3670     {
3671 #ifndef EPOC
3672        /*The big, slow, and stupid way */
3673         STDCHAR buf[8192];
3674 #else
3675         /* Need to work around EPOC SDK features          */
3676         /* On WINS: MS VC5 generates calls to _chkstk,    */
3677         /* if a `large' stack frame is allocated          */
3678         /* gcc on MARM does not generate calls like these */
3679         STDCHAR buf[1024];
3680 #endif
3681
3682 screamer2:
3683         if (rslen) {
3684             register STDCHAR *bpe = buf + sizeof(buf);
3685             bp = buf;
3686             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3687                 ; /* keep reading */
3688             cnt = bp - buf;
3689         }
3690         else {
3691             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3692             /* Accomodate broken VAXC compiler, which applies U8 cast to
3693              * both args of ?: operator, causing EOF to change into 255
3694              */
3695             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3696         }
3697
3698         if (append)
3699             sv_catpvn(sv, (char *) buf, cnt);
3700         else
3701             sv_setpvn(sv, (char *) buf, cnt);
3702
3703         if (i != EOF &&                 /* joy */
3704             (!rslen ||
3705              SvCUR(sv) < rslen ||
3706              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3707         {
3708             append = -1;
3709             /*
3710              * If we're reading from a TTY and we get a short read,
3711              * indicating that the user hit his EOF character, we need
3712              * to notice it now, because if we try to read from the TTY
3713              * again, the EOF condition will disappear.
3714              *
3715              * The comparison of cnt to sizeof(buf) is an optimization
3716              * that prevents unnecessary calls to feof().
3717              *
3718              * - jik 9/25/96
3719              */
3720             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3721                 goto screamer2;
3722         }
3723     }
3724
3725     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
3726         while (i != EOF) {      /* to make sure file boundaries work right */
3727             i = PerlIO_getc(fp);
3728             if (i != '\n') {
3729                 PerlIO_ungetc(fp,i);
3730                 break;
3731             }
3732         }
3733     }
3734
3735 #ifdef WIN32
3736     win32_strip_return(sv);
3737 #endif
3738
3739     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3740 }
3741
3742
3743 void
3744 Perl_sv_inc(pTHX_ register SV *sv)
3745 {
3746     register char *d;
3747     int flags;
3748
3749     if (!sv)
3750         return;
3751     if (SvGMAGICAL(sv))
3752         mg_get(sv);
3753     if (SvTHINKFIRST(sv)) {
3754         if (SvREADONLY(sv)) {
3755             dTHR;
3756             if (PL_curcop != &PL_compiling)
3757                 Perl_croak(aTHX_ PL_no_modify);
3758         }
3759         if (SvROK(sv)) {
3760             IV i;
3761             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3762                 return;
3763             i = (IV)SvRV(sv);
3764             sv_unref(sv);
3765             sv_setiv(sv, i);
3766         }
3767     }
3768     flags = SvFLAGS(sv);
3769     if (flags & SVp_NOK) {
3770         (void)SvNOK_only(sv);
3771         SvNVX(sv) += 1.0;
3772         return;
3773     }
3774     if (flags & SVp_IOK) {
3775         if (SvIsUV(sv)) {
3776             if (SvUVX(sv) == UV_MAX)
3777                 sv_setnv(sv, (NV)UV_MAX + 1.0);
3778             else
3779                 (void)SvIOK_only_UV(sv);
3780                 ++SvUVX(sv);
3781         } else {
3782             if (SvIVX(sv) == IV_MAX)
3783                 sv_setnv(sv, (NV)IV_MAX + 1.0);
3784             else {
3785                 (void)SvIOK_only(sv);
3786                 ++SvIVX(sv);
3787             }
3788         }
3789         return;
3790     }
3791     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3792         if ((flags & SVTYPEMASK) < SVt_PVNV)
3793             sv_upgrade(sv, SVt_NV);
3794         SvNVX(sv) = 1.0;
3795         (void)SvNOK_only(sv);
3796         return;
3797     }
3798     d = SvPVX(sv);
3799     while (isALPHA(*d)) d++;
3800     while (isDIGIT(*d)) d++;
3801     if (*d) {
3802         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
3803         return;
3804     }
3805     d--;
3806     while (d >= SvPVX(sv)) {
3807         if (isDIGIT(*d)) {
3808             if (++*d <= '9')
3809                 return;
3810             *(d--) = '0';
3811         }
3812         else {
3813 #ifdef EBCDIC
3814             /* MKS: The original code here died if letters weren't consecutive.
3815              * at least it didn't have to worry about non-C locales.  The
3816              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3817              * arranged in order (although not consecutively) and that only
3818              * [A-Za-z] are accepted by isALPHA in the C locale.
3819              */
3820             if (*d != 'z' && *d != 'Z') {
3821                 do { ++*d; } while (!isALPHA(*d));
3822                 return;
3823             }
3824             *(d--) -= 'z' - 'a';
3825 #else
3826             ++*d;
3827             if (isALPHA(*d))
3828                 return;
3829             *(d--) -= 'z' - 'a' + 1;
3830 #endif
3831         }
3832     }
3833     /* oh,oh, the number grew */
3834     SvGROW(sv, SvCUR(sv) + 2);
3835     SvCUR(sv)++;
3836     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3837         *d = d[-1];
3838     if (isDIGIT(d[1]))
3839         *d = '1';
3840     else
3841         *d = d[1];
3842 }
3843
3844 void
3845 Perl_sv_dec(pTHX_ register SV *sv)
3846 {
3847     int flags;
3848
3849     if (!sv)
3850         return;
3851     if (SvGMAGICAL(sv))
3852         mg_get(sv);
3853     if (SvTHINKFIRST(sv)) {
3854         if (SvREADONLY(sv)) {
3855             dTHR;
3856             if (PL_curcop != &PL_compiling)
3857                 Perl_croak(aTHX_ PL_no_modify);
3858         }
3859         if (SvROK(sv)) {
3860             IV i;
3861             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3862                 return;
3863             i = (IV)SvRV(sv);
3864             sv_unref(sv);
3865             sv_setiv(sv, i);
3866         }
3867     }
3868     flags = SvFLAGS(sv);
3869     if (flags & SVp_NOK) {
3870         SvNVX(sv) -= 1.0;
3871         (void)SvNOK_only(sv);
3872         return;
3873     }
3874     if (flags & SVp_IOK) {
3875         if (SvIsUV(sv)) {
3876             if (SvUVX(sv) == 0) {
3877                 (void)SvIOK_only(sv);
3878                 SvIVX(sv) = -1;
3879             }
3880             else {
3881                 (void)SvIOK_only_UV(sv);
3882                 --SvUVX(sv);
3883             }
3884         } else {
3885             if (SvIVX(sv) == IV_MIN)
3886                 sv_setnv(sv, (NV)IV_MIN - 1.0);
3887             else {
3888                 (void)SvIOK_only(sv);
3889                 --SvIVX(sv);
3890             }
3891         }
3892         return;
3893     }
3894     if (!(flags & SVp_POK)) {
3895         if ((flags & SVTYPEMASK) < SVt_PVNV)
3896             sv_upgrade(sv, SVt_NV);
3897         SvNVX(sv) = -1.0;
3898         (void)SvNOK_only(sv);
3899         return;
3900     }
3901     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3902 }
3903
3904 /* Make a string that will exist for the duration of the expression
3905  * evaluation.  Actually, it may have to last longer than that, but
3906  * hopefully we won't free it until it has been assigned to a
3907  * permanent location. */
3908
3909 SV *
3910 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3911 {
3912     dTHR;
3913     register SV *sv;
3914
3915     new_SV(sv);
3916     sv_setsv(sv,oldstr);
3917     EXTEND_MORTAL(1);
3918     PL_tmps_stack[++PL_tmps_ix] = sv;
3919     SvTEMP_on(sv);
3920     return sv;
3921 }
3922
3923 SV *
3924 Perl_sv_newmortal(pTHX)
3925 {
3926     dTHR;
3927     register SV *sv;
3928
3929     new_SV(sv);
3930     SvFLAGS(sv) = SVs_TEMP;
3931     EXTEND_MORTAL(1);
3932     PL_tmps_stack[++PL_tmps_ix] = sv;
3933     return sv;
3934 }
3935
3936 /* same thing without the copying */
3937
3938 SV *
3939 Perl_sv_2mortal(pTHX_ register SV *sv)
3940 {
3941     dTHR;
3942     if (!sv)
3943         return sv;
3944     if (SvREADONLY(sv) && SvIMMORTAL(sv))
3945         return sv;
3946     EXTEND_MORTAL(1);
3947     PL_tmps_stack[++PL_tmps_ix] = sv;
3948     SvTEMP_on(sv);
3949     return sv;
3950 }
3951
3952 SV *
3953 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3954 {
3955     register SV *sv;
3956
3957     new_SV(sv);
3958     if (!len)
3959         len = strlen(s);
3960     sv_setpvn(sv,s,len);
3961     return sv;
3962 }
3963
3964 SV *
3965 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3966 {
3967     register SV *sv;
3968
3969     new_SV(sv);
3970     sv_setpvn(sv,s,len);
3971     return sv;
3972 }
3973
3974 #if defined(PERL_IMPLICIT_CONTEXT)
3975 SV *
3976 Perl_newSVpvf_nocontext(const char* pat, ...)
3977 {
3978     dTHX;
3979     register SV *sv;
3980     va_list args;
3981
3982     new_SV(sv);
3983     va_start(args, pat);
3984     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3985     va_end(args);
3986     return sv;
3987 }
3988 #endif
3989
3990 SV *
3991 Perl_newSVpvf(pTHX_ const char* pat, ...)
3992 {
3993     register SV *sv;
3994     va_list args;
3995
3996     new_SV(sv);
3997     va_start(args, pat);
3998     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3999     va_end(args);
4000     return sv;
4001 }
4002
4003 SV *
4004 Perl_newSVnv(pTHX_ NV n)
4005 {
4006     register SV *sv;
4007
4008     new_SV(sv);
4009     sv_setnv(sv,n);
4010     return sv;
4011 }
4012
4013 SV *
4014 Perl_newSViv(pTHX_ IV i)
4015 {
4016     register SV *sv;
4017
4018     new_SV(sv);
4019     sv_setiv(sv,i);
4020     return sv;
4021 }
4022
4023 SV *
4024 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4025 {
4026     dTHR;
4027     register SV *sv;
4028
4029     new_SV(sv);
4030     sv_upgrade(sv, SVt_RV);
4031     SvTEMP_off(tmpRef);
4032     SvRV(sv) = tmpRef;
4033     SvROK_on(sv);
4034     return sv;
4035 }
4036
4037 SV *
4038 Perl_newRV(pTHX_ SV *tmpRef)
4039 {
4040     return newRV_noinc(SvREFCNT_inc(tmpRef));
4041 }
4042
4043 /* make an exact duplicate of old */
4044
4045 SV *
4046 Perl_newSVsv(pTHX_ register SV *old)
4047 {
4048     register SV *sv;
4049
4050     if (!old)
4051         return Nullsv;
4052     if (SvTYPE(old) == SVTYPEMASK) {
4053         Perl_warn(aTHX_ "semi-panic: attempt to dup freed string");
4054         return Nullsv;
4055     }
4056     new_SV(sv);
4057     if (SvTEMP(old)) {
4058         SvTEMP_off(old);
4059         sv_setsv(sv,old);
4060         SvTEMP_on(old);
4061     }
4062     else
4063         sv_setsv(sv,old);
4064     return sv;
4065 }
4066
4067 void
4068 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4069 {
4070     register HE *entry;
4071     register GV *gv;
4072     register SV *sv;
4073     register I32 i;
4074     register PMOP *pm;
4075     register I32 max;
4076     char todo[256];
4077
4078     if (!stash)
4079         return;
4080
4081     if (!*s) {          /* reset ?? searches */
4082         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4083             pm->op_pmdynflags &= ~PMdf_USED;
4084         }
4085         return;
4086     }
4087
4088     /* reset variables */
4089
4090     if (!HvARRAY(stash))
4091         return;
4092
4093     Zero(todo, 256, char);
4094     while (*s) {
4095         i = *s;
4096         if (s[1] == '-') {
4097             s += 2;
4098         }
4099         max = *s++;
4100         for ( ; i <= max; i++) {
4101             todo[i] = 1;
4102         }
4103         for (i = 0; i <= (I32) HvMAX(stash); i++) {
4104             for (entry = HvARRAY(stash)[i];
4105                  entry;
4106                  entry = HeNEXT(entry))
4107             {
4108                 if (!todo[(U8)*HeKEY(entry)])
4109                     continue;
4110                 gv = (GV*)HeVAL(entry);
4111                 sv = GvSV(gv);
4112                 if (SvTHINKFIRST(sv)) {
4113                     if (!SvREADONLY(sv) && SvROK(sv))
4114                         sv_unref(sv);
4115                     continue;
4116                 }
4117                 (void)SvOK_off(sv);
4118                 if (SvTYPE(sv) >= SVt_PV) {
4119                     SvCUR_set(sv, 0);
4120                     if (SvPVX(sv) != Nullch)
4121                         *SvPVX(sv) = '\0';
4122                     SvTAINT(sv);
4123                 }
4124                 if (GvAV(gv)) {
4125                     av_clear(GvAV(gv));
4126                 }
4127                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4128                     hv_clear(GvHV(gv));
4129 #ifndef VMS  /* VMS has no environ array */
4130                     if (gv == PL_envgv)
4131                         environ[0] = Nullch;
4132 #endif
4133                 }
4134             }
4135         }
4136     }
4137 }
4138
4139 IO*
4140 Perl_sv_2io(pTHX_ SV *sv)
4141 {
4142     IO* io;
4143     GV* gv;
4144     STRLEN n_a;
4145
4146     switch (SvTYPE(sv)) {
4147     case SVt_PVIO:
4148         io = (IO*)sv;
4149         break;
4150     case SVt_PVGV:
4151         gv = (GV*)sv;
4152         io = GvIO(gv);
4153         if (!io)
4154             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4155         break;
4156     default:
4157         if (!SvOK(sv))
4158             Perl_croak(aTHX_ PL_no_usym, "filehandle");
4159         if (SvROK(sv))
4160             return sv_2io(SvRV(sv));
4161         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4162         if (gv)
4163             io = GvIO(gv);
4164         else
4165             io = 0;
4166         if (!io)
4167             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4168         break;
4169     }
4170     return io;
4171 }
4172
4173 CV *
4174 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4175 {
4176     GV *gv;
4177     CV *cv;
4178     STRLEN n_a;
4179
4180     if (!sv)
4181         return *gvp = Nullgv, Nullcv;
4182     switch (SvTYPE(sv)) {
4183     case SVt_PVCV:
4184         *st = CvSTASH(sv);
4185         *gvp = Nullgv;
4186         return (CV*)sv;
4187     case SVt_PVHV:
4188     case SVt_PVAV:
4189         *gvp = Nullgv;
4190         return Nullcv;
4191     case SVt_PVGV:
4192         gv = (GV*)sv;
4193         *gvp = gv;
4194         *st = GvESTASH(gv);
4195         goto fix_gv;
4196
4197     default:
4198         if (SvGMAGICAL(sv))
4199             mg_get(sv);
4200         if (SvROK(sv)) {
4201             dTHR;
4202             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
4203             tryAMAGICunDEREF(to_cv);
4204
4205             sv = SvRV(sv);
4206             if (SvTYPE(sv) == SVt_PVCV) {
4207                 cv = (CV*)sv;
4208                 *gvp = Nullgv;
4209                 *st = CvSTASH(cv);
4210                 return cv;
4211             }
4212             else if(isGV(sv))
4213                 gv = (GV*)sv;
4214             else
4215                 Perl_croak(aTHX_ "Not a subroutine reference");
4216         }
4217         else if (isGV(sv))
4218             gv = (GV*)sv;
4219         else
4220             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4221         *gvp = gv;
4222         if (!gv)
4223             return Nullcv;
4224         *st = GvESTASH(gv);
4225     fix_gv:
4226         if (lref && !GvCVu(gv)) {
4227             SV *tmpsv;
4228             ENTER;
4229             tmpsv = NEWSV(704,0);
4230             gv_efullname3(tmpsv, gv, Nullch);
4231             /* XXX this is probably not what they think they're getting.
4232              * It has the same effect as "sub name;", i.e. just a forward
4233              * declaration! */
4234             newSUB(start_subparse(FALSE, 0),
4235                    newSVOP(OP_CONST, 0, tmpsv),
4236                    Nullop,
4237                    Nullop);
4238             LEAVE;
4239             if (!GvCVu(gv))
4240                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4241         }
4242         return GvCVu(gv);
4243     }
4244 }
4245
4246 I32
4247 Perl_sv_true(pTHX_ register SV *sv)
4248 {
4249     dTHR;
4250     if (!sv)
4251         return 0;
4252     if (SvPOK(sv)) {
4253         register XPV* tXpv;
4254         if ((tXpv = (XPV*)SvANY(sv)) &&
4255                 (*tXpv->xpv_pv > '0' ||
4256                 tXpv->xpv_cur > 1 ||
4257                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4258             return 1;
4259         else
4260             return 0;
4261     }
4262     else {
4263         if (SvIOK(sv))
4264             return SvIVX(sv) != 0;
4265         else {
4266             if (SvNOK(sv))
4267                 return SvNVX(sv) != 0.0;
4268             else
4269                 return sv_2bool(sv);
4270         }
4271     }
4272 }
4273
4274 IV
4275 Perl_sv_iv(pTHX_ register SV *sv)
4276 {
4277     if (SvIOK(sv)) {
4278         if (SvIsUV(sv))
4279             return (IV)SvUVX(sv);
4280         return SvIVX(sv);
4281     }
4282     return sv_2iv(sv);
4283 }
4284
4285 UV
4286 Perl_sv_uv(pTHX_ register SV *sv)
4287 {
4288     if (SvIOK(sv)) {
4289         if (SvIsUV(sv))
4290             return SvUVX(sv);
4291         return (UV)SvIVX(sv);
4292     }
4293     return sv_2uv(sv);
4294 }
4295
4296 NV
4297 Perl_sv_nv(pTHX_ register SV *sv)
4298 {
4299     if (SvNOK(sv))
4300         return SvNVX(sv);
4301     return sv_2nv(sv);
4302 }
4303
4304 char *
4305 Perl_sv_pv(pTHX_ SV *sv)
4306 {
4307     STRLEN n_a;
4308
4309     if (SvPOK(sv))
4310         return SvPVX(sv);
4311
4312     return sv_2pv(sv, &n_a);
4313 }
4314
4315 char *
4316 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4317 {
4318     if (SvPOK(sv)) {
4319         *lp = SvCUR(sv);
4320         return SvPVX(sv);
4321     }
4322     return sv_2pv(sv, lp);
4323 }
4324
4325 char *
4326 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4327 {
4328     char *s;
4329
4330     if (SvTHINKFIRST(sv) && !SvROK(sv))
4331         sv_force_normal(sv);
4332
4333     if (SvPOK(sv)) {
4334         *lp = SvCUR(sv);
4335     }
4336     else {
4337         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4338             dTHR;
4339             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4340                 PL_op_name[PL_op->op_type]);
4341         }
4342         else
4343             s = sv_2pv(sv, lp);
4344         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
4345             STRLEN len = *lp;
4346
4347             if (SvROK(sv))
4348                 sv_unref(sv);
4349             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
4350             SvGROW(sv, len + 1);
4351             Move(s,SvPVX(sv),len,char);
4352             SvCUR_set(sv, len);
4353             *SvEND(sv) = '\0';
4354         }
4355         if (!SvPOK(sv)) {
4356             SvPOK_on(sv);               /* validate pointer */
4357             SvTAINT(sv);
4358             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4359                 (unsigned long)sv,SvPVX(sv)));
4360         }
4361     }
4362     return SvPVX(sv);
4363 }
4364
4365 char *
4366 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4367 {
4368     if (ob && SvOBJECT(sv))
4369         return HvNAME(SvSTASH(sv));
4370     else {
4371         switch (SvTYPE(sv)) {
4372         case SVt_NULL:
4373         case SVt_IV:
4374         case SVt_NV:
4375         case SVt_RV:
4376         case SVt_PV:
4377         case SVt_PVIV:
4378         case SVt_PVNV:
4379         case SVt_PVMG:
4380         case SVt_PVBM:
4381                                 if (SvROK(sv))
4382                                     return "REF";
4383                                 else
4384                                     return "SCALAR";
4385         case SVt_PVLV:          return "LVALUE";
4386         case SVt_PVAV:          return "ARRAY";
4387         case SVt_PVHV:          return "HASH";
4388         case SVt_PVCV:          return "CODE";
4389         case SVt_PVGV:          return "GLOB";
4390         case SVt_PVFM:          return "FORMAT";
4391         default:                return "UNKNOWN";
4392         }
4393     }
4394 }
4395
4396 int
4397 Perl_sv_isobject(pTHX_ SV *sv)
4398 {
4399     if (!sv)
4400         return 0;
4401     if (SvGMAGICAL(sv))
4402         mg_get(sv);
4403     if (!SvROK(sv))
4404         return 0;
4405     sv = (SV*)SvRV(sv);
4406     if (!SvOBJECT(sv))
4407         return 0;
4408     return 1;
4409 }
4410
4411 int
4412 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4413 {
4414     if (!sv)
4415         return 0;
4416     if (SvGMAGICAL(sv))
4417         mg_get(sv);
4418     if (!SvROK(sv))
4419         return 0;
4420     sv = (SV*)SvRV(sv);
4421     if (!SvOBJECT(sv))
4422         return 0;
4423
4424     return strEQ(HvNAME(SvSTASH(sv)), name);
4425 }
4426
4427 SV*
4428 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4429 {
4430     dTHR;
4431     SV *sv;
4432
4433     new_SV(sv);
4434
4435     SV_CHECK_THINKFIRST(rv);
4436     SvAMAGIC_off(rv);
4437
4438     if (SvTYPE(rv) < SVt_RV)
4439       sv_upgrade(rv, SVt_RV);
4440
4441     (void)SvOK_off(rv);
4442     SvRV(rv) = sv;
4443     SvROK_on(rv);
4444
4445     if (classname) {
4446         HV* stash = gv_stashpv(classname, TRUE);
4447         (void)sv_bless(rv, stash);
4448     }
4449     return sv;
4450 }
4451
4452 SV*
4453 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4454 {
4455     if (!pv) {
4456         sv_setsv(rv, &PL_sv_undef);
4457         SvSETMAGIC(rv);
4458     }
4459     else
4460         sv_setiv(newSVrv(rv,classname), (IV)pv);
4461     return rv;
4462 }
4463
4464 SV*
4465 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4466 {
4467     sv_setiv(newSVrv(rv,classname), iv);
4468     return rv;
4469 }
4470
4471 SV*
4472 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4473 {
4474     sv_setnv(newSVrv(rv,classname), nv);
4475     return rv;
4476 }
4477
4478 SV*
4479 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4480 {
4481     sv_setpvn(newSVrv(rv,classname), pv, n);
4482     return rv;
4483 }
4484
4485 SV*
4486 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4487 {
4488     dTHR;
4489     SV *tmpRef;
4490     if (!SvROK(sv))
4491         Perl_croak(aTHX_ "Can't bless non-reference value");
4492     tmpRef = SvRV(sv);
4493     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4494         if (SvREADONLY(tmpRef))
4495             Perl_croak(aTHX_ PL_no_modify);
4496         if (SvOBJECT(tmpRef)) {
4497             if (SvTYPE(tmpRef) != SVt_PVIO)
4498                 --PL_sv_objcount;
4499             SvREFCNT_dec(SvSTASH(tmpRef));
4500         }
4501     }
4502     SvOBJECT_on(tmpRef);
4503     if (SvTYPE(tmpRef) != SVt_PVIO)
4504         ++PL_sv_objcount;
4505     (void)SvUPGRADE(tmpRef, SVt_PVMG);
4506     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4507
4508     if (Gv_AMG(stash))
4509         SvAMAGIC_on(sv);
4510     else
4511         SvAMAGIC_off(sv);
4512
4513     return sv;
4514 }
4515
4516 STATIC void
4517 S_sv_unglob(pTHX_ SV *sv)
4518 {
4519     assert(SvTYPE(sv) == SVt_PVGV);
4520     SvFAKE_off(sv);
4521     if (GvGP(sv))
4522         gp_free((GV*)sv);
4523     if (GvSTASH(sv)) {
4524         SvREFCNT_dec(GvSTASH(sv));
4525         GvSTASH(sv) = Nullhv;
4526     }
4527     sv_unmagic(sv, '*');
4528     Safefree(GvNAME(sv));
4529     GvMULTI_off(sv);
4530     SvFLAGS(sv) &= ~SVTYPEMASK;
4531     SvFLAGS(sv) |= SVt_PVMG;
4532 }
4533
4534 void
4535 Perl_sv_unref(pTHX_ SV *sv)
4536 {
4537     SV* rv = SvRV(sv);
4538
4539     if (SvWEAKREF(sv)) {
4540         sv_del_backref(sv);
4541         SvWEAKREF_off(sv);
4542         SvRV(sv) = 0;
4543         return;
4544     }
4545     SvRV(sv) = 0;
4546     SvROK_off(sv);
4547     if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4548         SvREFCNT_dec(rv);
4549     else
4550         sv_2mortal(rv);         /* Schedule for freeing later */
4551 }
4552
4553 void
4554 Perl_sv_taint(pTHX_ SV *sv)
4555 {
4556     sv_magic((sv), Nullsv, 't', Nullch, 0);
4557 }
4558
4559 void
4560 Perl_sv_untaint(pTHX_ SV *sv)
4561 {
4562     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4563         MAGIC *mg = mg_find(sv, 't');
4564         if (mg)
4565             mg->mg_len &= ~1;
4566     }
4567 }
4568
4569 bool
4570 Perl_sv_tainted(pTHX_ SV *sv)
4571 {
4572     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4573         MAGIC *mg = mg_find(sv, 't');
4574         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4575             return TRUE;
4576     }
4577     return FALSE;
4578 }
4579
4580 void
4581 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4582 {
4583     char buf[TYPE_CHARS(UV)];
4584     char *ebuf;
4585     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4586
4587     sv_setpvn(sv, ptr, ebuf - ptr);
4588 }
4589
4590
4591 void
4592 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4593 {
4594     char buf[TYPE_CHARS(UV)];
4595     char *ebuf;
4596     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4597
4598     sv_setpvn(sv, ptr, ebuf - ptr);
4599     SvSETMAGIC(sv);
4600 }
4601
4602 #if defined(PERL_IMPLICIT_CONTEXT)
4603 void
4604 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4605 {
4606     dTHX;
4607     va_list args;
4608     va_start(args, pat);
4609     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4610     va_end(args);
4611 }
4612
4613
4614 void
4615 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4616 {
4617     dTHX;
4618     va_list args;
4619     va_start(args, pat);
4620     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4621     va_end(args);
4622     SvSETMAGIC(sv);
4623 }
4624 #endif
4625
4626 void
4627 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4628 {
4629     va_list args;
4630     va_start(args, pat);
4631     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4632     va_end(args);
4633 }
4634
4635
4636 void
4637 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4638 {
4639     va_list args;
4640     va_start(args, pat);
4641     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4642     va_end(args);
4643     SvSETMAGIC(sv);
4644 }
4645
4646 #if defined(PERL_IMPLICIT_CONTEXT)
4647 void
4648 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4649 {
4650     dTHX;
4651     va_list args;
4652     va_start(args, pat);
4653     sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4654     va_end(args);
4655 }
4656
4657 void
4658 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4659 {
4660     dTHX;
4661     va_list args;
4662     va_start(args, pat);
4663     sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4664     va_end(args);
4665     SvSETMAGIC(sv);
4666 }
4667 #endif
4668
4669 void
4670 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4671 {
4672     va_list args;
4673     va_start(args, pat);
4674     sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4675     va_end(args);
4676 }
4677
4678 void
4679 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4680 {
4681     va_list args;
4682     va_start(args, pat);
4683     sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4684     va_end(args);
4685     SvSETMAGIC(sv);
4686 }
4687
4688 void
4689 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4690 {
4691     sv_setpvn(sv, "", 0);
4692     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4693 }
4694
4695 void
4696 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4697 {
4698     dTHR;
4699     char *p;
4700     char *q;
4701     char *patend;
4702     STRLEN origlen;
4703     I32 svix = 0;
4704     static char nullstr[] = "(null)";
4705
4706     /* no matter what, this is a string now */
4707     (void)SvPV_force(sv, origlen);
4708
4709     /* special-case "", "%s", and "%_" */
4710     if (patlen == 0)
4711         return;
4712     if (patlen == 2 && pat[0] == '%') {
4713         switch (pat[1]) {
4714         case 's':
4715             if (args) {
4716                 char *s = va_arg(*args, char*);
4717                 sv_catpv(sv, s ? s : nullstr);
4718             }
4719             else if (svix < svmax)
4720                 sv_catsv(sv, *svargs);
4721             return;
4722         case '_':
4723             if (args) {
4724                 sv_catsv(sv, va_arg(*args, SV*));
4725                 return;
4726             }
4727             /* See comment on '_' below */
4728             break;
4729         }
4730     }
4731
4732     patend = (char*)pat + patlen;
4733     for (p = (char*)pat; p < patend; p = q) {
4734         bool alt = FALSE;
4735         bool left = FALSE;
4736         char fill = ' ';
4737         char plus = 0;
4738         char intsize = 0;
4739         STRLEN width = 0;
4740         STRLEN zeros = 0;
4741         bool has_precis = FALSE;
4742         STRLEN precis = 0;
4743
4744         char esignbuf[4];
4745         U8 utf8buf[10];
4746         STRLEN esignlen = 0;
4747
4748         char *eptr = Nullch;
4749         STRLEN elen = 0;
4750         char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4751         char c;
4752         int i;
4753         unsigned base;
4754         IV iv;
4755         UV uv;
4756         NV nv;
4757         STRLEN have;
4758         STRLEN need;
4759         STRLEN gap;
4760
4761         for (q = p; q < patend && *q != '%'; ++q) ;
4762         if (q > p) {
4763             sv_catpvn(sv, p, q - p);
4764             p = q;
4765         }
4766         if (q++ >= patend)
4767             break;
4768
4769         /* FLAGS */
4770
4771         while (*q) {
4772             switch (*q) {
4773             case ' ':
4774             case '+':
4775                 plus = *q++;
4776                 continue;
4777
4778             case '-':
4779                 left = TRUE;
4780                 q++;
4781                 continue;
4782
4783             case '0':
4784                 fill = *q++;
4785                 continue;
4786
4787             case '#':
4788                 alt = TRUE;
4789                 q++;
4790                 continue;
4791
4792             default:
4793                 break;
4794             }
4795             break;
4796         }
4797
4798         /* WIDTH */
4799
4800         switch (*q) {
4801         case '1': case '2': case '3':
4802         case '4': case '5': case '6':
4803         case '7': case '8': case '9':
4804             width = 0;
4805             while (isDIGIT(*q))
4806                 width = width * 10 + (*q++ - '0');
4807             break;
4808
4809         case '*':
4810             if (args)
4811                 i = va_arg(*args, int);
4812             else
4813                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4814             left |= (i < 0);
4815             width = (i < 0) ? -i : i;
4816             q++;
4817             break;
4818         }
4819
4820         /* PRECISION */
4821
4822         if (*q == '.') {
4823             q++;
4824             if (*q == '*') {
4825                 if (args)
4826                     i = va_arg(*args, int);
4827                 else
4828                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4829                 precis = (i < 0) ? 0 : i;
4830                 q++;
4831             }
4832             else {
4833                 precis = 0;
4834                 while (isDIGIT(*q))
4835                     precis = precis * 10 + (*q++ - '0');
4836             }
4837             has_precis = TRUE;
4838         }
4839
4840         /* SIZE */
4841
4842         switch (*q) {
4843         case 'l':
4844 #if 0  /* when quads have better support within Perl */
4845             if (*(q + 1) == 'l') {
4846                 intsize = 'q';
4847                 q += 2;
4848                 break;
4849             }
4850 #endif
4851             /* FALL THROUGH */
4852         case 'h':
4853         case 'V':
4854             intsize = *q++;
4855             break;
4856         }
4857
4858         /* CONVERSION */
4859
4860         switch (c = *q++) {
4861
4862             /* STRINGS */
4863
4864         case '%':
4865             eptr = q - 1;
4866             elen = 1;
4867             goto string;
4868
4869         case 'c':
4870             if (IN_UTF8) {
4871                 if (args)
4872                     uv = va_arg(*args, int);
4873                 else
4874                     uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4875
4876                 eptr = (char*)utf8buf;
4877                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4878                 goto string;
4879             }
4880             if (args)
4881                 c = va_arg(*args, int);
4882             else
4883                 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4884             eptr = &c;
4885             elen = 1;
4886             goto string;
4887
4888         case 's':
4889             if (args) {
4890                 eptr = va_arg(*args, char*);
4891                 if (eptr)
4892                     elen = strlen(eptr);
4893                 else {
4894                     eptr = nullstr;
4895                     elen = sizeof nullstr - 1;
4896                 }
4897             }
4898             else if (svix < svmax) {
4899                 eptr = SvPVx(svargs[svix++], elen);
4900                 if (IN_UTF8) {
4901                     if (has_precis && precis < elen) {
4902                         I32 p = precis;
4903                         sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4904                         precis = p;
4905                     }
4906                     if (width) { /* fudge width (can't fudge elen) */
4907                         width += elen - sv_len_utf8(svargs[svix - 1]);
4908                     }
4909                 }
4910             }
4911             goto string;
4912
4913         case '_':
4914             /*
4915              * The "%_" hack might have to be changed someday,
4916              * if ISO or ANSI decide to use '_' for something.
4917              * So we keep it hidden from users' code.
4918              */
4919             if (!args)
4920                 goto unknown;
4921             eptr = SvPVx(va_arg(*args, SV*), elen);
4922
4923         string:
4924             if (has_precis && elen > precis)
4925                 elen = precis;
4926             break;
4927
4928             /* INTEGERS */
4929
4930         case 'p':
4931             if (args)
4932                 uv = (UV)va_arg(*args, void*);
4933             else
4934                 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4935             base = 16;
4936             goto integer;
4937
4938         case 'D':
4939             intsize = 'l';
4940             /* FALL THROUGH */
4941         case 'd':
4942         case 'i':
4943             if (args) {
4944                 switch (intsize) {
4945                 case 'h':       iv = (short)va_arg(*args, int); break;
4946                 default:        iv = va_arg(*args, int); break;
4947                 case 'l':       iv = va_arg(*args, long);