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