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