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