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