sv.c

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