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(do_report_used);
 298 }
 299
 300 void
 301 Perl_sv_clean_objs(pTHX)
 302 {
 303     PL_in_clean_objs = TRUE;
 304     visit(do_clean_objs);
 305 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 306     /* some barnacles may yet remain, clinging to typeglobs */
 307     visit(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(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     va_start(args, pat);
3953     sv = vnewSVpvf(pat, &args);
3954     va_end(args);
3955     return sv;
3956 }
3957 #endif
3958
3959 SV *
3960 Perl_newSVpvf(pTHX_ const char* pat, ...)
3961 {
3962     register SV *sv;
3963     va_list args;
3964     va_start(args, pat);
3965     sv = vnewSVpvf(pat, &args);
3966     va_end(args);
3967     return sv;
3968 }
3969
3970 SV *
3971 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
3972 {
3973     register SV *sv;
3974     new_SV(sv);
3975     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
3976     return sv;
3977 }
3978
3979 SV *
3980 Perl_newSVnv(pTHX_ NV n)
3981 {
3982     register SV *sv;
3983
3984     new_SV(sv);
3985     sv_setnv(sv,n);
3986     return sv;
3987 }
3988
3989 SV *
3990 Perl_newSViv(pTHX_ IV i)
3991 {
3992     register SV *sv;
3993
3994     new_SV(sv);
3995     sv_setiv(sv,i);
3996     return sv;
3997 }
3998
3999 SV *
4000 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4001 {
4002     dTHR;
4003     register SV *sv;
4004
4005     new_SV(sv);
4006     sv_upgrade(sv, SVt_RV);
4007     SvTEMP_off(tmpRef);
4008     SvRV(sv) = tmpRef;
4009     SvROK_on(sv);
4010     return sv;
4011 }
4012
4013 SV *
4014 Perl_newRV(pTHX_ SV *tmpRef)
4015 {
4016     return newRV_noinc(SvREFCNT_inc(tmpRef));
4017 }
4018
4019 /* make an exact duplicate of old */
4020
4021 SV *
4022 Perl_newSVsv(pTHX_ register SV *old)
4023 {
4024     dTHR;
4025     register SV *sv;
4026
4027     if (!old)
4028         return Nullsv;
4029     if (SvTYPE(old) == SVTYPEMASK) {
4030         if (ckWARN_d(WARN_INTERNAL))
4031             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4032         return Nullsv;
4033     }
4034     new_SV(sv);
4035     if (SvTEMP(old)) {
4036         SvTEMP_off(old);
4037         sv_setsv(sv,old);
4038         SvTEMP_on(old);
4039     }
4040     else
4041         sv_setsv(sv,old);
4042     return sv;
4043 }
4044
4045 void
4046 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4047 {
4048     register HE *entry;
4049     register GV *gv;
4050     register SV *sv;
4051     register I32 i;
4052     register PMOP *pm;
4053     register I32 max;
4054     char todo[256];
4055
4056     if (!stash)
4057         return;
4058
4059     if (!*s) {          /* reset ?? searches */
4060         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4061             pm->op_pmdynflags &= ~PMdf_USED;
4062         }
4063         return;
4064     }
4065
4066     /* reset variables */
4067
4068     if (!HvARRAY(stash))
4069         return;
4070
4071     Zero(todo, 256, char);
4072     while (*s) {
4073         i = *s;
4074         if (s[1] == '-') {
4075             s += 2;
4076         }
4077         max = *s++;
4078         for ( ; i <= max; i++) {
4079             todo[i] = 1;
4080         }
4081         for (i = 0; i <= (I32) HvMAX(stash); i++) {
4082             for (entry = HvARRAY(stash)[i];
4083                  entry;
4084                  entry = HeNEXT(entry))
4085             {
4086                 if (!todo[(U8)*HeKEY(entry)])
4087                     continue;
4088                 gv = (GV*)HeVAL(entry);
4089                 sv = GvSV(gv);
4090                 if (SvTHINKFIRST(sv)) {
4091                     if (!SvREADONLY(sv) && SvROK(sv))
4092                         sv_unref(sv);
4093                     continue;
4094                 }
4095                 (void)SvOK_off(sv);
4096                 if (SvTYPE(sv) >= SVt_PV) {
4097                     SvCUR_set(sv, 0);
4098                     if (SvPVX(sv) != Nullch)
4099                         *SvPVX(sv) = '\0';
4100                     SvTAINT(sv);
4101                 }
4102                 if (GvAV(gv)) {
4103                     av_clear(GvAV(gv));
4104                 }
4105                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4106                     hv_clear(GvHV(gv));
4107 #ifndef VMS  /* VMS has no environ array */
4108                     if (gv == PL_envgv)
4109                         environ[0] = Nullch;
4110 #endif
4111                 }
4112             }
4113         }
4114     }
4115 }
4116
4117 IO*
4118 Perl_sv_2io(pTHX_ SV *sv)
4119 {
4120     IO* io;
4121     GV* gv;
4122     STRLEN n_a;
4123
4124     switch (SvTYPE(sv)) {
4125     case SVt_PVIO:
4126         io = (IO*)sv;
4127         break;
4128     case SVt_PVGV:
4129         gv = (GV*)sv;
4130         io = GvIO(gv);
4131         if (!io)
4132             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4133         break;
4134     default:
4135         if (!SvOK(sv))
4136             Perl_croak(aTHX_ PL_no_usym, "filehandle");
4137         if (SvROK(sv))
4138             return sv_2io(SvRV(sv));
4139         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4140         if (gv)
4141             io = GvIO(gv);
4142         else
4143             io = 0;
4144         if (!io)
4145             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4146         break;
4147     }
4148     return io;
4149 }
4150
4151 CV *
4152 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4153 {
4154     GV *gv;
4155     CV *cv;
4156     STRLEN n_a;
4157
4158     if (!sv)
4159         return *gvp = Nullgv, Nullcv;
4160     switch (SvTYPE(sv)) {
4161     case SVt_PVCV:
4162         *st = CvSTASH(sv);
4163         *gvp = Nullgv;
4164         return (CV*)sv;
4165     case SVt_PVHV:
4166     case SVt_PVAV:
4167         *gvp = Nullgv;
4168         return Nullcv;
4169     case SVt_PVGV:
4170         gv = (GV*)sv;
4171         *gvp = gv;
4172         *st = GvESTASH(gv);
4173         goto fix_gv;
4174
4175     default:
4176         if (SvGMAGICAL(sv))
4177             mg_get(sv);
4178         if (SvROK(sv)) {
4179             dTHR;
4180             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
4181             tryAMAGICunDEREF(to_cv);
4182
4183             sv = SvRV(sv);
4184             if (SvTYPE(sv) == SVt_PVCV) {
4185                 cv = (CV*)sv;
4186                 *gvp = Nullgv;
4187                 *st = CvSTASH(cv);
4188                 return cv;
4189             }
4190             else if(isGV(sv))
4191                 gv = (GV*)sv;
4192             else
4193                 Perl_croak(aTHX_ "Not a subroutine reference");
4194         }
4195         else if (isGV(sv))
4196             gv = (GV*)sv;
4197         else
4198             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4199         *gvp = gv;
4200         if (!gv)
4201             return Nullcv;
4202         *st = GvESTASH(gv);
4203     fix_gv:
4204         if (lref && !GvCVu(gv)) {
4205             SV *tmpsv;
4206             ENTER;
4207             tmpsv = NEWSV(704,0);
4208             gv_efullname3(tmpsv, gv, Nullch);
4209             /* XXX this is probably not what they think they're getting.
4210              * It has the same effect as "sub name;", i.e. just a forward
4211              * declaration! */
4212             newSUB(start_subparse(FALSE, 0),
4213                    newSVOP(OP_CONST, 0, tmpsv),
4214                    Nullop,
4215                    Nullop);
4216             LEAVE;
4217             if (!GvCVu(gv))
4218                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4219         }
4220         return GvCVu(gv);
4221     }
4222 }
4223
4224 I32
4225 Perl_sv_true(pTHX_ register SV *sv)
4226 {
4227     dTHR;
4228     if (!sv)
4229         return 0;
4230     if (SvPOK(sv)) {
4231         register XPV* tXpv;
4232         if ((tXpv = (XPV*)SvANY(sv)) &&
4233                 (*tXpv->xpv_pv > '0' ||
4234                 tXpv->xpv_cur > 1 ||
4235                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4236             return 1;
4237         else
4238             return 0;
4239     }
4240     else {
4241         if (SvIOK(sv))
4242             return SvIVX(sv) != 0;
4243         else {
4244             if (SvNOK(sv))
4245                 return SvNVX(sv) != 0.0;
4246             else
4247                 return sv_2bool(sv);
4248         }
4249     }
4250 }
4251
4252 IV
4253 Perl_sv_iv(pTHX_ register SV *sv)
4254 {
4255     if (SvIOK(sv)) {
4256         if (SvIsUV(sv))
4257             return (IV)SvUVX(sv);
4258         return SvIVX(sv);
4259     }
4260     return sv_2iv(sv);
4261 }
4262
4263 UV
4264 Perl_sv_uv(pTHX_ register SV *sv)
4265 {
4266     if (SvIOK(sv)) {
4267         if (SvIsUV(sv))
4268             return SvUVX(sv);
4269         return (UV)SvIVX(sv);
4270     }
4271     return sv_2uv(sv);
4272 }
4273
4274 NV
4275 Perl_sv_nv(pTHX_ register SV *sv)
4276 {
4277     if (SvNOK(sv))
4278         return SvNVX(sv);
4279     return sv_2nv(sv);
4280 }
4281
4282 char *
4283 Perl_sv_pv(pTHX_ SV *sv)
4284 {
4285     STRLEN n_a;
4286
4287     if (SvPOK(sv))
4288         return SvPVX(sv);
4289
4290     return sv_2pv(sv, &n_a);
4291 }
4292
4293 char *
4294 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4295 {
4296     if (SvPOK(sv)) {
4297         *lp = SvCUR(sv);
4298         return SvPVX(sv);
4299     }
4300     return sv_2pv(sv, lp);
4301 }
4302
4303 char *
4304 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4305 {
4306     char *s;
4307
4308     if (SvTHINKFIRST(sv) && !SvROK(sv))
4309         sv_force_normal(sv);
4310
4311     if (SvPOK(sv)) {
4312         *lp = SvCUR(sv);
4313     }
4314     else {
4315         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4316             dTHR;
4317             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4318                 PL_op_name[PL_op->op_type]);
4319         }
4320         else
4321             s = sv_2pv(sv, lp);
4322         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
4323             STRLEN len = *lp;
4324
4325             if (SvROK(sv))
4326                 sv_unref(sv);
4327             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
4328             SvGROW(sv, len + 1);
4329             Move(s,SvPVX(sv),len,char);
4330             SvCUR_set(sv, len);
4331             *SvEND(sv) = '\0';
4332         }
4333         if (!SvPOK(sv)) {
4334             SvPOK_on(sv);               /* validate pointer */
4335             SvTAINT(sv);
4336             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4337                 (unsigned long)sv,SvPVX(sv)));
4338         }
4339     }
4340     return SvPVX(sv);
4341 }
4342
4343 char *
4344 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4345 {
4346     if (ob && SvOBJECT(sv))
4347         return HvNAME(SvSTASH(sv));
4348     else {
4349         switch (SvTYPE(sv)) {
4350         case SVt_NULL:
4351         case SVt_IV:
4352         case SVt_NV:
4353         case SVt_RV:
4354         case SVt_PV:
4355         case SVt_PVIV:
4356         case SVt_PVNV:
4357         case SVt_PVMG:
4358         case SVt_PVBM:
4359                                 if (SvROK(sv))
4360                                     return "REF";
4361                                 else
4362                                     return "SCALAR";
4363         case SVt_PVLV:          return "LVALUE";
4364         case SVt_PVAV:          return "ARRAY";
4365         case SVt_PVHV:          return "HASH";
4366         case SVt_PVCV:          return "CODE";
4367         case SVt_PVGV:          return "GLOB";
4368         case SVt_PVFM:          return "FORMAT";
4369         default:                return "UNKNOWN";
4370         }
4371     }
4372 }
4373
4374 int
4375 Perl_sv_isobject(pTHX_ SV *sv)
4376 {
4377     if (!sv)
4378         return 0;
4379     if (SvGMAGICAL(sv))
4380         mg_get(sv);
4381     if (!SvROK(sv))
4382         return 0;
4383     sv = (SV*)SvRV(sv);
4384     if (!SvOBJECT(sv))
4385         return 0;
4386     return 1;
4387 }
4388
4389 int
4390 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4391 {
4392     if (!sv)
4393         return 0;
4394     if (SvGMAGICAL(sv))
4395         mg_get(sv);
4396     if (!SvROK(sv))
4397         return 0;
4398     sv = (SV*)SvRV(sv);
4399     if (!SvOBJECT(sv))
4400         return 0;
4401
4402     return strEQ(HvNAME(SvSTASH(sv)), name);
4403 }
4404
4405 SV*
4406 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4407 {
4408     dTHR;
4409     SV *sv;
4410
4411     new_SV(sv);
4412
4413     SV_CHECK_THINKFIRST(rv);
4414     SvAMAGIC_off(rv);
4415
4416     if (SvTYPE(rv) < SVt_RV)
4417       sv_upgrade(rv, SVt_RV);
4418
4419     (void)SvOK_off(rv);
4420     SvRV(rv) = sv;
4421     SvROK_on(rv);
4422
4423     if (classname) {
4424         HV* stash = gv_stashpv(classname, TRUE);
4425         (void)sv_bless(rv, stash);
4426     }
4427     return sv;
4428 }
4429
4430 SV*
4431 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4432 {
4433     if (!pv) {
4434         sv_setsv(rv, &PL_sv_undef);
4435         SvSETMAGIC(rv);
4436     }
4437     else
4438         sv_setiv(newSVrv(rv,classname), (IV)pv);
4439     return rv;
4440 }
4441
4442 SV*
4443 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4444 {
4445     sv_setiv(newSVrv(rv,classname), iv);
4446     return rv;
4447 }
4448
4449 SV*
4450 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4451 {
4452     sv_setnv(newSVrv(rv,classname), nv);
4453     return rv;
4454 }
4455
4456 SV*
4457 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4458 {
4459     sv_setpvn(newSVrv(rv,classname), pv, n);
4460     return rv;
4461 }
4462
4463 SV*
4464 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4465 {
4466     dTHR;
4467     SV *tmpRef;
4468     if (!SvROK(sv))
4469         Perl_croak(aTHX_ "Can't bless non-reference value");
4470     tmpRef = SvRV(sv);
4471     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4472         if (SvREADONLY(tmpRef))
4473             Perl_croak(aTHX_ PL_no_modify);
4474         if (SvOBJECT(tmpRef)) {
4475             if (SvTYPE(tmpRef) != SVt_PVIO)
4476                 --PL_sv_objcount;
4477             SvREFCNT_dec(SvSTASH(tmpRef));
4478         }
4479     }
4480     SvOBJECT_on(tmpRef);
4481     if (SvTYPE(tmpRef) != SVt_PVIO)
4482         ++PL_sv_objcount;
4483     (void)SvUPGRADE(tmpRef, SVt_PVMG);
4484     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4485
4486     if (Gv_AMG(stash))
4487         SvAMAGIC_on(sv);
4488     else
4489         SvAMAGIC_off(sv);
4490
4491     return sv;
4492 }
4493
4494 STATIC void
4495 S_sv_unglob(pTHX_ SV *sv)
4496 {
4497     assert(SvTYPE(sv) == SVt_PVGV);
4498     SvFAKE_off(sv);
4499     if (GvGP(sv))
4500         gp_free((GV*)sv);
4501     if (GvSTASH(sv)) {
4502         SvREFCNT_dec(GvSTASH(sv));
4503         GvSTASH(sv) = Nullhv;
4504     }
4505     sv_unmagic(sv, '*');
4506     Safefree(GvNAME(sv));
4507     GvMULTI_off(sv);
4508     SvFLAGS(sv) &= ~SVTYPEMASK;
4509     SvFLAGS(sv) |= SVt_PVMG;
4510 }
4511
4512 void
4513 Perl_sv_unref(pTHX_ SV *sv)
4514 {
4515     SV* rv = SvRV(sv);
4516
4517     if (SvWEAKREF(sv)) {
4518         sv_del_backref(sv);
4519         SvWEAKREF_off(sv);
4520         SvRV(sv) = 0;
4521         return;
4522     }
4523     SvRV(sv) = 0;
4524     SvROK_off(sv);
4525     if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4526         SvREFCNT_dec(rv);
4527     else
4528         sv_2mortal(rv);         /* Schedule for freeing later */
4529 }
4530
4531 void
4532 Perl_sv_taint(pTHX_ SV *sv)
4533 {
4534     sv_magic((sv), Nullsv, 't', Nullch, 0);
4535 }
4536
4537 void
4538 Perl_sv_untaint(pTHX_ SV *sv)
4539 {
4540     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4541         MAGIC *mg = mg_find(sv, 't');
4542         if (mg)
4543             mg->mg_len &= ~1;
4544     }
4545 }
4546
4547 bool
4548 Perl_sv_tainted(pTHX_ SV *sv)
4549 {
4550     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4551         MAGIC *mg = mg_find(sv, 't');
4552         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4553             return TRUE;
4554     }
4555     return FALSE;
4556 }
4557
4558 void
4559 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4560 {
4561     char buf[TYPE_CHARS(UV)];
4562     char *ebuf;
4563     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4564
4565     sv_setpvn(sv, ptr, ebuf - ptr);
4566 }
4567
4568
4569 void
4570 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4571 {
4572     char buf[TYPE_CHARS(UV)];
4573     char *ebuf;
4574     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4575
4576     sv_setpvn(sv, ptr, ebuf - ptr);
4577     SvSETMAGIC(sv);
4578 }
4579
4580 #if defined(PERL_IMPLICIT_CONTEXT)
4581 void
4582 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4583 {
4584     dTHX;
4585     va_list args;
4586     va_start(args, pat);
4587     sv_vsetpvf(sv, pat, &args);
4588     va_end(args);
4589 }
4590
4591
4592 void
4593 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4594 {
4595     dTHX;
4596     va_list args;
4597     va_start(args, pat);
4598     sv_vsetpvf_mg(sv, pat, &args);
4599     va_end(args);
4600 }
4601 #endif
4602
4603 void
4604 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4605 {
4606     va_list args;
4607     va_start(args, pat);
4608     sv_vsetpvf(sv, pat, &args);
4609     va_end(args);
4610 }
4611
4612 void
4613 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4614 {
4615     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4616 }
4617
4618 void
4619 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4620 {
4621     va_list args;
4622     va_start(args, pat);
4623     sv_vsetpvf_mg(sv, pat, &args);
4624     va_end(args);
4625 }
4626
4627 void
4628 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4629 {
4630     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4631     SvSETMAGIC(sv);
4632 }
4633
4634 #if defined(PERL_IMPLICIT_CONTEXT)
4635 void
4636 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4637 {
4638     dTHX;
4639     va_list args;
4640     va_start(args, pat);
4641     sv_vcatpvf(sv, pat, &args);
4642     va_end(args);
4643 }
4644
4645 void
4646 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4647 {
4648     dTHX;
4649     va_list args;
4650     va_start(args, pat);
4651     sv_vcatpvf_mg(sv, pat, &args);
4652     va_end(args);
4653 }
4654 #endif
4655
4656 void
4657 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4658 {
4659     va_list args;
4660     va_start(args, pat);
4661     sv_vcatpvf(sv, pat, &args);
4662     va_end(args);
4663 }
4664
4665 void
4666 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4667 {
4668     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4669 }
4670
4671 void
4672 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4673 {
4674     va_list args;
4675     va_start(args, pat);
4676     sv_vcatpvf_mg(sv, pat, &args);
4677     va_end(args);
4678 }
4679
4680 void
4681 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4682 {
4683     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4684     SvSETMAGIC(sv);
4685 }
4686
4687 void
4688 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4689 {
4690     sv_setpvn(sv, "", 0);
4691     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4692 }
4693
4694 void
4695 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4696 {
4697     dTHR;
4698     char *p;
4699     char *q;
4700     char *patend;
4701     STRLEN origlen;
4702     I32 svix = 0;
4703     static char nullstr[] = "(null)";
4704
4705     /* no matter what, this is a string now */
4706     (void)SvPV_force(sv, origlen);
4707
4708     /* special-case "", "%s", and "%_" */
4709     if (patlen == 0)
4710         return;
4711     if (patlen == 2 && pat[0] == '%') {
4712         switch (pat[1]) {
4713         case 's':
4714             if (args) {
4715                 char *s = va_arg(*args, char*);
4716                 sv_catpv(sv, s ? s : nullstr);
4717             }
4718             else if (svix < svmax)
4719                 sv_catsv(sv, *svargs);
4720             return;
4721         case '_':
4722             if (args) {
4723                 sv_catsv(sv, va_arg(*args, SV*));
4724                 return;
4725             }
4726             /* See comment on '_' below */
4727             break;
4728         }
4729     }
4730
4731     patend = (char*)pat + patlen;
4732     for (p = (char*)pat; p < patend; p = q) {
4733         bool alt = FALSE;
4734         bool left = FALSE;
4735         char fill = ' ';
4736         char plus = 0;
4737         char intsize = 0;
4738         STRLEN width = 0;
4739         STRLEN zeros = 0;
4740         bool has_precis = FALSE;
4741         STRLEN precis = 0;
4742
4743         char esignbuf[4];
4744         U8 utf8buf[10];
4745         STRLEN esignlen = 0;
4746
4747         char *eptr = Nullch;
4748         STRLEN elen = 0;
4749         char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4750         char c;
4751         int i;
4752         unsigned base;
4753         IV iv;
4754         UV uv;
4755         NV nv;
4756         STRLEN have;
4757         STRLEN need;
4758         STRLEN gap;
4759
4760         for (q = p; q < patend && *q != '%'; ++q) ;
4761         if (q > p) {
4762             sv_catpvn(sv, p, q - p);
4763             p = q;
4764         }
4765         if (q++ >= patend)
4766             break;
4767
4768         /* FLAGS */
4769
4770         while (*q) {
4771             switch (*q) {
4772             case ' ':
4773             case '+':
4774                 plus = *q++;
4775                 continue;
4776
4777             case '-':
4778                 left = TRUE;
4779                 q++;
4780                 continue;
4781
4782             case '0':
4783                 fill = *q++;
4784                 continue;
4785
4786             case '#':
4787                 alt = TRUE;
4788                 q++;
4789                 continue;
4790
4791             default:
4792                 break;
4793             }
4794             break;
4795         }
4796
4797         /* WIDTH */
4798
4799         switch (*q) {
4800         case '1': case '2': case '3':
4801         case '4': case '5': case '6':
4802         case '7': case '8': case '9':
4803             width = 0;
4804             while (isDIGIT(*q))
4805                 width = width * 10 + (*q++ - '0');
4806             break;
4807
4808         case '*':
4809             if (args)
4810                 i = va_arg(*args, int);
4811             else
4812                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4813             left |= (i < 0);
4814             width = (i < 0) ? -i : i;
4815             q++;
4816             break;
4817         }
4818
4819         /* PRECISION */
4820
4821         if (*q == '.') {
4822             q++;
4823             if (*q == '*') {
4824                 if (args)
4825                     i = va_arg(*args, int);
4826                 else
4827                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4828                 precis = (i < 0) ? 0 : i;
4829                 q++;
4830             }
4831             else {
4832                 precis = 0;
4833                 while (isDIGIT(*q))
4834                     precis = precis * 10 + (*q++ - '0');
4835             }
4836             has_precis = TRUE;
4837         }
4838
4839         /* SIZE */
4840
4841         switch (*q) {
4842         case 'l':
4843 #if 0  /* when quads have better support within Perl */
4844             if (*(q + 1) == 'l') {
4845                 intsize = 'q';
4846                 q += 2;
4847                 break;
4848             }
4849 #endif
4850             /* FALL THROUGH */
4851         case 'h':
4852         case 'V':
4853             intsize = *q++;
4854             break;
4855         }
4856
4857         /* CONVERSION */
4858
4859         switch (c = *q++) {
4860
4861             /* STRINGS */
4862
4863         case '%':
4864             eptr = q - 1;
4865             elen = 1;
4866             goto string;
4867
4868         case 'c':
4869             if (IN_UTF8) {
4870                 if (args)
4871                     uv = va_arg(*args, int);
4872                 else
4873                     uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4874
4875                 eptr = (char*)utf8buf;
4876                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4877                 goto string;
4878             }
4879             if (args)
4880                 c = va_arg(*args, int);
4881             else
4882                 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4883             eptr = &c;
4884             elen = 1;
4885             goto string;
4886
4887         case 's':
4888             if (args) {
4889                 eptr = va_arg(*args, char*);
4890                 if (eptr)
4891                     elen = strlen(eptr);
4892                 else {
4893                     eptr = nullstr;
4894                     elen = sizeof nullstr - 1;
4895                 }
4896             }
4897             else if (svix < svmax) {
4898                 eptr = SvPVx(svargs[svix++], elen);
4899                 if (IN_UTF8) {
4900                     if (has_precis && precis < elen) {
4901                         I32 p = precis;
4902                         sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4903                         precis = p;
4904                     }
4905                     if (width) { /* fudge width (can't fudge elen) */
4906                         width += elen - sv_len_utf8(svargs[svix - 1]);
4907                     }
4908                 }
4909             }
4910             goto string;
4911
4912         case '_':
4913             /*
4914              * The "%_" hack might have to be changed someday,
4915              * if ISO or ANSI decide to use '_' for something.
4916              * So we keep it hidden from users' code.
4917              */
4918             if (!args)
4919                 goto unknown;
4920             eptr = SvPVx(va_arg(*args, SV*), elen);
4921
4922         string:
4923             if (has_precis && elen > precis)
4924                 elen = precis;
4925             break;
4926
4927             /* INTEGERS */
4928
4929         case 'p':
4930             if (args)
4931                 uv = (UV)va_arg(*args, void*);
4932             else
4933                 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4934             base = 16;
4935             goto integer;
4936
4937         case 'D':
4938             intsize = 'l';
4939             /* FALL THROUGH */
4940         case 'd':
4941         case 'i':
4942             if (args) {
4943                 switch (intsize) {
4944                 case 'h':       iv = (short)va_arg(*args, int); break;
4945                 default:        iv = va_arg(*args, int); break;
4946                 case 'l':       iv = va_arg(*args, long); break;
4947                 case 'V':       iv = va_arg(*args, IV); break;
4948                 }
4949             }
4950             else {
4951                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4952                 switch (intsize) {
4953                 case 'h':       iv = (short)iv; break;
4954                 default:        iv = (int)iv; break;
4955                 case 'l':       iv = (long)iv; break;
4956                 case 'V':       break;
4957                 }
4958             }
4959             if (iv >= 0) {
4960                 uv = iv;
4961                 if (plus)
4962                     esignbuf[esignlen++] = plus;
4963             }
4964             else {
4965                 uv = -iv;
4966                 esignbuf[esignlen++] = '-';
4967             }
4968             base = 10;
4969             goto integer;
4970
4971         case 'U':
4972             intsize = 'l';
4973             /* FALL THROUGH */
4974         case 'u':
4975             base = 10;
4976             goto uns_integer;
4977
4978         case 'b':
4979             base = 2;
4980             goto uns_integer;
4981
4982         case 'O':
4983             intsize = 'l';
4984             /* FALL THROUGH */
4985         case 'o':
4986             base = 8;
4987             goto uns_integer;
4988
4989         case 'X':
4990         case 'x':
4991             base = 16;
4992
4993         uns_integer:
4994             if (args) {
4995                 switch (intsize) {
4996                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
4997                 default:   uv = va_arg(*args, unsigned); break;
4998                 case 'l':  uv = va_arg(*args, unsigned long); break;
4999                 case 'V':  uv = va_arg(*args, UV); break;
5000                 }
5001             }
5002             else {
5003                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5004                 switch (intsize) {
5005                 case 'h':       uv = (unsigned short)uv; break;
5006                 default:        uv = (unsigned)uv; break;
5007                 case 'l':       uv = (unsigned long)uv; break;
5008                 case 'V':       break;
5009                 }
5010             }
5011
5012         integer:
5013             eptr = ebuf + sizeof ebuf;
5014             switch (base) {
5015                 unsigned dig;
5016             case 16:
5017                 if (!uv)
5018                     alt = FALSE;
5019                 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5020                 do {
5021                     dig = uv & 15;
5022                     *--eptr = p[dig];
5023                 } while (uv >>= 4);
5024                 if (alt) {
5025                     esignbuf[esignlen++] = '0';
5026                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
5027                 }
5028                 break;
5029             case 8:
5030                 do {
5031                     dig = uv & 7;
5032                     *--eptr = '0' + dig;
5033                 } while (uv >>= 3);
5034                 if (alt && *eptr != '0')
5035                     *--eptr = '0';
5036                 break;
5037             case 2:
5038                 do {
5039                     dig = uv & 1;
5040                     *--eptr = '0' + dig;
5041                 } while (uv >>= 1);
5042                 if (alt && *eptr != '0')
5043                     *--eptr = '0';
5044                 break;
5045             default:            /* it had better be ten or less */
5046                 do {
5047                     dig = uv % base;
5048                     *--eptr = '0' + dig;
5049                 } while (uv /= base);
5050                 break;
5051             }
5052             elen = (ebuf + sizeof ebuf) - eptr;
5053             if (has_precis) {
5054                 if (precis > elen)
5055                     zeros = precis - elen;
5056                 else if (precis == 0 && elen == 1 && *eptr == '0')
5057                     elen = 0;
5058             }
5059             break;
5060
5061             /* FLOATING POINT */
5062
5063         case 'F':
5064             c = 'f';            /* maybe %F isn't supported here */
5065             /* FALL THROUGH */
5066         case 'e': case 'E':
5067         case 'f':
5068         case 'g': case 'G':
5069
5070             /* This is evil, but floating point is even more evil */
5071
5072             if (args)
5073                 nv = va_arg(*args, NV);
5074             else
5075                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5076
5077             need = 0;
5078             if (c != 'e' && c != 'E') {
5079                 i = PERL_INT_MIN;
5080                 (void)frexp(nv, &i);
5081                 if (i == PERL_INT_MIN)
5082                     Perl_die(aTHX_ "panic: frexp");
5083                 if (i > 0)
5084                     need = BIT_DIGITS(i);
5085             }
5086             need += has_precis ? precis : 6; /* known default */
5087             if (need < width)
5088                 need = width;
5089
5090             need += 20; /* fudge factor */
5091             if (PL_efloatsize < need) {
5092                 Safefree(PL_efloatbuf);
5093                 PL_efloatsize = need + 20; /* more fudge */
5094                 New(906, PL_efloatbuf, PL_efloatsize, char);
5095             }
5096
5097             eptr = ebuf + sizeof ebuf;
5098             *--eptr = '\0';
5099             *--eptr = c;
5100 #ifdef USE_LONG_DOUBLE
5101             *--eptr = 'L';
5102 #endif
5103             if (has_precis) {
5104                 base = precis;
5105                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5106                 *--eptr = '.';
5107             }
5108             if (width) {
5109                 base = width;
5110                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5111             }
5112             if (fill == '0')
5113                 *--eptr = fill;
5114             if (left)
5115                 *--eptr = '-';
5116             if (plus)
5117                 *--eptr = plus;
5118             if (alt)
5119                 *--eptr = '#';
5120             *--eptr = '%';
5121
5122             {
5123                 RESTORE_NUMERIC_STANDARD();
5124                 (void)sprintf(PL_efloatbuf, eptr, nv);
5125                 RESTORE_NUMERIC_LOCAL();
5126             }
5127
5128             eptr = PL_efloatbuf;
5129             elen = strlen(PL_efloatbuf);
5130
5131 #ifdef LC_NUMERIC
5132             /*
5133              * User-defined locales may include arbitrary characters.
5134              * And, unfortunately, some system may alloc the "C" locale
5135              * to be overridden by a malicious user.
5136              */
5137             if (used_locale)
5138                 *used_locale = TRUE;
5139 #endif /* LC_NUMERIC */
5140
5141             break;
5142
5143             /* SPECIAL */
5144
5145         case 'n':
5146             i = SvCUR(sv) - origlen;
5147             if (args) {
5148                 switch (intsize) {
5149                 case 'h':       *(va_arg(*args, short*)) = i; break;
5150                 default:        *(va_arg(*args, int*)) = i; break;
5151                 case 'l':       *(va_arg(*args, long*)) = i; break;
5152                 case 'V':       *(va_arg(*args, IV*)) = i; break;
5153                 }
5154             }
5155             else if (svix < svmax)
5156                 sv_setuv(svargs[svix++], (UV)i);
5157             continue;   /* not "break" */
5158
5159             /* UNKNOWN */
5160
5161         default:
5162       unknown:
5163             if (!args && ckWARN(WARN_PRINTF) &&
5164                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5165                 SV *msg = sv_newmortal();
5166                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5167                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5168                 if (c)
5169                     Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5170                               c & 0xFF);
5171                 else
5172                     sv_catpv(msg, "end of string");
5173                 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5174             }
5175
5176             /* output mangled stuff ... */
5177             if (c == '\0')
5178                 --q;
5179             eptr = p;
5180             elen = q - p;
5181
5182             /* ... right here, because formatting flags should not apply */
5183             SvGROW(sv, SvCUR(sv) + elen + 1);
5184             p = SvEND(sv);
5185             memcpy(p, eptr, elen);
5186             p += elen;
5187             *p = '\0';
5188             SvCUR(sv) = p - SvPVX(sv);
5189             continue;   /* not "break" */
5190         }
5191
5192         have = esignlen + zeros + elen;
5193         need = (have > width ? have : width);
5194         gap = need - have;
5195
5196         SvGROW(sv, SvCUR(sv) + need + 1);
5197         p = SvEND(sv);
5198         if (esignlen && fill == '0') {
5199             for (i = 0; i < esignlen; i++)
5200                 *p++ = esignbuf[i];
5201         }
5202         if (gap && !left) {
5203             memset(p, fill, gap);
5204             p += gap;
5205         }
5206         if (esignlen && fill != '0') {
5207             for (i = 0; i < esignlen; i++)
5208                 *p++ = esignbuf[i];
5209         }
5210         if (zeros) {
5211             for (i = zeros; i; i--)
5212                 *p++ = '0';
5213         }
5214         if (elen) {
5215             memcpy(p, eptr, elen);
5216             p += elen;
5217         }
5218         if (gap && left) {
5219             memset(p, ' ', gap);
5220             p += gap;
5221         }
5222         *p = '\0';
5223         SvCUR(sv) = p - SvPVX(sv);
5224     }
5225 }
5226
5227
5228 #ifdef PERL_OBJECT
5229 #define NO_XSLOCKS
5230 #include "XSUB.h"
5231 #endif
5232
5233 static void
5234 do_report_used(pTHXo_ SV *sv)
5235 {
5236     if (SvTYPE(sv) != SVTYPEMASK) {
5237         /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
5238         PerlIO_printf(PerlIO_stderr(), "****\n");
5239         sv_dump(sv);
5240     }
5241 }
5242
5243 static void
5244 do_clean_objs(pTHXo_ SV *sv)
5245 {
5246     SV* rv;
5247
5248     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5249         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5250         SvROK_off(sv);
5251         SvRV(sv) = 0;
5252         SvREFCNT_dec(rv);
5253     }
5254
5255     /* XXX Might want to check arrays, etc. */
5256 }
5257
5258 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5259 static void
5260 do_clean_named_objs(pTHXo_ SV *sv)
5261 {
5262     if (SvTYPE(sv) == SVt_PVGV) {
5263         if ( SvOBJECT(GvSV(sv)) ||
5264              GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5265              GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5266              GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5267              GvCV(sv) && SvOBJECT(GvCV(sv)) )
5268         {
5269             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5270             SvREFCNT_dec(sv);
5271         }
5272     }
5273 }
5274 #endif
5275
5276 static void
5277 do_clean_all(pTHXo_ SV *sv)
5278 {
5279     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
5280     SvFLAGS(sv) |= SVf_BREAK;
5281     SvREFCNT_dec(sv);
5282 }
5283