sv.c

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