sv.c

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