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