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