sv.c

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