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