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