sv.c

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