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