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