sv.c

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