sv.c

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