sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (c) 1991-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_SV_C
  16 #include "perl.h"
  17
  18 #define FCALL *f
  19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
  20
  21 static void do_report_used(pTHXo_ SV *sv);
  22 static void do_clean_objs(pTHXo_ SV *sv);
  23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
  24 static void do_clean_named_objs(pTHXo_ SV *sv);
  25 #endif
  26 static void do_clean_all(pTHXo_ SV *sv);
  27
  28 /*
  29  * "A time to plant, and a time to uproot what was planted..."
  30  */
  31
  32 #define plant_SV(p) \
  33     STMT_START {                                        \
  34         SvANY(p) = (void *)PL_sv_root;                  \
  35         SvFLAGS(p) = SVTYPEMASK;                        \
  36         PL_sv_root = (p);                               \
  37         --PL_sv_count;                                  \
  38     } STMT_END
  39
  40 /* sv_mutex must be held while calling uproot_SV() */
  41 #define uproot_SV(p) \
  42     STMT_START {                                        \
  43         (p) = PL_sv_root;                               \
  44         PL_sv_root = (SV*)SvANY(p);                     \
  45         ++PL_sv_count;                                  \
  46     } STMT_END
  47
  48 #define new_SV(p) \
  49     STMT_START {                                        \
  50         LOCK_SV_MUTEX;                                  \
  51         if (PL_sv_root)                                 \
  52             uproot_SV(p);                               \
  53         else                                            \
  54             (p) = more_sv();                            \
  55         UNLOCK_SV_MUTEX;                                \
  56         SvANY(p) = 0;                                   \
  57         SvREFCNT(p) = 1;                                \
  58         SvFLAGS(p) = 0;                                 \
  59     } STMT_END
  60
  61 #ifdef DEBUGGING
  62
  63 #define del_SV(p) \
  64     STMT_START {                                        \
  65         LOCK_SV_MUTEX;                                  \
  66         if (DEBUG_D_TEST)                               \
  67             del_sv(p);                                  \
  68         else                                            \
  69             plant_SV(p);                                \
  70         UNLOCK_SV_MUTEX;                                \
  71     } STMT_END
  72
  73 STATIC void
  74 S_del_sv(pTHX_ SV *p)
  75 {
  76     if (DEBUG_D_TEST) {
  77         SV* sva;
  78         SV* sv;
  79         SV* svend;
  80         int ok = 0;
  81         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
  82             sv = sva + 1;
  83             svend = &sva[SvREFCNT(sva)];
  84             if (p >= sv && p < svend)
  85                 ok = 1;
  86         }
  87         if (!ok) {
  88             if (ckWARN_d(WARN_INTERNAL))
  89                 Perl_warner(aTHX_ WARN_INTERNAL,
  90                             "Attempt to free non-arena SV: 0x%"UVxf,
  91                             PTR2UV(p));
  92             return;
  93         }
  94     }
  95     plant_SV(p);
  96 }
  97
  98 #else /* ! DEBUGGING */
  99
 100 #define del_SV(p)   plant_SV(p)
 101
 102 #endif /* DEBUGGING */
 103
 104 void
 105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
 106 {
 107     SV* sva = (SV*)ptr;
 108     register SV* sv;
 109     register SV* svend;
 110     Zero(ptr, size, char);
 111
 112     /* The first SV in an arena isn't an SV. */
 113     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 114     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 115     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 116
 117     PL_sv_arenaroot = sva;
 118     PL_sv_root = sva + 1;
 119
 120     svend = &sva[SvREFCNT(sva) - 1];
 121     sv = sva + 1;
 122     while (sv < svend) {
 123         SvANY(sv) = (void *)(SV*)(sv + 1);
 124         SvFLAGS(sv) = SVTYPEMASK;
 125         sv++;
 126     }
 127     SvANY(sv) = 0;
 128     SvFLAGS(sv) = SVTYPEMASK;
 129 }
 130
 131 /* sv_mutex must be held while calling more_sv() */
 132 STATIC SV*
 133 S_more_sv(pTHX)
 134 {
 135     register SV* sv;
 136
 137     if (PL_nice_chunk) {
 138         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 139         PL_nice_chunk = Nullch;
 140         PL_nice_chunk_size = 0;
 141     }
 142     else {
 143         char *chunk;                /* must use New here to match call to */
 144         New(704,chunk,1008,char);   /* Safefree() in sv_free_arenas()     */
 145         sv_add_arena(chunk, 1008, 0);
 146     }
 147     uproot_SV(sv);
 148     return sv;
 149 }
 150
 151 STATIC I32
 152 S_visit(pTHX_ SVFUNC_t f)
 153 {
 154     SV* sva;
 155     SV* sv;
 156     register SV* svend;
 157     I32 visited = 0;
 158
 159     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 160         svend = &sva[SvREFCNT(sva)];
 161         for (sv = sva + 1; sv < svend; ++sv) {
 162             if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
 163                 (FCALL)(aTHXo_ sv);
 164                 ++visited;
 165             }
 166         }
 167     }
 168     return visited;
 169 }
 170
 171 void
 172 Perl_sv_report_used(pTHX)
 173 {
 174     visit(do_report_used);
 175 }
 176
 177 void
 178 Perl_sv_clean_objs(pTHX)
 179 {
 180     PL_in_clean_objs = TRUE;
 181     visit(do_clean_objs);
 182 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 183     /* some barnacles may yet remain, clinging to typeglobs */
 184     visit(do_clean_named_objs);
 185 #endif
 186     PL_in_clean_objs = FALSE;
 187 }
 188
 189 I32
 190 Perl_sv_clean_all(pTHX)
 191 {
 192     I32 cleaned;
 193     PL_in_clean_all = TRUE;
 194     cleaned = visit(do_clean_all);
 195     PL_in_clean_all = FALSE;
 196     return cleaned;
 197 }
 198
 199 void
 200 Perl_sv_free_arenas(pTHX)
 201 {
 202     SV* sva;
 203     SV* svanext;
 204     XPV *arena, *arenanext;
 205
 206     /* Free arenas here, but be careful about fake ones.  (We assume
 207        contiguity of the fake ones with the corresponding real ones.) */
 208
 209     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 210         svanext = (SV*) SvANY(sva);
 211         while (svanext && SvFAKE(svanext))
 212             svanext = (SV*) SvANY(svanext);
 213
 214         if (!SvFAKE(sva))
 215             Safefree((void *)sva);
 216     }
 217
 218     for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
 219         arenanext = (XPV*)arena->xpv_pv;
 220         Safefree(arena);
 221     }
 222     PL_xiv_arenaroot = 0;
 223
 224     for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
 225         arenanext = (XPV*)arena->xpv_pv;
 226         Safefree(arena);
 227     }
 228     PL_xnv_arenaroot = 0;
 229
 230     for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
 231         arenanext = (XPV*)arena->xpv_pv;
 232         Safefree(arena);
 233     }
 234     PL_xrv_arenaroot = 0;
 235
 236     for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
 237         arenanext = (XPV*)arena->xpv_pv;
 238         Safefree(arena);
 239     }
 240     PL_xpv_arenaroot = 0;
 241
 242     for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
 243         arenanext = (XPV*)arena->xpv_pv;
 244         Safefree(arena);
 245     }
 246     PL_xpviv_arenaroot = 0;
 247
 248     for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
 249         arenanext = (XPV*)arena->xpv_pv;
 250         Safefree(arena);
 251     }
 252     PL_xpvnv_arenaroot = 0;
 253
 254     for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
 255         arenanext = (XPV*)arena->xpv_pv;
 256         Safefree(arena);
 257     }
 258     PL_xpvcv_arenaroot = 0;
 259
 260     for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
 261         arenanext = (XPV*)arena->xpv_pv;
 262         Safefree(arena);
 263     }
 264     PL_xpvav_arenaroot = 0;
 265
 266     for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
 267         arenanext = (XPV*)arena->xpv_pv;
 268         Safefree(arena);
 269     }
 270     PL_xpvhv_arenaroot = 0;
 271
 272     for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
 273         arenanext = (XPV*)arena->xpv_pv;
 274         Safefree(arena);
 275     }
 276     PL_xpvmg_arenaroot = 0;
 277
 278     for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
 279         arenanext = (XPV*)arena->xpv_pv;
 280         Safefree(arena);
 281     }
 282     PL_xpvlv_arenaroot = 0;
 283
 284     for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
 285         arenanext = (XPV*)arena->xpv_pv;
 286         Safefree(arena);
 287     }
 288     PL_xpvbm_arenaroot = 0;
 289
 290     for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
 291         arenanext = (XPV*)arena->xpv_pv;
 292         Safefree(arena);
 293     }
 294     PL_he_arenaroot = 0;
 295
 296     if (PL_nice_chunk)
 297         Safefree(PL_nice_chunk);
 298     PL_nice_chunk = Nullch;
 299     PL_nice_chunk_size = 0;
 300     PL_sv_arenaroot = 0;
 301     PL_sv_root = 0;
 302 }
 303
 304 void
 305 Perl_report_uninit(pTHX)
 306 {
 307     if (PL_op)
 308         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
 309                     " in ", PL_op_desc[PL_op->op_type]);
 310     else
 311         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
 312 }
 313
 314 STATIC XPVIV*
 315 S_new_xiv(pTHX)
 316 {
 317     IV* xiv;
 318     LOCK_SV_MUTEX;
 319     if (!PL_xiv_root)
 320         more_xiv();
 321     xiv = PL_xiv_root;
 322     /*
 323      * See comment in more_xiv() -- RAM.
 324      */
 325     PL_xiv_root = *(IV**)xiv;
 326     UNLOCK_SV_MUTEX;
 327     return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
 328 }
 329
 330 STATIC void
 331 S_del_xiv(pTHX_ XPVIV *p)
 332 {
 333     IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
 334     LOCK_SV_MUTEX;
 335     *(IV**)xiv = PL_xiv_root;
 336     PL_xiv_root = xiv;
 337     UNLOCK_SV_MUTEX;
 338 }
 339
 340 STATIC void
 341 S_more_xiv(pTHX)
 342 {
 343     register IV* xiv;
 344     register IV* xivend;
 345     XPV* ptr;
 346     New(705, ptr, 1008/sizeof(XPV), XPV);
 347     ptr->xpv_pv = (char*)PL_xiv_arenaroot;              /* linked list of xiv arenas */
 348     PL_xiv_arenaroot = ptr;                     /* to keep Purify happy */
 349
 350     xiv = (IV*) ptr;
 351     xivend = &xiv[1008 / sizeof(IV) - 1];
 352     xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1;   /* fudge by size of XPV */
 353     PL_xiv_root = xiv;
 354     while (xiv < xivend) {
 355         *(IV**)xiv = (IV *)(xiv + 1);
 356         xiv++;
 357     }
 358     *(IV**)xiv = 0;
 359 }
 360
 361 STATIC XPVNV*
 362 S_new_xnv(pTHX)
 363 {
 364     NV* xnv;
 365     LOCK_SV_MUTEX;
 366     if (!PL_xnv_root)
 367         more_xnv();
 368     xnv = PL_xnv_root;
 369     PL_xnv_root = *(NV**)xnv;
 370     UNLOCK_SV_MUTEX;
 371     return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
 372 }
 373
 374 STATIC void
 375 S_del_xnv(pTHX_ XPVNV *p)
 376 {
 377     NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
 378     LOCK_SV_MUTEX;
 379     *(NV**)xnv = PL_xnv_root;
 380     PL_xnv_root = xnv;
 381     UNLOCK_SV_MUTEX;
 382 }
 383
 384 STATIC void
 385 S_more_xnv(pTHX)
 386 {
 387     register NV* xnv;
 388     register NV* xnvend;
 389     XPV *ptr;
 390     New(711, ptr, 1008/sizeof(XPV), XPV);
 391     ptr->xpv_pv = (char*)PL_xnv_arenaroot;
 392     PL_xnv_arenaroot = ptr;
 393
 394     xnv = (NV*) ptr;
 395     xnvend = &xnv[1008 / sizeof(NV) - 1];
 396     xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
 397     PL_xnv_root = xnv;
 398     while (xnv < xnvend) {
 399         *(NV**)xnv = (NV*)(xnv + 1);
 400         xnv++;
 401     }
 402     *(NV**)xnv = 0;
 403 }
 404
 405 STATIC XRV*
 406 S_new_xrv(pTHX)
 407 {
 408     XRV* xrv;
 409     LOCK_SV_MUTEX;
 410     if (!PL_xrv_root)
 411         more_xrv();
 412     xrv = PL_xrv_root;
 413     PL_xrv_root = (XRV*)xrv->xrv_rv;
 414     UNLOCK_SV_MUTEX;
 415     return xrv;
 416 }
 417
 418 STATIC void
 419 S_del_xrv(pTHX_ XRV *p)
 420 {
 421     LOCK_SV_MUTEX;
 422     p->xrv_rv = (SV*)PL_xrv_root;
 423     PL_xrv_root = p;
 424     UNLOCK_SV_MUTEX;
 425 }
 426
 427 STATIC void
 428 S_more_xrv(pTHX)
 429 {
 430     register XRV* xrv;
 431     register XRV* xrvend;
 432     XPV *ptr;
 433     New(712, ptr, 1008/sizeof(XPV), XPV);
 434     ptr->xpv_pv = (char*)PL_xrv_arenaroot;
 435     PL_xrv_arenaroot = ptr;
 436
 437     xrv = (XRV*) ptr;
 438     xrvend = &xrv[1008 / sizeof(XRV) - 1];
 439     xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
 440     PL_xrv_root = xrv;
 441     while (xrv < xrvend) {
 442         xrv->xrv_rv = (SV*)(xrv + 1);
 443         xrv++;
 444     }
 445     xrv->xrv_rv = 0;
 446 }
 447
 448 STATIC XPV*
 449 S_new_xpv(pTHX)
 450 {
 451     XPV* xpv;
 452     LOCK_SV_MUTEX;
 453     if (!PL_xpv_root)
 454         more_xpv();
 455     xpv = PL_xpv_root;
 456     PL_xpv_root = (XPV*)xpv->xpv_pv;
 457     UNLOCK_SV_MUTEX;
 458     return xpv;
 459 }
 460
 461 STATIC void
 462 S_del_xpv(pTHX_ XPV *p)
 463 {
 464     LOCK_SV_MUTEX;
 465     p->xpv_pv = (char*)PL_xpv_root;
 466     PL_xpv_root = p;
 467     UNLOCK_SV_MUTEX;
 468 }
 469
 470 STATIC void
 471 S_more_xpv(pTHX)
 472 {
 473     register XPV* xpv;
 474     register XPV* xpvend;
 475     New(713, xpv, 1008/sizeof(XPV), XPV);
 476     xpv->xpv_pv = (char*)PL_xpv_arenaroot;
 477     PL_xpv_arenaroot = xpv;
 478
 479     xpvend = &xpv[1008 / sizeof(XPV) - 1];
 480     PL_xpv_root = ++xpv;
 481     while (xpv < xpvend) {
 482         xpv->xpv_pv = (char*)(xpv + 1);
 483         xpv++;
 484     }
 485     xpv->xpv_pv = 0;
 486 }
 487
 488 STATIC XPVIV*
 489 S_new_xpviv(pTHX)
 490 {
 491     XPVIV* xpviv;
 492     LOCK_SV_MUTEX;
 493     if (!PL_xpviv_root)
 494         more_xpviv();
 495     xpviv = PL_xpviv_root;
 496     PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
 497     UNLOCK_SV_MUTEX;
 498     return xpviv;
 499 }
 500
 501 STATIC void
 502 S_del_xpviv(pTHX_ XPVIV *p)
 503 {
 504     LOCK_SV_MUTEX;
 505     p->xpv_pv = (char*)PL_xpviv_root;
 506     PL_xpviv_root = p;
 507     UNLOCK_SV_MUTEX;
 508 }
 509
 510 STATIC void
 511 S_more_xpviv(pTHX)
 512 {
 513     register XPVIV* xpviv;
 514     register XPVIV* xpvivend;
 515     New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
 516     xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
 517     PL_xpviv_arenaroot = xpviv;
 518
 519     xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
 520     PL_xpviv_root = ++xpviv;
 521     while (xpviv < xpvivend) {
 522         xpviv->xpv_pv = (char*)(xpviv + 1);
 523         xpviv++;
 524     }
 525     xpviv->xpv_pv = 0;
 526 }
 527
 528 STATIC XPVNV*
 529 S_new_xpvnv(pTHX)
 530 {
 531     XPVNV* xpvnv;
 532     LOCK_SV_MUTEX;
 533     if (!PL_xpvnv_root)
 534         more_xpvnv();
 535     xpvnv = PL_xpvnv_root;
 536     PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
 537     UNLOCK_SV_MUTEX;
 538     return xpvnv;
 539 }
 540
 541 STATIC void
 542 S_del_xpvnv(pTHX_ XPVNV *p)
 543 {
 544     LOCK_SV_MUTEX;
 545     p->xpv_pv = (char*)PL_xpvnv_root;
 546     PL_xpvnv_root = p;
 547     UNLOCK_SV_MUTEX;
 548 }
 549
 550 STATIC void
 551 S_more_xpvnv(pTHX)
 552 {
 553     register XPVNV* xpvnv;
 554     register XPVNV* xpvnvend;
 555     New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
 556     xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
 557     PL_xpvnv_arenaroot = xpvnv;
 558
 559     xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
 560     PL_xpvnv_root = ++xpvnv;
 561     while (xpvnv < xpvnvend) {
 562         xpvnv->xpv_pv = (char*)(xpvnv + 1);
 563         xpvnv++;
 564     }
 565     xpvnv->xpv_pv = 0;
 566 }
 567
 568 STATIC XPVCV*
 569 S_new_xpvcv(pTHX)
 570 {
 571     XPVCV* xpvcv;
 572     LOCK_SV_MUTEX;
 573     if (!PL_xpvcv_root)
 574         more_xpvcv();
 575     xpvcv = PL_xpvcv_root;
 576     PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
 577     UNLOCK_SV_MUTEX;
 578     return xpvcv;
 579 }
 580
 581 STATIC void
 582 S_del_xpvcv(pTHX_ XPVCV *p)
 583 {
 584     LOCK_SV_MUTEX;
 585     p->xpv_pv = (char*)PL_xpvcv_root;
 586     PL_xpvcv_root = p;
 587     UNLOCK_SV_MUTEX;
 588 }
 589
 590 STATIC void
 591 S_more_xpvcv(pTHX)
 592 {
 593     register XPVCV* xpvcv;
 594     register XPVCV* xpvcvend;
 595     New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
 596     xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
 597     PL_xpvcv_arenaroot = xpvcv;
 598
 599     xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
 600     PL_xpvcv_root = ++xpvcv;
 601     while (xpvcv < xpvcvend) {
 602         xpvcv->xpv_pv = (char*)(xpvcv + 1);
 603         xpvcv++;
 604     }
 605     xpvcv->xpv_pv = 0;
 606 }
 607
 608 STATIC XPVAV*
 609 S_new_xpvav(pTHX)
 610 {
 611     XPVAV* xpvav;
 612     LOCK_SV_MUTEX;
 613     if (!PL_xpvav_root)
 614         more_xpvav();
 615     xpvav = PL_xpvav_root;
 616     PL_xpvav_root = (XPVAV*)xpvav->xav_array;
 617     UNLOCK_SV_MUTEX;
 618     return xpvav;
 619 }
 620
 621 STATIC void
 622 S_del_xpvav(pTHX_ XPVAV *p)
 623 {
 624     LOCK_SV_MUTEX;
 625     p->xav_array = (char*)PL_xpvav_root;
 626     PL_xpvav_root = p;
 627     UNLOCK_SV_MUTEX;
 628 }
 629
 630 STATIC void
 631 S_more_xpvav(pTHX)
 632 {
 633     register XPVAV* xpvav;
 634     register XPVAV* xpvavend;
 635     New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
 636     xpvav->xav_array = (char*)PL_xpvav_arenaroot;
 637     PL_xpvav_arenaroot = xpvav;
 638
 639     xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
 640     PL_xpvav_root = ++xpvav;
 641     while (xpvav < xpvavend) {
 642         xpvav->xav_array = (char*)(xpvav + 1);
 643         xpvav++;
 644     }
 645     xpvav->xav_array = 0;
 646 }
 647
 648 STATIC XPVHV*
 649 S_new_xpvhv(pTHX)
 650 {
 651     XPVHV* xpvhv;
 652     LOCK_SV_MUTEX;
 653     if (!PL_xpvhv_root)
 654         more_xpvhv();
 655     xpvhv = PL_xpvhv_root;
 656     PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
 657     UNLOCK_SV_MUTEX;
 658     return xpvhv;
 659 }
 660
 661 STATIC void
 662 S_del_xpvhv(pTHX_ XPVHV *p)
 663 {
 664     LOCK_SV_MUTEX;
 665     p->xhv_array = (char*)PL_xpvhv_root;
 666     PL_xpvhv_root = p;
 667     UNLOCK_SV_MUTEX;
 668 }
 669
 670 STATIC void
 671 S_more_xpvhv(pTHX)
 672 {
 673     register XPVHV* xpvhv;
 674     register XPVHV* xpvhvend;
 675     New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
 676     xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
 677     PL_xpvhv_arenaroot = xpvhv;
 678
 679     xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
 680     PL_xpvhv_root = ++xpvhv;
 681     while (xpvhv < xpvhvend) {
 682         xpvhv->xhv_array = (char*)(xpvhv + 1);
 683         xpvhv++;
 684     }
 685     xpvhv->xhv_array = 0;
 686 }
 687
 688 STATIC XPVMG*
 689 S_new_xpvmg(pTHX)
 690 {
 691     XPVMG* xpvmg;
 692     LOCK_SV_MUTEX;
 693     if (!PL_xpvmg_root)
 694         more_xpvmg();
 695     xpvmg = PL_xpvmg_root;
 696     PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
 697     UNLOCK_SV_MUTEX;
 698     return xpvmg;
 699 }
 700
 701 STATIC void
 702 S_del_xpvmg(pTHX_ XPVMG *p)
 703 {
 704     LOCK_SV_MUTEX;
 705     p->xpv_pv = (char*)PL_xpvmg_root;
 706     PL_xpvmg_root = p;
 707     UNLOCK_SV_MUTEX;
 708 }
 709
 710 STATIC void
 711 S_more_xpvmg(pTHX)
 712 {
 713     register XPVMG* xpvmg;
 714     register XPVMG* xpvmgend;
 715     New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
 716     xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
 717     PL_xpvmg_arenaroot = xpvmg;
 718
 719     xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
 720     PL_xpvmg_root = ++xpvmg;
 721     while (xpvmg < xpvmgend) {
 722         xpvmg->xpv_pv = (char*)(xpvmg + 1);
 723         xpvmg++;
 724     }
 725     xpvmg->xpv_pv = 0;
 726 }
 727
 728 STATIC XPVLV*
 729 S_new_xpvlv(pTHX)
 730 {
 731     XPVLV* xpvlv;
 732     LOCK_SV_MUTEX;
 733     if (!PL_xpvlv_root)
 734         more_xpvlv();
 735     xpvlv = PL_xpvlv_root;
 736     PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
 737     UNLOCK_SV_MUTEX;
 738     return xpvlv;
 739 }
 740
 741 STATIC void
 742 S_del_xpvlv(pTHX_ XPVLV *p)
 743 {
 744     LOCK_SV_MUTEX;
 745     p->xpv_pv = (char*)PL_xpvlv_root;
 746     PL_xpvlv_root = p;
 747     UNLOCK_SV_MUTEX;
 748 }
 749
 750 STATIC void
 751 S_more_xpvlv(pTHX)
 752 {
 753     register XPVLV* xpvlv;
 754     register XPVLV* xpvlvend;
 755     New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
 756     xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
 757     PL_xpvlv_arenaroot = xpvlv;
 758
 759     xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
 760     PL_xpvlv_root = ++xpvlv;
 761     while (xpvlv < xpvlvend) {
 762         xpvlv->xpv_pv = (char*)(xpvlv + 1);
 763         xpvlv++;
 764     }
 765     xpvlv->xpv_pv = 0;
 766 }
 767
 768 STATIC XPVBM*
 769 S_new_xpvbm(pTHX)
 770 {
 771     XPVBM* xpvbm;
 772     LOCK_SV_MUTEX;
 773     if (!PL_xpvbm_root)
 774         more_xpvbm();
 775     xpvbm = PL_xpvbm_root;
 776     PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
 777     UNLOCK_SV_MUTEX;
 778     return xpvbm;
 779 }
 780
 781 STATIC void
 782 S_del_xpvbm(pTHX_ XPVBM *p)
 783 {
 784     LOCK_SV_MUTEX;
 785     p->xpv_pv = (char*)PL_xpvbm_root;
 786     PL_xpvbm_root = p;
 787     UNLOCK_SV_MUTEX;
 788 }
 789
 790 STATIC void
 791 S_more_xpvbm(pTHX)
 792 {
 793     register XPVBM* xpvbm;
 794     register XPVBM* xpvbmend;
 795     New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
 796     xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
 797     PL_xpvbm_arenaroot = xpvbm;
 798
 799     xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
 800     PL_xpvbm_root = ++xpvbm;
 801     while (xpvbm < xpvbmend) {
 802         xpvbm->xpv_pv = (char*)(xpvbm + 1);
 803         xpvbm++;
 804     }
 805     xpvbm->xpv_pv = 0;
 806 }
 807
 808 #ifdef LEAKTEST
 809 #  define my_safemalloc(s)      (void*)safexmalloc(717,s)
 810 #  define my_safefree(p)        safexfree((char*)p)
 811 #else
 812 #  define my_safemalloc(s)      (void*)safemalloc(s)
 813 #  define my_safefree(p)        safefree((char*)p)
 814 #endif
 815
 816 #ifdef PURIFY
 817
 818 #define new_XIV()       my_safemalloc(sizeof(XPVIV))
 819 #define del_XIV(p)      my_safefree(p)
 820
 821 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
 822 #define del_XNV(p)      my_safefree(p)
 823
 824 #define new_XRV()       my_safemalloc(sizeof(XRV))
 825 #define del_XRV(p)      my_safefree(p)
 826
 827 #define new_XPV()       my_safemalloc(sizeof(XPV))
 828 #define del_XPV(p)      my_safefree(p)
 829
 830 #define new_XPVIV()     my_safemalloc(sizeof(XPVIV))
 831 #define del_XPVIV(p)    my_safefree(p)
 832
 833 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
 834 #define del_XPVNV(p)    my_safefree(p)
 835
 836 #define new_XPVCV()     my_safemalloc(sizeof(XPVCV))
 837 #define del_XPVCV(p)    my_safefree(p)
 838
 839 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
 840 #define del_XPVAV(p)    my_safefree(p)
 841
 842 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
 843 #define del_XPVHV(p)    my_safefree(p)
 844
 845 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
 846 #define del_XPVMG(p)    my_safefree(p)
 847
 848 #define new_XPVLV()     my_safemalloc(sizeof(XPVLV))
 849 #define del_XPVLV(p)    my_safefree(p)
 850
 851 #define new_XPVBM()     my_safemalloc(sizeof(XPVBM))
 852 #define del_XPVBM(p)    my_safefree(p)
 853
 854 #else /* !PURIFY */
 855
 856 #define new_XIV()       (void*)new_xiv()
 857 #define del_XIV(p)      del_xiv((XPVIV*) p)
 858
 859 #define new_XNV()       (void*)new_xnv()
 860 #define del_XNV(p)      del_xnv((XPVNV*) p)
 861
 862 #define new_XRV()       (void*)new_xrv()
 863 #define del_XRV(p)      del_xrv((XRV*) p)
 864
 865 #define new_XPV()       (void*)new_xpv()
 866 #define del_XPV(p)      del_xpv((XPV *)p)
 867
 868 #define new_XPVIV()     (void*)new_xpviv()
 869 #define del_XPVIV(p)    del_xpviv((XPVIV *)p)
 870
 871 #define new_XPVNV()     (void*)new_xpvnv()
 872 #define del_XPVNV(p)    del_xpvnv((XPVNV *)p)
 873
 874 #define new_XPVCV()     (void*)new_xpvcv()
 875 #define del_XPVCV(p)    del_xpvcv((XPVCV *)p)
 876
 877 #define new_XPVAV()     (void*)new_xpvav()
 878 #define del_XPVAV(p)    del_xpvav((XPVAV *)p)
 879
 880 #define new_XPVHV()     (void*)new_xpvhv()
 881 #define del_XPVHV(p)    del_xpvhv((XPVHV *)p)
 882
 883 #define new_XPVMG()     (void*)new_xpvmg()
 884 #define del_XPVMG(p)    del_xpvmg((XPVMG *)p)
 885
 886 #define new_XPVLV()     (void*)new_xpvlv()
 887 #define del_XPVLV(p)    del_xpvlv((XPVLV *)p)
 888
 889 #define new_XPVBM()     (void*)new_xpvbm()
 890 #define del_XPVBM(p)    del_xpvbm((XPVBM *)p)
 891
 892 #endif /* PURIFY */
 893
 894 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
 895 #define del_XPVGV(p)    my_safefree(p)
 896
 897 #define new_XPVFM()     my_safemalloc(sizeof(XPVFM))
 898 #define del_XPVFM(p)    my_safefree(p)
 899
 900 #define new_XPVIO()     my_safemalloc(sizeof(XPVIO))
 901 #define del_XPVIO(p)    my_safefree(p)
 902
 903 /*
 904 =for apidoc sv_upgrade
 905
 906 Upgrade an SV to a more complex form.  Use C<SvUPGRADE>.  See
 907 C<svtype>.
 908
 909 =cut
 910 */
 911
 912 bool
 913 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
 914 {
 915     char*       pv;
 916     U32         cur;
 917     U32         len;
 918     IV          iv;
 919     NV          nv;
 920     MAGIC*      magic;
 921     HV*         stash;
 922
 923     if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
 924         sv_force_normal(sv);
 925     }
 926
 927     if (SvTYPE(sv) == mt)
 928         return TRUE;
 929
 930     if (mt < SVt_PVIV)
 931         (void)SvOOK_off(sv);
 932
 933     switch (SvTYPE(sv)) {
 934     case SVt_NULL:
 935         pv      = 0;
 936         cur     = 0;
 937         len     = 0;
 938         iv      = 0;
 939         nv      = 0.0;
 940         magic   = 0;
 941         stash   = 0;
 942         break;
 943     case SVt_IV:
 944         pv      = 0;
 945         cur     = 0;
 946         len     = 0;
 947         iv      = SvIVX(sv);
 948         nv      = (NV)SvIVX(sv);
 949         del_XIV(SvANY(sv));
 950         magic   = 0;
 951         stash   = 0;
 952         if (mt == SVt_NV)
 953             mt = SVt_PVNV;
 954         else if (mt < SVt_PVIV)
 955             mt = SVt_PVIV;
 956         break;
 957     case SVt_NV:
 958         pv      = 0;
 959         cur     = 0;
 960         len     = 0;
 961         nv      = SvNVX(sv);
 962         iv      = I_V(nv);
 963         magic   = 0;
 964         stash   = 0;
 965         del_XNV(SvANY(sv));
 966         SvANY(sv) = 0;
 967         if (mt < SVt_PVNV)
 968             mt = SVt_PVNV;
 969         break;
 970     case SVt_RV:
 971         pv      = (char*)SvRV(sv);
 972         cur     = 0;
 973         len     = 0;
 974         iv      = PTR2IV(pv);
 975         nv      = PTR2NV(pv);
 976         del_XRV(SvANY(sv));
 977         magic   = 0;
 978         stash   = 0;
 979         break;
 980     case SVt_PV:
 981         pv      = SvPVX(sv);
 982         cur     = SvCUR(sv);
 983         len     = SvLEN(sv);
 984         iv      = 0;
 985         nv      = 0.0;
 986         magic   = 0;
 987         stash   = 0;
 988         del_XPV(SvANY(sv));
 989         if (mt <= SVt_IV)
 990             mt = SVt_PVIV;
 991         else if (mt == SVt_NV)
 992             mt = SVt_PVNV;
 993         break;
 994     case SVt_PVIV:
 995         pv      = SvPVX(sv);
 996         cur     = SvCUR(sv);
 997         len     = SvLEN(sv);
 998         iv      = SvIVX(sv);
 999         nv      = 0.0;
1000         magic   = 0;
1001         stash   = 0;
1002         del_XPVIV(SvANY(sv));
1003         break;
1004     case SVt_PVNV:
1005         pv      = SvPVX(sv);
1006         cur     = SvCUR(sv);
1007         len     = SvLEN(sv);
1008         iv      = SvIVX(sv);
1009         nv      = SvNVX(sv);
1010         magic   = 0;
1011         stash   = 0;
1012         del_XPVNV(SvANY(sv));
1013         break;
1014     case SVt_PVMG:
1015         pv      = SvPVX(sv);
1016         cur     = SvCUR(sv);
1017         len     = SvLEN(sv);
1018         iv      = SvIVX(sv);
1019         nv      = SvNVX(sv);
1020         magic   = SvMAGIC(sv);
1021         stash   = SvSTASH(sv);
1022         del_XPVMG(SvANY(sv));
1023         break;
1024     default:
1025         Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1026     }
1027
1028     switch (mt) {
1029     case SVt_NULL:
1030         Perl_croak(aTHX_ "Can't upgrade to undef");
1031     case SVt_IV:
1032         SvANY(sv) = new_XIV();
1033         SvIVX(sv)       = iv;
1034         break;
1035     case SVt_NV:
1036         SvANY(sv) = new_XNV();
1037         SvNVX(sv)       = nv;
1038         break;
1039     case SVt_RV:
1040         SvANY(sv) = new_XRV();
1041         SvRV(sv) = (SV*)pv;
1042         break;
1043     case SVt_PV:
1044         SvANY(sv) = new_XPV();
1045         SvPVX(sv)       = pv;
1046         SvCUR(sv)       = cur;
1047         SvLEN(sv)       = len;
1048         break;
1049     case SVt_PVIV:
1050         SvANY(sv) = new_XPVIV();
1051         SvPVX(sv)       = pv;
1052         SvCUR(sv)       = cur;
1053         SvLEN(sv)       = len;
1054         SvIVX(sv)       = iv;
1055         if (SvNIOK(sv))
1056             (void)SvIOK_on(sv);
1057         SvNOK_off(sv);
1058         break;
1059     case SVt_PVNV:
1060         SvANY(sv) = new_XPVNV();
1061         SvPVX(sv)       = pv;
1062         SvCUR(sv)       = cur;
1063         SvLEN(sv)       = len;
1064         SvIVX(sv)       = iv;
1065         SvNVX(sv)       = nv;
1066         break;
1067     case SVt_PVMG:
1068         SvANY(sv) = new_XPVMG();
1069         SvPVX(sv)       = pv;
1070         SvCUR(sv)       = cur;
1071         SvLEN(sv)       = len;
1072         SvIVX(sv)       = iv;
1073         SvNVX(sv)       = nv;
1074         SvMAGIC(sv)     = magic;
1075         SvSTASH(sv)     = stash;
1076         break;
1077     case SVt_PVLV:
1078         SvANY(sv) = new_XPVLV();
1079         SvPVX(sv)       = pv;
1080         SvCUR(sv)       = cur;
1081         SvLEN(sv)       = len;
1082         SvIVX(sv)       = iv;
1083         SvNVX(sv)       = nv;
1084         SvMAGIC(sv)     = magic;
1085         SvSTASH(sv)     = stash;
1086         LvTARGOFF(sv)   = 0;
1087         LvTARGLEN(sv)   = 0;
1088         LvTARG(sv)      = 0;
1089         LvTYPE(sv)      = 0;
1090         break;
1091     case SVt_PVAV:
1092         SvANY(sv) = new_XPVAV();
1093         if (pv)
1094             Safefree(pv);
1095         SvPVX(sv)       = 0;
1096         AvMAX(sv)       = -1;
1097         AvFILLp(sv)     = -1;
1098         SvIVX(sv)       = 0;
1099         SvNVX(sv)       = 0.0;
1100         SvMAGIC(sv)     = magic;
1101         SvSTASH(sv)     = stash;
1102         AvALLOC(sv)     = 0;
1103         AvARYLEN(sv)    = 0;
1104         AvFLAGS(sv)     = 0;
1105         break;
1106     case SVt_PVHV:
1107         SvANY(sv) = new_XPVHV();
1108         if (pv)
1109             Safefree(pv);
1110         SvPVX(sv)       = 0;
1111         HvFILL(sv)      = 0;
1112         HvMAX(sv)       = 0;
1113         HvKEYS(sv)      = 0;
1114         SvNVX(sv)       = 0.0;
1115         SvMAGIC(sv)     = magic;
1116         SvSTASH(sv)     = stash;
1117         HvRITER(sv)     = 0;
1118         HvEITER(sv)     = 0;
1119         HvPMROOT(sv)    = 0;
1120         HvNAME(sv)      = 0;
1121         break;
1122     case SVt_PVCV:
1123         SvANY(sv) = new_XPVCV();
1124         Zero(SvANY(sv), 1, XPVCV);
1125         SvPVX(sv)       = pv;
1126         SvCUR(sv)       = cur;
1127         SvLEN(sv)       = len;
1128         SvIVX(sv)       = iv;
1129         SvNVX(sv)       = nv;
1130         SvMAGIC(sv)     = magic;
1131         SvSTASH(sv)     = stash;
1132         break;
1133     case SVt_PVGV:
1134         SvANY(sv) = new_XPVGV();
1135         SvPVX(sv)       = pv;
1136         SvCUR(sv)       = cur;
1137         SvLEN(sv)       = len;
1138         SvIVX(sv)       = iv;
1139         SvNVX(sv)       = nv;
1140         SvMAGIC(sv)     = magic;
1141         SvSTASH(sv)     = stash;
1142         GvGP(sv)        = 0;
1143         GvNAME(sv)      = 0;
1144         GvNAMELEN(sv)   = 0;
1145         GvSTASH(sv)     = 0;
1146         GvFLAGS(sv)     = 0;
1147         break;
1148     case SVt_PVBM:
1149         SvANY(sv) = new_XPVBM();
1150         SvPVX(sv)       = pv;
1151         SvCUR(sv)       = cur;
1152         SvLEN(sv)       = len;
1153         SvIVX(sv)       = iv;
1154         SvNVX(sv)       = nv;
1155         SvMAGIC(sv)     = magic;
1156         SvSTASH(sv)     = stash;
1157         BmRARE(sv)      = 0;
1158         BmUSEFUL(sv)    = 0;
1159         BmPREVIOUS(sv)  = 0;
1160         break;
1161     case SVt_PVFM:
1162         SvANY(sv) = new_XPVFM();
1163         Zero(SvANY(sv), 1, XPVFM);
1164         SvPVX(sv)       = pv;
1165         SvCUR(sv)       = cur;
1166         SvLEN(sv)       = len;
1167         SvIVX(sv)       = iv;
1168         SvNVX(sv)       = nv;
1169         SvMAGIC(sv)     = magic;
1170         SvSTASH(sv)     = stash;
1171         break;
1172     case SVt_PVIO:
1173         SvANY(sv) = new_XPVIO();
1174         Zero(SvANY(sv), 1, XPVIO);
1175         SvPVX(sv)       = pv;
1176         SvCUR(sv)       = cur;
1177         SvLEN(sv)       = len;
1178         SvIVX(sv)       = iv;
1179         SvNVX(sv)       = nv;
1180         SvMAGIC(sv)     = magic;
1181         SvSTASH(sv)     = stash;
1182         IoPAGE_LEN(sv)  = 60;
1183         break;
1184     }
1185     SvFLAGS(sv) &= ~SVTYPEMASK;
1186     SvFLAGS(sv) |= mt;
1187     return TRUE;
1188 }
1189
1190 int
1191 Perl_sv_backoff(pTHX_ register SV *sv)
1192 {
1193     assert(SvOOK(sv));
1194     if (SvIVX(sv)) {
1195         char *s = SvPVX(sv);
1196         SvLEN(sv) += SvIVX(sv);
1197         SvPVX(sv) -= SvIVX(sv);
1198         SvIV_set(sv, 0);
1199         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1200     }
1201     SvFLAGS(sv) &= ~SVf_OOK;
1202     return 0;
1203 }
1204
1205 /*
1206 =for apidoc sv_grow
1207
1208 Expands the character buffer in the SV.  This will use C<sv_unref> and will
1209 upgrade the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1210 Use C<SvGROW>.
1211
1212 =cut
1213 */
1214
1215 char *
1216 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1217 {
1218     register char *s;
1219
1220 #ifdef HAS_64K_LIMIT
1221     if (newlen >= 0x10000) {
1222         PerlIO_printf(Perl_debug_log,
1223                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1224         my_exit(1);
1225     }
1226 #endif /* HAS_64K_LIMIT */
1227     if (SvROK(sv))
1228         sv_unref(sv);
1229     if (SvTYPE(sv) < SVt_PV) {
1230         sv_upgrade(sv, SVt_PV);
1231         s = SvPVX(sv);
1232     }
1233     else if (SvOOK(sv)) {       /* pv is offset? */
1234         sv_backoff(sv);
1235         s = SvPVX(sv);
1236         if (newlen > SvLEN(sv))
1237             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1238 #ifdef HAS_64K_LIMIT
1239         if (newlen >= 0x10000)
1240             newlen = 0xFFFF;
1241 #endif
1242     }
1243     else
1244         s = SvPVX(sv);
1245     if (newlen > SvLEN(sv)) {           /* need more room? */
1246         if (SvLEN(sv) && s) {
1247 #if defined(MYMALLOC) && !defined(LEAKTEST)
1248             STRLEN l = malloced_size((void*)SvPVX(sv));
1249             if (newlen <= l) {
1250                 SvLEN_set(sv, l);
1251                 return s;
1252             } else
1253 #endif
1254             Renew(s,newlen,char);
1255         }
1256         else
1257             New(703,s,newlen,char);
1258         SvPV_set(sv, s);
1259         SvLEN_set(sv, newlen);
1260     }
1261     return s;
1262 }
1263
1264 /*
1265 =for apidoc sv_setiv
1266
1267 Copies an integer into the given SV.  Does not handle 'set' magic.  See
1268 C<sv_setiv_mg>.
1269
1270 =cut
1271 */
1272
1273 void
1274 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1275 {
1276     SV_CHECK_THINKFIRST(sv);
1277     switch (SvTYPE(sv)) {
1278     case SVt_NULL:
1279         sv_upgrade(sv, SVt_IV);
1280         break;
1281     case SVt_NV:
1282         sv_upgrade(sv, SVt_PVNV);
1283         break;
1284     case SVt_RV:
1285     case SVt_PV:
1286         sv_upgrade(sv, SVt_PVIV);
1287         break;
1288
1289     case SVt_PVGV:
1290     case SVt_PVAV:
1291     case SVt_PVHV:
1292     case SVt_PVCV:
1293     case SVt_PVFM:
1294     case SVt_PVIO:
1295         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1296                    PL_op_desc[PL_op->op_type]);
1297     }
1298     (void)SvIOK_only(sv);                       /* validate number */
1299     SvIVX(sv) = i;
1300     SvTAINT(sv);
1301 }
1302
1303 /*
1304 =for apidoc sv_setiv_mg
1305
1306 Like C<sv_setiv>, but also handles 'set' magic.
1307
1308 =cut
1309 */
1310
1311 void
1312 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1313 {
1314     sv_setiv(sv,i);
1315     SvSETMAGIC(sv);
1316 }
1317
1318 /*
1319 =for apidoc sv_setuv
1320
1321 Copies an unsigned integer into the given SV.  Does not handle 'set' magic.
1322 See C<sv_setuv_mg>.
1323
1324 =cut
1325 */
1326
1327 void
1328 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1329 {
1330     /* With these two if statements:
1331        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1332
1333        without
1334        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1335
1336        If you wish to remove them, please benchmark to see what the effect is
1337     */
1338     if (u <= (UV)IV_MAX) {
1339        sv_setiv(sv, (IV)u);
1340        return;
1341     }
1342     sv_setiv(sv, 0);
1343     SvIsUV_on(sv);
1344     SvUVX(sv) = u;
1345 }
1346
1347 /*
1348 =for apidoc sv_setuv_mg
1349
1350 Like C<sv_setuv>, but also handles 'set' magic.
1351
1352 =cut
1353 */
1354
1355 void
1356 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1357 {
1358     /* With these two if statements:
1359        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1360
1361        without
1362        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1363
1364        If you wish to remove them, please benchmark to see what the effect is
1365     */
1366     if (u <= (UV)IV_MAX) {
1367        sv_setiv(sv, (IV)u);
1368     } else {
1369        sv_setiv(sv, 0);
1370        SvIsUV_on(sv);
1371        sv_setuv(sv,u);
1372     }
1373     SvSETMAGIC(sv);
1374 }
1375
1376 /*
1377 =for apidoc sv_setnv
1378
1379 Copies a double into the given SV.  Does not handle 'set' magic.  See
1380 C<sv_setnv_mg>.
1381
1382 =cut
1383 */
1384
1385 void
1386 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1387 {
1388     SV_CHECK_THINKFIRST(sv);
1389     switch (SvTYPE(sv)) {
1390     case SVt_NULL:
1391     case SVt_IV:
1392         sv_upgrade(sv, SVt_NV);
1393         break;
1394     case SVt_RV:
1395     case SVt_PV:
1396     case SVt_PVIV:
1397         sv_upgrade(sv, SVt_PVNV);
1398         break;
1399
1400     case SVt_PVGV:
1401     case SVt_PVAV:
1402     case SVt_PVHV:
1403     case SVt_PVCV:
1404     case SVt_PVFM:
1405     case SVt_PVIO:
1406         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1407                    PL_op_name[PL_op->op_type]);
1408     }
1409     SvNVX(sv) = num;
1410     (void)SvNOK_only(sv);                       /* validate number */
1411     SvTAINT(sv);
1412 }
1413
1414 /*
1415 =for apidoc sv_setnv_mg
1416
1417 Like C<sv_setnv>, but also handles 'set' magic.
1418
1419 =cut
1420 */
1421
1422 void
1423 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1424 {
1425     sv_setnv(sv,num);
1426     SvSETMAGIC(sv);
1427 }
1428
1429 STATIC void
1430 S_not_a_number(pTHX_ SV *sv)
1431 {
1432     char tmpbuf[64];
1433     char *d = tmpbuf;
1434     char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1435                   /* each *s can expand to 4 chars + "...\0",
1436                      i.e. need room for 8 chars */
1437
1438     char *s, *end;
1439     for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1440         int ch = *s & 0xFF;
1441         if (ch & 128 && !isPRINT_LC(ch)) {
1442             *d++ = 'M';
1443             *d++ = '-';
1444             ch &= 127;
1445         }
1446         if (ch == '\n') {
1447             *d++ = '\\';
1448             *d++ = 'n';
1449         }
1450         else if (ch == '\r') {
1451             *d++ = '\\';
1452             *d++ = 'r';
1453         }
1454         else if (ch == '\f') {
1455             *d++ = '\\';
1456             *d++ = 'f';
1457         }
1458         else if (ch == '\\') {
1459             *d++ = '\\';
1460             *d++ = '\\';
1461         }
1462         else if (ch == '\0') {
1463             *d++ = '\\';
1464             *d++ = '0';
1465         }
1466         else if (isPRINT_LC(ch))
1467             *d++ = ch;
1468         else {
1469             *d++ = '^';
1470             *d++ = toCTRL(ch);
1471         }
1472     }
1473     if (s < end) {
1474         *d++ = '.';
1475         *d++ = '.';
1476         *d++ = '.';
1477     }
1478     *d = '\0';
1479
1480     if (PL_op)
1481         Perl_warner(aTHX_ WARN_NUMERIC,
1482                     "Argument \"%s\" isn't numeric in %s", tmpbuf,
1483                 PL_op_desc[PL_op->op_type]);
1484     else
1485         Perl_warner(aTHX_ WARN_NUMERIC,
1486                     "Argument \"%s\" isn't numeric", tmpbuf);
1487 }
1488
1489 /*
1490 =for apidoc looks_like_number
1491
1492 Test if an the content of an SV looks like a number (or is a
1493 number). C<Inf> and C<Infinity> are treated as numbers (so will not
1494 issue a non-numeric warning), even if your atof() doesn't grok them.
1495
1496 =cut
1497 */
1498
1499 I32
1500 Perl_looks_like_number(pTHX_ SV *sv)
1501 {
1502     register char *sbegin;
1503     STRLEN len;
1504
1505     if (SvPOK(sv)) {
1506         sbegin = SvPVX(sv);
1507         len = SvCUR(sv);
1508     }
1509     else if (SvPOKp(sv))
1510         sbegin = SvPV(sv, len);
1511     else
1512         return 1; /* Historic.  Wrong?  */
1513     return grok_number(sbegin, len, NULL);
1514 }
1515
1516 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1517    until proven guilty, assume that things are not that bad... */
1518
1519 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1520    an IV (an assumption perl has been based on to date) it becomes necessary
1521    to remove the assumption that the NV always carries enough precision to
1522    recreate the IV whenever needed, and that the NV is the canonical form.
1523    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1524    precision as an side effect of conversion (which would lead to insanity
1525    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1526    1) to distinguish between IV/UV/NV slots that have cached a valid
1527       conversion where precision was lost and IV/UV/NV slots that have a
1528       valid conversion which has lost no precision
1529    2) to ensure that if a numeric conversion to one form is request that
1530       would lose precision, the precise conversion (or differently
1531       imprecise conversion) is also performed and cached, to prevent
1532       requests for different numeric formats on the same SV causing
1533       lossy conversion chains. (lossless conversion chains are perfectly
1534       acceptable (still))
1535
1536
1537    flags are used:
1538    SvIOKp is true if the IV slot contains a valid value
1539    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1540    SvNOKp is true if the NV slot contains a valid value
1541    SvNOK  is true only if the NV value is accurate
1542
1543    so
1544    while converting from PV to NV check to see if converting that NV to an
1545    IV(or UV) would lose accuracy over a direct conversion from PV to
1546    IV(or UV). If it would, cache both conversions, return NV, but mark
1547    SV as IOK NOKp (ie not NOK).
1548
1549    while converting from PV to IV check to see if converting that IV to an
1550    NV would lose accuracy over a direct conversion from PV to NV. If it
1551    would, cache both conversions, flag similarly.
1552
1553    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1554    correctly because if IV & NV were set NV *always* overruled.
1555    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1556    changes - now IV and NV together means that the two are interchangeable
1557    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1558
1559    The benefit of this is operations such as pp_add know that if SvIOK is
1560    true for both left and right operands, then integer addition can be
1561    used instead of floating point. (for cases where the result won't
1562    overflow) Before, floating point was always used, which could lead to
1563    loss of precision compared with integer addition.
1564
1565    * making IV and NV equal status should make maths accurate on 64 bit
1566      platforms
1567    * may speed up maths somewhat if pp_add and friends start to use
1568      integers when possible instead of fp. (hopefully the overhead in
1569      looking for SvIOK and checking for overflow will not outweigh the
1570      fp to integer speedup)
1571    * will slow down integer operations (callers of SvIV) on "inaccurate"
1572      values, as the change from SvIOK to SvIOKp will cause a call into
1573      sv_2iv each time rather than a macro access direct to the IV slot
1574    * should speed up number->string conversion on integers as IV is
1575      favoured when IV and NV equally accurate
1576
1577    ####################################################################
1578    You had better be using SvIOK_notUV if you want an IV for arithmetic
1579    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1580    SvUOK is true iff UV.
1581    ####################################################################
1582
1583    Your mileage will vary depending your CPUs relative fp to integer
1584    performance ratio.
1585 */
1586
1587 #ifndef NV_PRESERVES_UV
1588 #define IS_NUMBER_UNDERFLOW_IV 1
1589 #define IS_NUMBER_UNDERFLOW_UV 2
1590 #define IS_NUMBER_IV_AND_UV 2
1591 #define IS_NUMBER_OVERFLOW_IV 4
1592 #define IS_NUMBER_OVERFLOW_UV 5
1593
1594 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1595 STATIC int
1596 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1597 {
1598     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1599     if (SvNVX(sv) < (NV)IV_MIN) {
1600         (void)SvIOKp_on(sv);
1601         (void)SvNOK_on(sv);
1602         SvIVX(sv) = IV_MIN;
1603         return IS_NUMBER_UNDERFLOW_IV;
1604     }
1605     if (SvNVX(sv) > (NV)UV_MAX) {
1606         (void)SvIOKp_on(sv);
1607         (void)SvNOK_on(sv);
1608         SvIsUV_on(sv);
1609         SvUVX(sv) = UV_MAX;
1610         return IS_NUMBER_OVERFLOW_UV;
1611     }
1612     (void)SvIOKp_on(sv);
1613     (void)SvNOK_on(sv);
1614     /* Can't use strtol etc to convert this string.  (See truth table in
1615        sv_2iv  */
1616     if (SvNVX(sv) <= (UV)IV_MAX) {
1617         SvIVX(sv) = I_V(SvNVX(sv));
1618         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1619             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1620         } else {
1621             /* Integer is imprecise. NOK, IOKp */
1622         }
1623         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1624     }
1625     SvIsUV_on(sv);
1626     SvUVX(sv) = U_V(SvNVX(sv));
1627     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1628         if (SvUVX(sv) == UV_MAX) {
1629             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1630                possibly be preserved by NV. Hence, it must be overflow.
1631                NOK, IOKp */
1632             return IS_NUMBER_OVERFLOW_UV;
1633         }
1634         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1635     } else {
1636         /* Integer is imprecise. NOK, IOKp */
1637     }
1638     return IS_NUMBER_OVERFLOW_IV;
1639 }
1640 #endif /* NV_PRESERVES_UV*/
1641
1642 IV
1643 Perl_sv_2iv(pTHX_ register SV *sv)
1644 {
1645     if (!sv)
1646         return 0;
1647     if (SvGMAGICAL(sv)) {
1648         mg_get(sv);
1649         if (SvIOKp(sv))
1650             return SvIVX(sv);
1651         if (SvNOKp(sv)) {
1652             return I_V(SvNVX(sv));
1653         }
1654         if (SvPOKp(sv) && SvLEN(sv))
1655             return asIV(sv);
1656         if (!SvROK(sv)) {
1657             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1658                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1659                     report_uninit();
1660             }
1661             return 0;
1662         }
1663     }
1664     if (SvTHINKFIRST(sv)) {
1665         if (SvROK(sv)) {
1666           SV* tmpstr;
1667           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1668                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1669               return SvIV(tmpstr);
1670           return PTR2IV(SvRV(sv));
1671         }
1672         if (SvREADONLY(sv) && SvFAKE(sv)) {
1673             sv_force_normal(sv);
1674         }
1675         if (SvREADONLY(sv) && !SvOK(sv)) {
1676             if (ckWARN(WARN_UNINITIALIZED))
1677                 report_uninit();
1678             return 0;
1679         }
1680     }
1681     if (SvIOKp(sv)) {
1682         if (SvIsUV(sv)) {
1683             return (IV)(SvUVX(sv));
1684         }
1685         else {
1686             return SvIVX(sv);
1687         }
1688     }
1689     if (SvNOKp(sv)) {
1690         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1691          * without also getting a cached IV/UV from it at the same time
1692          * (ie PV->NV conversion should detect loss of accuracy and cache
1693          * IV or UV at same time to avoid this.  NWC */
1694
1695         if (SvTYPE(sv) == SVt_NV)
1696             sv_upgrade(sv, SVt_PVNV);
1697
1698         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1699         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1700            certainly cast into the IV range at IV_MAX, whereas the correct
1701            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1702            cases go to UV */
1703         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1704             SvIVX(sv) = I_V(SvNVX(sv));
1705             if (SvNVX(sv) == (NV) SvIVX(sv)
1706 #ifndef NV_PRESERVES_UV
1707                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1708                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1709                 /* Don't flag it as "accurately an integer" if the number
1710                    came from a (by definition imprecise) NV operation, and
1711                    we're outside the range of NV integer precision */
1712 #endif
1713                 ) {
1714                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
1715                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1716                                       "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1717                                       PTR2UV(sv),
1718                                       SvNVX(sv),
1719                                       SvIVX(sv)));
1720
1721             } else {
1722                 /* IV not precise.  No need to convert from PV, as NV
1723                    conversion would already have cached IV if it detected
1724                    that PV->IV would be better than PV->NV->IV
1725                    flags already correct - don't set public IOK.  */
1726                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1727                                       "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1728                                       PTR2UV(sv),
1729                                       SvNVX(sv),
1730                                       SvIVX(sv)));
1731             }
1732             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1733                but the cast (NV)IV_MIN rounds to a the value less (more
1734                negative) than IV_MIN which happens to be equal to SvNVX ??
1735                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1736                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1737                (NV)UVX == NVX are both true, but the values differ. :-(
1738                Hopefully for 2s complement IV_MIN is something like
1739                0x8000000000000000 which will be exact. NWC */
1740         }
1741         else {
1742             SvUVX(sv) = U_V(SvNVX(sv));
1743             if (
1744                 (SvNVX(sv) == (NV) SvUVX(sv))
1745 #ifndef  NV_PRESERVES_UV
1746                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1747                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1748                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1749                 /* Don't flag it as "accurately an integer" if the number
1750                    came from a (by definition imprecise) NV operation, and
1751                    we're outside the range of NV integer precision */
1752 #endif
1753                 )
1754                 SvIOK_on(sv);
1755             SvIsUV_on(sv);
1756           ret_iv_max:
1757             DEBUG_c(PerlIO_printf(Perl_debug_log,
1758                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1759                                   PTR2UV(sv),
1760                                   SvUVX(sv),
1761                                   SvUVX(sv)));
1762             return (IV)SvUVX(sv);
1763         }
1764     }
1765     else if (SvPOKp(sv) && SvLEN(sv)) {
1766         UV value;
1767         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
1768         /* We want to avoid a possible problem when we cache an IV which
1769            may be later translated to an NV, and the resulting NV is not
1770            the same as the direct translation of the initial string
1771            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1772            be careful to ensure that the value with the .456 is around if the
1773            NV value is requested in the future).
1774
1775            This means that if we cache such an IV, we need to cache the
1776            NV as well.  Moreover, we trade speed for space, and do not
1777            cache the NV if we are sure it's not needed.
1778          */
1779
1780         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
1781         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1782              == IS_NUMBER_IN_UV) {
1783             /* It's defintately an integer, only upgrade to PVIV */
1784             if (SvTYPE(sv) < SVt_PVIV)
1785                 sv_upgrade(sv, SVt_PVIV);
1786             (void)SvIOK_on(sv);
1787         } else if (SvTYPE(sv) < SVt_PVNV)
1788             sv_upgrade(sv, SVt_PVNV);
1789
1790         /* If NV preserves UV then we only use the UV value if we know that
1791            we aren't going to call atof() below. If NVs don't preserve UVs
1792            then the value returned may have more precision than atof() will
1793            return, even though value isn't perfectly accurate.  */
1794         if ((numtype & (IS_NUMBER_IN_UV
1795 #ifdef NV_PRESERVES_UV
1796                         | IS_NUMBER_NOT_INT
1797 #endif
1798             )) == IS_NUMBER_IN_UV) {
1799             /* This won't turn off the public IOK flag if it was set above  */
1800             (void)SvIOKp_on(sv);
1801
1802             if (!(numtype & IS_NUMBER_NEG)) {
1803                 /* positive */;
1804                 if (value <= (UV)IV_MAX) {
1805                     SvIVX(sv) = (IV)value;
1806                 } else {
1807                     SvUVX(sv) = value;
1808                     SvIsUV_on(sv);
1809                 }
1810             } else {
1811                 /* 2s complement assumption  */
1812                 if (value <= (UV)IV_MIN) {
1813                     SvIVX(sv) = -(IV)value;
1814                 } else {
1815                     /* Too negative for an IV.  This is a double upgrade, but
1816                        I'm assuming it will be be rare.  */
1817                     if (SvTYPE(sv) < SVt_PVNV)
1818                         sv_upgrade(sv, SVt_PVNV);
1819                     SvNOK_on(sv);
1820                     SvIOK_off(sv);
1821                     SvIOKp_on(sv);
1822                     SvNVX(sv) = -(NV)value;
1823                     SvIVX(sv) = IV_MIN;
1824                 }
1825             }
1826         }
1827         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
1828            will be in the previous block to set the IV slot, and the next
1829            block to set the NV slot.  So no else here.  */
1830
1831         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1832             != IS_NUMBER_IN_UV) {
1833             /* It wasn't an (integer that doesn't overflow the UV). */
1834             SvNVX(sv) = Atof(SvPVX(sv));
1835
1836             if (! numtype && ckWARN(WARN_NUMERIC))
1837                 not_a_number(sv);
1838
1839 #if defined(USE_LONG_DOUBLE)
1840             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1841                                   PTR2UV(sv), SvNVX(sv)));
1842 #else
1843             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1844                                   PTR2UV(sv), SvNVX(sv)));
1845 #endif
1846
1847
1848 #ifdef NV_PRESERVES_UV
1849             (void)SvIOKp_on(sv);
1850             (void)SvNOK_on(sv);
1851             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1852                 SvIVX(sv) = I_V(SvNVX(sv));
1853                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1854                     SvIOK_on(sv);
1855                 } else {
1856                     /* Integer is imprecise. NOK, IOKp */
1857                 }
1858                 /* UV will not work better than IV */
1859             } else {
1860                 if (SvNVX(sv) > (NV)UV_MAX) {
1861                     SvIsUV_on(sv);
1862                     /* Integer is inaccurate. NOK, IOKp, is UV */
1863                     SvUVX(sv) = UV_MAX;
1864                     SvIsUV_on(sv);
1865                 } else {
1866                     SvUVX(sv) = U_V(SvNVX(sv));
1867                     /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1868                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1869                         SvIOK_on(sv);
1870                         SvIsUV_on(sv);
1871                     } else {
1872                         /* Integer is imprecise. NOK, IOKp, is UV */
1873                         SvIsUV_on(sv);
1874                     }
1875                 }
1876                 goto ret_iv_max;
1877             }
1878 #else /* NV_PRESERVES_UV */
1879             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1880                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
1881                 /* The IV slot will have been set from value returned by
1882                    grok_number above.  The NV slot has just been set using
1883                    Atof.  */
1884                 SvNOK_on(sv);
1885                 assert (SvIOKp(sv));
1886             } else {
1887                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1888                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1889                     /* Small enough to preserve all bits. */
1890                     (void)SvIOKp_on(sv);
1891                     SvNOK_on(sv);
1892                     SvIVX(sv) = I_V(SvNVX(sv));
1893                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
1894                         SvIOK_on(sv);
1895                     /* Assumption: first non-preserved integer is < IV_MAX,
1896                        this NV is in the preserved range, therefore: */
1897                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1898                           < (UV)IV_MAX)) {
1899                         Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
1900                     }
1901                 } else {
1902                     /* IN_UV NOT_INT
1903                          0      0       already failed to read UV.
1904                          0      1       already failed to read UV.
1905                          1      0       you won't get here in this case. IV/UV
1906                                         slot set, public IOK, Atof() unneeded.
1907                          1      1       already read UV.
1908                        so there's no point in sv_2iuv_non_preserve() attempting
1909                        to use atol, strtol, strtoul etc.  */
1910                     if (sv_2iuv_non_preserve (sv, numtype)
1911                         >= IS_NUMBER_OVERFLOW_IV)
1912                     goto ret_iv_max;
1913                 }
1914             }
1915 #endif /* NV_PRESERVES_UV */
1916         }
1917     } else  {
1918         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1919             report_uninit();
1920         if (SvTYPE(sv) < SVt_IV)
1921             /* Typically the caller expects that sv_any is not NULL now.  */
1922             sv_upgrade(sv, SVt_IV);
1923         return 0;
1924     }
1925     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1926         PTR2UV(sv),SvIVX(sv)));
1927     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1928 }
1929
1930 UV
1931 Perl_sv_2uv(pTHX_ register SV *sv)
1932 {
1933     if (!sv)
1934         return 0;
1935     if (SvGMAGICAL(sv)) {
1936         mg_get(sv);
1937         if (SvIOKp(sv))
1938             return SvUVX(sv);
1939         if (SvNOKp(sv))
1940             return U_V(SvNVX(sv));
1941         if (SvPOKp(sv) && SvLEN(sv))
1942             return asUV(sv);
1943         if (!SvROK(sv)) {
1944             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1945                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1946                     report_uninit();
1947             }
1948             return 0;
1949         }
1950     }
1951     if (SvTHINKFIRST(sv)) {
1952         if (SvROK(sv)) {
1953           SV* tmpstr;
1954           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1955                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1956               return SvUV(tmpstr);
1957           return PTR2UV(SvRV(sv));
1958         }
1959         if (SvREADONLY(sv) && SvFAKE(sv)) {
1960             sv_force_normal(sv);
1961         }
1962         if (SvREADONLY(sv) && !SvOK(sv)) {
1963             if (ckWARN(WARN_UNINITIALIZED))
1964                 report_uninit();
1965             return 0;
1966         }
1967     }
1968     if (SvIOKp(sv)) {
1969         if (SvIsUV(sv)) {
1970             return SvUVX(sv);
1971         }
1972         else {
1973             return (UV)SvIVX(sv);
1974         }
1975     }
1976     if (SvNOKp(sv)) {
1977         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1978          * without also getting a cached IV/UV from it at the same time
1979          * (ie PV->NV conversion should detect loss of accuracy and cache
1980          * IV or UV at same time to avoid this. */
1981         /* IV-over-UV optimisation - choose to cache IV if possible */
1982
1983         if (SvTYPE(sv) == SVt_NV)
1984             sv_upgrade(sv, SVt_PVNV);
1985
1986         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1987         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1988             SvIVX(sv) = I_V(SvNVX(sv));
1989             if (SvNVX(sv) == (NV) SvIVX(sv)
1990 #ifndef NV_PRESERVES_UV
1991                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1992                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1993                 /* Don't flag it as "accurately an integer" if the number
1994                    came from a (by definition imprecise) NV operation, and
1995                    we're outside the range of NV integer precision */
1996 #endif
1997                 ) {
1998                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
1999                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2000                                       "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2001                                       PTR2UV(sv),
2002                                       SvNVX(sv),
2003                                       SvIVX(sv)));
2004
2005             } else {
2006                 /* IV not precise.  No need to convert from PV, as NV
2007                    conversion would already have cached IV if it detected
2008                    that PV->IV would be better than PV->NV->IV
2009                    flags already correct - don't set public IOK.  */
2010                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2011                                       "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2012                                       PTR2UV(sv),
2013                                       SvNVX(sv),
2014                                       SvIVX(sv)));
2015             }
2016             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2017                but the cast (NV)IV_MIN rounds to a the value less (more
2018                negative) than IV_MIN which happens to be equal to SvNVX ??
2019                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2020                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2021                (NV)UVX == NVX are both true, but the values differ. :-(
2022                Hopefully for 2s complement IV_MIN is something like
2023                0x8000000000000000 which will be exact. NWC */
2024         }
2025         else {
2026             SvUVX(sv) = U_V(SvNVX(sv));
2027             if (
2028                 (SvNVX(sv) == (NV) SvUVX(sv))
2029 #ifndef  NV_PRESERVES_UV
2030                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2031                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2032                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2033                 /* Don't flag it as "accurately an integer" if the number
2034                    came from a (by definition imprecise) NV operation, and
2035                    we're outside the range of NV integer precision */
2036 #endif
2037                 )
2038                 SvIOK_on(sv);
2039             SvIsUV_on(sv);
2040             DEBUG_c(PerlIO_printf(Perl_debug_log,
2041                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2042                                   PTR2UV(sv),
2043                                   SvUVX(sv),
2044                                   SvUVX(sv)));
2045         }
2046     }
2047     else if (SvPOKp(sv) && SvLEN(sv)) {
2048         UV value;
2049         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2050
2051         /* We want to avoid a possible problem when we cache a UV which
2052            may be later translated to an NV, and the resulting NV is not
2053            the translation of the initial data.
2054
2055            This means that if we cache such a UV, we need to cache the
2056            NV as well.  Moreover, we trade speed for space, and do not
2057            cache the NV if not needed.
2058          */
2059
2060         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2061         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2062              == IS_NUMBER_IN_UV) {
2063             /* It's defintately an integer, only upgrade to PVIV */
2064             if (SvTYPE(sv) < SVt_PVIV)
2065                 sv_upgrade(sv, SVt_PVIV);
2066             (void)SvIOK_on(sv);
2067         } else if (SvTYPE(sv) < SVt_PVNV)
2068             sv_upgrade(sv, SVt_PVNV);
2069
2070         /* If NV preserves UV then we only use the UV value if we know that
2071            we aren't going to call atof() below. If NVs don't preserve UVs
2072            then the value returned may have more precision than atof() will
2073            return, even though it isn't accurate.  */
2074         if ((numtype & (IS_NUMBER_IN_UV
2075 #ifdef NV_PRESERVES_UV
2076                         | IS_NUMBER_NOT_INT
2077 #endif
2078             )) == IS_NUMBER_IN_UV) {
2079             /* This won't turn off the public IOK flag if it was set above  */
2080             (void)SvIOKp_on(sv);
2081
2082             if (!(numtype & IS_NUMBER_NEG)) {
2083                 /* positive */;
2084                 if (value <= (UV)IV_MAX) {
2085                     SvIVX(sv) = (IV)value;
2086                 } else {
2087                     /* it didn't overflow, and it was positive. */
2088                     SvUVX(sv) = value;
2089                     SvIsUV_on(sv);
2090                 }
2091             } else {
2092                 /* 2s complement assumption  */
2093                 if (value <= (UV)IV_MIN) {
2094                     SvIVX(sv) = -(IV)value;
2095                 } else {
2096                     /* Too negative for an IV.  This is a double upgrade, but
2097                        I'm assuming it will be be rare.  */
2098                     if (SvTYPE(sv) < SVt_PVNV)
2099                         sv_upgrade(sv, SVt_PVNV);
2100                     SvNOK_on(sv);
2101                     SvIOK_off(sv);
2102                     SvIOKp_on(sv);
2103                     SvNVX(sv) = -(NV)value;
2104                     SvIVX(sv) = IV_MIN;
2105                 }
2106             }
2107         }
2108
2109         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2110             != IS_NUMBER_IN_UV) {
2111             /* It wasn't an integer, or it overflowed the UV. */
2112             SvNVX(sv) = Atof(SvPVX(sv));
2113
2114             if (! numtype && ckWARN(WARN_NUMERIC))
2115                     not_a_number(sv);
2116
2117 #if defined(USE_LONG_DOUBLE)
2118             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2119                                   PTR2UV(sv), SvNVX(sv)));
2120 #else
2121             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2122                                   PTR2UV(sv), SvNVX(sv)));
2123 #endif
2124
2125 #ifdef NV_PRESERVES_UV
2126             (void)SvIOKp_on(sv);
2127             (void)SvNOK_on(sv);
2128             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2129                 SvIVX(sv) = I_V(SvNVX(sv));
2130                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2131                     SvIOK_on(sv);
2132                 } else {
2133                     /* Integer is imprecise. NOK, IOKp */
2134                 }
2135                 /* UV will not work better than IV */
2136             } else {
2137                 if (SvNVX(sv) > (NV)UV_MAX) {
2138                     SvIsUV_on(sv);
2139                     /* Integer is inaccurate. NOK, IOKp, is UV */
2140                     SvUVX(sv) = UV_MAX;
2141                     SvIsUV_on(sv);
2142                 } else {
2143                     SvUVX(sv) = U_V(SvNVX(sv));
2144                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2145                        NV preservse UV so can do correct comparison.  */
2146                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2147                         SvIOK_on(sv);
2148                         SvIsUV_on(sv);
2149                     } else {
2150                         /* Integer is imprecise. NOK, IOKp, is UV */
2151                         SvIsUV_on(sv);
2152                     }
2153                 }
2154             }
2155 #else /* NV_PRESERVES_UV */
2156             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2157                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2158                 /* The UV slot will have been set from value returned by
2159                    grok_number above.  The NV slot has just been set using
2160                    Atof.  */
2161                 SvNOK_on(sv);
2162                 assert (SvIOKp(sv));
2163             } else {
2164                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2165                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2166                     /* Small enough to preserve all bits. */
2167                     (void)SvIOKp_on(sv);
2168                     SvNOK_on(sv);
2169                     SvIVX(sv) = I_V(SvNVX(sv));
2170                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2171                         SvIOK_on(sv);
2172                     /* Assumption: first non-preserved integer is < IV_MAX,
2173                        this NV is in the preserved range, therefore: */
2174                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2175                           < (UV)IV_MAX)) {
2176                         Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2177                     }
2178                 } else
2179                     sv_2iuv_non_preserve (sv, numtype);
2180             }
2181 #endif /* NV_PRESERVES_UV */
2182         }
2183     }
2184     else  {
2185         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2186             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2187                 report_uninit();
2188         }
2189         if (SvTYPE(sv) < SVt_IV)
2190             /* Typically the caller expects that sv_any is not NULL now.  */
2191             sv_upgrade(sv, SVt_IV);
2192         return 0;
2193     }
2194
2195     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2196                           PTR2UV(sv),SvUVX(sv)));
2197     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2198 }
2199
2200 NV
2201 Perl_sv_2nv(pTHX_ register SV *sv)
2202 {
2203     if (!sv)
2204         return 0.0;
2205     if (SvGMAGICAL(sv)) {
2206         mg_get(sv);
2207         if (SvNOKp(sv))
2208             return SvNVX(sv);
2209         if (SvPOKp(sv) && SvLEN(sv)) {
2210             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2211                 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2212                 not_a_number(sv);
2213             return Atof(SvPVX(sv));
2214         }
2215         if (SvIOKp(sv)) {
2216             if (SvIsUV(sv))
2217                 return (NV)SvUVX(sv);
2218             else
2219                 return (NV)SvIVX(sv);
2220         }
2221         if (!SvROK(sv)) {
2222             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2223                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2224                     report_uninit();
2225             }
2226             return 0;
2227         }
2228     }
2229     if (SvTHINKFIRST(sv)) {
2230         if (SvROK(sv)) {
2231           SV* tmpstr;
2232           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2233                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2234               return SvNV(tmpstr);
2235           return PTR2NV(SvRV(sv));
2236         }
2237         if (SvREADONLY(sv) && SvFAKE(sv)) {
2238             sv_force_normal(sv);
2239         }
2240         if (SvREADONLY(sv) && !SvOK(sv)) {
2241             if (ckWARN(WARN_UNINITIALIZED))
2242                 report_uninit();
2243             return 0.0;
2244         }
2245     }
2246     if (SvTYPE(sv) < SVt_NV) {
2247         if (SvTYPE(sv) == SVt_IV)
2248             sv_upgrade(sv, SVt_PVNV);
2249         else
2250             sv_upgrade(sv, SVt_NV);
2251 #ifdef USE_LONG_DOUBLE
2252         DEBUG_c({
2253             STORE_NUMERIC_LOCAL_SET_STANDARD();
2254             PerlIO_printf(Perl_debug_log,
2255                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2256                           PTR2UV(sv), SvNVX(sv));
2257             RESTORE_NUMERIC_LOCAL();
2258         });
2259 #else
2260         DEBUG_c({
2261             STORE_NUMERIC_LOCAL_SET_STANDARD();
2262             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2263                           PTR2UV(sv), SvNVX(sv));
2264             RESTORE_NUMERIC_LOCAL();
2265         });
2266 #endif
2267     }
2268     else if (SvTYPE(sv) < SVt_PVNV)
2269         sv_upgrade(sv, SVt_PVNV);
2270     if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2271         SvNOK_on(sv);
2272     }
2273     else if (SvIOKp(sv)) {
2274         SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2275 #ifdef NV_PRESERVES_UV
2276         SvNOK_on(sv);
2277 #else
2278         /* Only set the public NV OK flag if this NV preserves the IV  */
2279         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2280         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2281                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2282             SvNOK_on(sv);
2283         else
2284             SvNOKp_on(sv);
2285 #endif
2286     }
2287     else if (SvPOKp(sv) && SvLEN(sv)) {
2288         UV value;
2289         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2290         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2291             not_a_number(sv);
2292 #ifdef NV_PRESERVES_UV
2293         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2294             == IS_NUMBER_IN_UV) {
2295             /* It's defintately an integer */
2296             SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2297         } else
2298             SvNVX(sv) = Atof(SvPVX(sv));
2299         SvNOK_on(sv);
2300 #else
2301         SvNVX(sv) = Atof(SvPVX(sv));
2302         /* Only set the public NV OK flag if this NV preserves the value in
2303            the PV at least as well as an IV/UV would.
2304            Not sure how to do this 100% reliably. */
2305         /* if that shift count is out of range then Configure's test is
2306            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2307            UV_BITS */
2308         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2309             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2310             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2311         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2312             /* Can't use strtol etc to convert this string, so don't try.
2313                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2314             SvNOK_on(sv);
2315         } else {
2316             /* value has been set.  It may not be precise.  */
2317             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2318                 /* 2s complement assumption for (UV)IV_MIN  */
2319                 SvNOK_on(sv); /* Integer is too negative.  */
2320             } else {
2321                 SvNOKp_on(sv);
2322                 SvIOKp_on(sv);
2323
2324                 if (numtype & IS_NUMBER_NEG) {
2325                     SvIVX(sv) = -(IV)value;
2326                 } else if (value <= (UV)IV_MAX) {
2327                     SvIVX(sv) = (IV)value;
2328                 } else {
2329                     SvUVX(sv) = value;
2330                     SvIsUV_on(sv);
2331                 }
2332
2333                 if (numtype & IS_NUMBER_NOT_INT) {
2334                     /* I believe that even if the original PV had decimals,
2335                        they are lost beyond the limit of the FP precision.
2336                        However, neither is canonical, so both only get p
2337                        flags.  NWC, 2000/11/25 */
2338                     /* Both already have p flags, so do nothing */
2339                 } else {
2340                     NV nv = SvNVX(sv);
2341                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2342                         if (SvIVX(sv) == I_V(nv)) {
2343                             SvNOK_on(sv);
2344                             SvIOK_on(sv);
2345                         } else {
2346                             SvIOK_on(sv);
2347                             /* It had no "." so it must be integer.  */
2348                         }
2349                     } else {
2350                         /* between IV_MAX and NV(UV_MAX).
2351                            Could be slightly > UV_MAX */
2352
2353                         if (numtype & IS_NUMBER_NOT_INT) {
2354                             /* UV and NV both imprecise.  */
2355                         } else {
2356                             UV nv_as_uv = U_V(nv);
2357
2358                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2359                                 SvNOK_on(sv);
2360                                 SvIOK_on(sv);
2361                             } else {
2362                                 SvIOK_on(sv);
2363                             }
2364                         }
2365                     }
2366                 }
2367             }
2368         }
2369 #endif /* NV_PRESERVES_UV */
2370     }
2371     else  {
2372         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2373             report_uninit();
2374         if (SvTYPE(sv) < SVt_NV)
2375             /* Typically the caller expects that sv_any is not NULL now.  */
2376             /* XXX Ilya implies that this is a bug in callers that assume this
2377                and ideally should be fixed.  */
2378             sv_upgrade(sv, SVt_NV);
2379         return 0.0;
2380     }
2381 #if defined(USE_LONG_DOUBLE)
2382     DEBUG_c({
2383         STORE_NUMERIC_LOCAL_SET_STANDARD();
2384         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2385                       PTR2UV(sv), SvNVX(sv));
2386         RESTORE_NUMERIC_LOCAL();
2387     });
2388 #else
2389     DEBUG_c({
2390         STORE_NUMERIC_LOCAL_SET_STANDARD();
2391         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2392                       PTR2UV(sv), SvNVX(sv));
2393         RESTORE_NUMERIC_LOCAL();
2394     });
2395 #endif
2396     return SvNVX(sv);
2397 }
2398
2399 /* Caller must validate PVX  */
2400 STATIC IV
2401 S_asIV(pTHX_ SV *sv)
2402 {
2403     UV value;
2404     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2405
2406     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2407         == IS_NUMBER_IN_UV) {
2408         /* It's defintately an integer */
2409         if (numtype & IS_NUMBER_NEG) {
2410             if (value < (UV)IV_MIN)
2411                 return -(IV)value;
2412         } else {
2413             if (value < (UV)IV_MAX)
2414                 return (IV)value;
2415         }
2416     }
2417     if (!numtype) {
2418         if (ckWARN(WARN_NUMERIC))
2419             not_a_number(sv);
2420     }
2421     return I_V(Atof(SvPVX(sv)));
2422 }
2423
2424 STATIC UV
2425 S_asUV(pTHX_ SV *sv)
2426 {
2427     UV value;
2428     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2429
2430     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2431         == IS_NUMBER_IN_UV) {
2432         /* It's defintately an integer */
2433         if (!(numtype & IS_NUMBER_NEG))
2434             return value;
2435     }
2436     if (!numtype) {
2437         if (ckWARN(WARN_NUMERIC))
2438             not_a_number(sv);
2439     }
2440     return U_V(Atof(SvPVX(sv)));
2441 }
2442
2443 char *
2444 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2445 {
2446     STRLEN n_a;
2447     return sv_2pv(sv, &n_a);
2448 }
2449
2450 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2451 static char *
2452 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2453 {
2454     char *ptr = buf + TYPE_CHARS(UV);
2455     char *ebuf = ptr;
2456     int sign;
2457
2458     if (is_uv)
2459         sign = 0;
2460     else if (iv >= 0) {
2461         uv = iv;
2462         sign = 0;
2463     } else {
2464         uv = -iv;
2465         sign = 1;
2466     }
2467     do {
2468         *--ptr = '0' + (uv % 10);
2469     } while (uv /= 10);
2470     if (sign)
2471         *--ptr = '-';
2472     *peob = ebuf;
2473     return ptr;
2474 }
2475
2476 char *
2477 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2478 {
2479     return sv_2pv_flags(sv, lp, SV_GMAGIC);
2480 }
2481
2482 char *
2483 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2484 {
2485     register char *s;
2486     int olderrno;
2487     SV *tsv;
2488     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2489     char *tmpbuf = tbuf;
2490
2491     if (!sv) {
2492         *lp = 0;
2493         return "";
2494     }
2495     if (SvGMAGICAL(sv)) {
2496         if (flags & SV_GMAGIC)
2497             mg_get(sv);
2498         if (SvPOKp(sv)) {
2499             *lp = SvCUR(sv);
2500             return SvPVX(sv);
2501         }
2502         if (SvIOKp(sv)) {
2503             if (SvIsUV(sv))
2504                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2505             else
2506                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2507             tsv = Nullsv;
2508             goto tokensave;
2509         }
2510         if (SvNOKp(sv)) {
2511             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2512             tsv = Nullsv;
2513             goto tokensave;
2514         }
2515         if (!SvROK(sv)) {
2516             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2517                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2518                     report_uninit();
2519             }
2520             *lp = 0;
2521             return "";
2522         }
2523     }
2524     if (SvTHINKFIRST(sv)) {
2525         if (SvROK(sv)) {
2526             SV* tmpstr;
2527             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2528                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2529                 return SvPV(tmpstr,*lp);
2530             sv = (SV*)SvRV(sv);
2531             if (!sv)
2532                 s = "NULLREF";
2533             else {
2534                 MAGIC *mg;
2535
2536                 switch (SvTYPE(sv)) {
2537                 case SVt_PVMG:
2538                     if ( ((SvFLAGS(sv) &
2539                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2540                           == (SVs_OBJECT|SVs_RMG))
2541                          && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2542                          && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2543                         regexp *re = (regexp *)mg->mg_obj;
2544
2545                         if (!mg->mg_ptr) {
2546                             char *fptr = "msix";
2547                             char reflags[6];
2548                             char ch;
2549                             int left = 0;
2550                             int right = 4;
2551                             U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2552
2553                             while((ch = *fptr++)) {
2554                                 if(reganch & 1) {
2555                                     reflags[left++] = ch;
2556                                 }
2557                                 else {
2558                                     reflags[right--] = ch;
2559                                 }
2560                                 reganch >>= 1;
2561                             }
2562                             if(left != 4) {
2563                                 reflags[left] = '-';
2564                                 left = 5;
2565                             }
2566
2567                             mg->mg_len = re->prelen + 4 + left;
2568                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2569                             Copy("(?", mg->mg_ptr, 2, char);
2570                             Copy(reflags, mg->mg_ptr+2, left, char);
2571                             Copy(":", mg->mg_ptr+left+2, 1, char);
2572                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2573                             mg->mg_ptr[mg->mg_len - 1] = ')';
2574                             mg->mg_ptr[mg->mg_len] = 0;
2575                         }
2576                         PL_reginterp_cnt += re->program[0].next_off;
2577                         *lp = mg->mg_len;
2578                         return mg->mg_ptr;
2579                     }
2580                                         /* Fall through */
2581                 case SVt_NULL:
2582                 case SVt_IV:
2583                 case SVt_NV:
2584                 case SVt_RV:
2585                 case SVt_PV:
2586                 case SVt_PVIV:
2587                 case SVt_PVNV:
2588                 case SVt_PVBM:  if (SvROK(sv))
2589                                     s = "REF";
2590                                 else
2591                                     s = "SCALAR";               break;
2592                 case SVt_PVLV:  s = "LVALUE";                   break;
2593                 case SVt_PVAV:  s = "ARRAY";                    break;
2594                 case SVt_PVHV:  s = "HASH";                     break;
2595                 case SVt_PVCV:  s = "CODE";                     break;
2596                 case SVt_PVGV:  s = "GLOB";                     break;
2597                 case SVt_PVFM:  s = "FORMAT";                   break;
2598                 case SVt_PVIO:  s = "IO";                       break;
2599                 default:        s = "UNKNOWN";                  break;
2600                 }
2601                 tsv = NEWSV(0,0);
2602                 if (SvOBJECT(sv))
2603                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2604                 else
2605                     sv_setpv(tsv, s);
2606                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2607                 goto tokensaveref;
2608             }
2609             *lp = strlen(s);
2610             return s;
2611         }
2612         if (SvREADONLY(sv) && !SvOK(sv)) {
2613             if (ckWARN(WARN_UNINITIALIZED))
2614                 report_uninit();
2615             *lp = 0;
2616             return "";
2617         }
2618     }
2619     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2620         /* I'm assuming that if both IV and NV are equally valid then
2621            converting the IV is going to be more efficient */
2622         U32 isIOK = SvIOK(sv);
2623         U32 isUIOK = SvIsUV(sv);
2624         char buf[TYPE_CHARS(UV)];
2625         char *ebuf, *ptr;
2626
2627         if (SvTYPE(sv) < SVt_PVIV)
2628             sv_upgrade(sv, SVt_PVIV);
2629         if (isUIOK)
2630             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2631         else
2632             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2633         SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
2634         Move(ptr,SvPVX(sv),ebuf - ptr,char);
2635         SvCUR_set(sv, ebuf - ptr);
2636         s = SvEND(sv);
2637         *s = '\0';
2638         if (isIOK)
2639             SvIOK_on(sv);
2640         else
2641             SvIOKp_on(sv);
2642         if (isUIOK)
2643             SvIsUV_on(sv);
2644     }
2645     else if (SvNOKp(sv)) {
2646         if (SvTYPE(sv) < SVt_PVNV)
2647             sv_upgrade(sv, SVt_PVNV);
2648         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2649         SvGROW(sv, NV_DIG + 20);
2650         s = SvPVX(sv);
2651         olderrno = errno;       /* some Xenix systems wipe out errno here */
2652 #ifdef apollo
2653         if (SvNVX(sv) == 0.0)
2654             (void)strcpy(s,"0");
2655         else
2656 #endif /*apollo*/
2657         {
2658             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2659         }
2660         errno = olderrno;
2661 #ifdef FIXNEGATIVEZERO
2662         if (*s == '-' && s[1] == '0' && !s[2])
2663             strcpy(s,"0");
2664 #endif
2665         while (*s) s++;
2666 #ifdef hcx
2667         if (s[-1] == '.')
2668             *--s = '\0';
2669 #endif
2670     }
2671     else {
2672         if (ckWARN(WARN_UNINITIALIZED)
2673             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2674             report_uninit();
2675         *lp = 0;
2676         if (SvTYPE(sv) < SVt_PV)
2677             /* Typically the caller expects that sv_any is not NULL now.  */
2678             sv_upgrade(sv, SVt_PV);
2679         return "";
2680     }
2681     *lp = s - SvPVX(sv);
2682     SvCUR_set(sv, *lp);
2683     SvPOK_on(sv);
2684     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2685                           PTR2UV(sv),SvPVX(sv)));
2686     return SvPVX(sv);
2687
2688   tokensave:
2689     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
2690         /* Sneaky stuff here */
2691
2692       tokensaveref:
2693         if (!tsv)
2694             tsv = newSVpv(tmpbuf, 0);
2695         sv_2mortal(tsv);
2696         *lp = SvCUR(tsv);
2697         return SvPVX(tsv);
2698     }
2699     else {
2700         STRLEN len;
2701         char *t;
2702
2703         if (tsv) {
2704             sv_2mortal(tsv);
2705             t = SvPVX(tsv);
2706             len = SvCUR(tsv);
2707         }
2708         else {
2709             t = tmpbuf;
2710             len = strlen(tmpbuf);
2711         }
2712 #ifdef FIXNEGATIVEZERO
2713         if (len == 2 && t[0] == '-' && t[1] == '0') {
2714             t = "0";
2715             len = 1;
2716         }
2717 #endif
2718         (void)SvUPGRADE(sv, SVt_PV);
2719         *lp = len;
2720         s = SvGROW(sv, len + 1);
2721         SvCUR_set(sv, len);
2722         (void)strcpy(s, t);
2723         SvPOKp_on(sv);
2724         return s;
2725     }
2726 }
2727
2728 char *
2729 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2730 {
2731     STRLEN n_a;
2732     return sv_2pvbyte(sv, &n_a);
2733 }
2734
2735 char *
2736 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2737 {
2738     sv_utf8_downgrade(sv,0);
2739     return SvPV(sv,*lp);
2740 }
2741
2742 char *
2743 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2744 {
2745     STRLEN n_a;
2746     return sv_2pvutf8(sv, &n_a);
2747 }
2748
2749 char *
2750 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2751 {
2752     sv_utf8_upgrade(sv);
2753     return SvPV(sv,*lp);
2754 }
2755
2756 /* This function is only called on magical items */
2757 bool
2758 Perl_sv_2bool(pTHX_ register SV *sv)
2759 {
2760     if (SvGMAGICAL(sv))
2761         mg_get(sv);
2762
2763     if (!SvOK(sv))
2764         return 0;
2765     if (SvROK(sv)) {
2766         SV* tmpsv;
2767         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2768                 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2769             return SvTRUE(tmpsv);
2770       return SvRV(sv) != 0;
2771     }
2772     if (SvPOKp(sv)) {
2773         register XPV* Xpvtmp;
2774         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2775                 (*Xpvtmp->xpv_pv > '0' ||
2776                 Xpvtmp->xpv_cur > 1 ||
2777                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2778             return 1;
2779         else
2780             return 0;
2781     }
2782     else {
2783         if (SvIOKp(sv))
2784             return SvIVX(sv) != 0;
2785         else {
2786             if (SvNOKp(sv))
2787                 return SvNVX(sv) != 0.0;
2788             else
2789                 return FALSE;
2790         }
2791     }
2792 }
2793
2794 /*
2795 =for apidoc sv_utf8_upgrade
2796
2797 Convert the PV of an SV to its UTF8-encoded form.
2798 Forces the SV to string form it it is not already.
2799 Always sets the SvUTF8 flag to avoid future validity checks even
2800 if all the bytes have hibit clear.
2801
2802 =cut
2803 */
2804
2805 STRLEN
2806 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2807 {
2808     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
2809 }
2810
2811 /*
2812 =for apidoc sv_utf8_upgrade_flags
2813
2814 Convert the PV of an SV to its UTF8-encoded form.
2815 Forces the SV to string form it it is not already.
2816 Always sets the SvUTF8 flag to avoid future validity checks even
2817 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2818 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2819 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2820
2821 =cut
2822 */
2823
2824 STRLEN
2825 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2826 {
2827     U8 *s, *t, *e;
2828     int  hibit = 0;
2829
2830     if (!sv)
2831         return 0;
2832
2833     if (!SvPOK(sv)) {
2834         STRLEN len = 0;
2835         (void) sv_2pv_flags(sv,&len, flags);
2836         if (!SvPOK(sv))
2837              return len;
2838     }
2839
2840     if (SvUTF8(sv))
2841         return SvCUR(sv);
2842
2843     if (SvREADONLY(sv) && SvFAKE(sv)) {
2844         sv_force_normal(sv);
2845     }
2846
2847     /* This function could be much more efficient if we had a FLAG in SVs
2848      * to signal if there are any hibit chars in the PV.
2849      * Given that there isn't make loop fast as possible
2850      */
2851     s = (U8 *) SvPVX(sv);
2852     e = (U8 *) SvEND(sv);
2853     t = s;
2854     while (t < e) {
2855         U8 ch = *t++;
2856         if ((hibit = !NATIVE_IS_INVARIANT(ch)))
2857             break;
2858     }
2859     if (hibit) {
2860         STRLEN len;
2861
2862         len = SvCUR(sv) + 1; /* Plus the \0 */
2863         SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2864         SvCUR(sv) = len - 1;
2865         if (SvLEN(sv) != 0)
2866             Safefree(s); /* No longer using what was there before. */
2867         SvLEN(sv) = len; /* No longer know the real size. */
2868     }
2869     /* Mark as UTF-8 even if no hibit - saves scanning loop */
2870     SvUTF8_on(sv);
2871     return SvCUR(sv);
2872 }
2873
2874 /*
2875 =for apidoc sv_utf8_downgrade
2876
2877 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2878 This may not be possible if the PV contains non-byte encoding characters;
2879 if this is the case, either returns false or, if C<fail_ok> is not
2880 true, croaks.
2881
2882 =cut
2883 */
2884
2885 bool
2886 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2887 {
2888     if (SvPOK(sv) && SvUTF8(sv)) {
2889         if (SvCUR(sv)) {
2890             U8 *s;
2891             STRLEN len;
2892
2893             if (SvREADONLY(sv) && SvFAKE(sv))
2894                 sv_force_normal(sv);
2895             s = (U8 *) SvPV(sv, len);
2896             if (!utf8_to_bytes(s, &len)) {
2897                 if (fail_ok)
2898                     return FALSE;
2899 #ifdef USE_BYTES_DOWNGRADES
2900                 else if (IN_BYTES) {
2901                     U8 *d = s;
2902                     U8 *e = (U8 *) SvEND(sv);
2903                     int first = 1;
2904                     while (s < e) {
2905                         UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
2906                         if (first && ch > 255) {
2907                             if (PL_op)
2908                                 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
2909                                            PL_op_desc[PL_op->op_type]);
2910                             else
2911                                 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
2912                             first = 0;
2913                         }
2914                         *d++ = ch;
2915                         s += len;
2916                     }
2917                     *d = '\0';
2918                     len = (d - (U8 *) SvPVX(sv));
2919                 }
2920 #endif
2921                 else {
2922                     if (PL_op)
2923                         Perl_croak(aTHX_ "Wide character in %s",
2924                                    PL_op_desc[PL_op->op_type]);
2925                     else
2926                         Perl_croak(aTHX_ "Wide character");
2927                 }
2928             }
2929             SvCUR(sv) = len;
2930         }
2931     }
2932     SvUTF8_off(sv);
2933     return TRUE;
2934 }
2935
2936 /*
2937 =for apidoc sv_utf8_encode
2938
2939 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2940 flag so that it looks like octets again. Used as a building block
2941 for encode_utf8 in Encode.xs
2942
2943 =cut
2944 */
2945
2946 void
2947 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2948 {
2949     (void) sv_utf8_upgrade(sv);
2950     SvUTF8_off(sv);
2951 }
2952
2953 /*
2954 =for apidoc sv_utf8_decode
2955
2956 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
2957 turn of SvUTF8 if needed so that we see characters. Used as a building block
2958 for decode_utf8 in Encode.xs
2959
2960 =cut
2961 */
2962
2963
2964
2965 bool
2966 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2967 {
2968     if (SvPOK(sv)) {
2969         U8 *c;
2970         U8 *e;
2971
2972         /* The octets may have got themselves encoded - get them back as bytes */
2973         if (!sv_utf8_downgrade(sv, TRUE))
2974             return FALSE;
2975
2976         /* it is actually just a matter of turning the utf8 flag on, but
2977          * we want to make sure everything inside is valid utf8 first.
2978          */
2979         c = (U8 *) SvPVX(sv);
2980         if (!is_utf8_string(c, SvCUR(sv)+1))
2981             return FALSE;
2982         e = (U8 *) SvEND(sv);
2983         while (c < e) {
2984             U8 ch = *c++;
2985             if (!UTF8_IS_INVARIANT(ch)) {
2986                 SvUTF8_on(sv);
2987                 break;
2988             }
2989         }
2990     }
2991     return TRUE;
2992 }
2993
2994
2995 /* Note: sv_setsv() should not be called with a source string that needs
2996  * to be reused, since it may destroy the source string if it is marked
2997  * as temporary.
2998  */
2999
3000 /*
3001 =for apidoc sv_setsv
3002
3003 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3004 The source SV may be destroyed if it is mortal.  Does not handle 'set'
3005 magic.  See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3006 C<sv_setsv_mg>.
3007
3008 =cut
3009 */
3010
3011 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3012    for binary compatibility only
3013 */
3014 void
3015 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3016 {
3017     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3018 }
3019
3020 /*
3021 =for apidoc sv_setsv_flags
3022
3023 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3024 The source SV may be destroyed if it is mortal.  Does not handle 'set'
3025 magic.  If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
3026 appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
3027 in terms of this function.
3028
3029 =cut
3030 */
3031
3032 void
3033 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3034 {
3035     register U32 sflags;
3036     register int dtype;
3037     register int stype;
3038
3039     if (sstr == dstr)
3040         return;
3041     SV_CHECK_THINKFIRST(dstr);
3042     if (!sstr)
3043         sstr = &PL_sv_undef;
3044     stype = SvTYPE(sstr);
3045     dtype = SvTYPE(dstr);
3046
3047     SvAMAGIC_off(dstr);
3048
3049     /* There's a lot of redundancy below but we're going for speed here */
3050
3051     switch (stype) {
3052     case SVt_NULL:
3053       undef_sstr:
3054         if (dtype != SVt_PVGV) {
3055             (void)SvOK_off(dstr);
3056             return;
3057         }
3058         break;
3059     case SVt_IV:
3060         if (SvIOK(sstr)) {
3061             switch (dtype) {
3062             case SVt_NULL:
3063                 sv_upgrade(dstr, SVt_IV);
3064                 break;
3065             case SVt_NV:
3066                 sv_upgrade(dstr, SVt_PVNV);
3067                 break;
3068             case SVt_RV:
3069             case SVt_PV:
3070                 sv_upgrade(dstr, SVt_PVIV);
3071                 break;
3072             }
3073             (void)SvIOK_only(dstr);
3074             SvIVX(dstr) = SvIVX(sstr);
3075             if (SvIsUV(sstr))
3076                 SvIsUV_on(dstr);
3077             if (SvTAINTED(sstr))
3078                 SvTAINT(dstr);
3079             return;
3080         }
3081         goto undef_sstr;
3082
3083     case SVt_NV:
3084         if (SvNOK(sstr)) {
3085             switch (dtype) {
3086             case SVt_NULL:
3087             case SVt_IV:
3088                 sv_upgrade(dstr, SVt_NV);
3089                 break;
3090             case SVt_RV:
3091             case SVt_PV:
3092             case SVt_PVIV:
3093                 sv_upgrade(dstr, SVt_PVNV);
3094                 break;
3095             }
3096             SvNVX(dstr) = SvNVX(sstr);
3097             (void)SvNOK_only(dstr);
3098             if (SvTAINTED(sstr))
3099                 SvTAINT(dstr);
3100             return;
3101         }
3102         goto undef_sstr;
3103
3104     case SVt_RV:
3105         if (dtype < SVt_RV)
3106             sv_upgrade(dstr, SVt_RV);
3107         else if (dtype == SVt_PVGV &&
3108                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3109             sstr = SvRV(sstr);
3110             if (sstr == dstr) {
3111                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3112                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3113                 {
3114                     GvIMPORTED_on(dstr);
3115                 }
3116                 GvMULTI_on(dstr);
3117                 return;
3118             }
3119             goto glob_assign;
3120         }
3121         break;
3122     case SVt_PV:
3123     case SVt_PVFM:
3124         if (dtype < SVt_PV)
3125             sv_upgrade(dstr, SVt_PV);
3126         break;
3127     case SVt_PVIV:
3128         if (dtype < SVt_PVIV)
3129             sv_upgrade(dstr, SVt_PVIV);
3130         break;
3131     case SVt_PVNV:
3132         if (dtype < SVt_PVNV)
3133             sv_upgrade(dstr, SVt_PVNV);
3134         break;
3135     case SVt_PVAV:
3136     case SVt_PVHV:
3137     case SVt_PVCV:
3138     case SVt_PVIO:
3139         if (PL_op)
3140             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3141                 PL_op_name[PL_op->op_type]);
3142         else
3143             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3144         break;
3145
3146     case SVt_PVGV:
3147         if (dtype <= SVt_PVGV) {
3148   glob_assign:
3149             if (dtype != SVt_PVGV) {
3150                 char *name = GvNAME(sstr);
3151                 STRLEN len = GvNAMELEN(sstr);
3152                 sv_upgrade(dstr, SVt_PVGV);
3153                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3154                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3155                 GvNAME(dstr) = savepvn(name, len);
3156                 GvNAMELEN(dstr) = len;
3157                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3158             }
3159             /* ahem, death to those who redefine active sort subs */
3160             else if (PL_curstackinfo->si_type == PERLSI_SORT
3161                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3162                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3163                       GvNAME(dstr));
3164
3165 #ifdef GV_SHARED_CHECK
3166                 if (GvSHARED((GV*)dstr)) {
3167                     Perl_croak(aTHX_ PL_no_modify);
3168                 }
3169 #endif
3170
3171             (void)SvOK_off(dstr);
3172             GvINTRO_off(dstr);          /* one-shot flag */
3173             gp_free((GV*)dstr);
3174             GvGP(dstr) = gp_ref(GvGP(sstr));
3175             if (SvTAINTED(sstr))
3176                 SvTAINT(dstr);
3177             if (GvIMPORTED(dstr) != GVf_IMPORTED
3178                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3179             {
3180                 GvIMPORTED_on(dstr);
3181             }
3182             GvMULTI_on(dstr);
3183             return;
3184         }
3185         /* FALL THROUGH */
3186
3187     default:
3188         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3189             mg_get(sstr);
3190             if (SvTYPE(sstr) != stype) {
3191                 stype = SvTYPE(sstr);
3192                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3193                     goto glob_assign;
3194             }
3195         }
3196         if (stype == SVt_PVLV)
3197             (void)SvUPGRADE(dstr, SVt_PVNV);
3198         else
3199             (void)SvUPGRADE(dstr, stype);
3200     }
3201
3202     sflags = SvFLAGS(sstr);
3203
3204     if (sflags & SVf_ROK) {
3205         if (dtype >= SVt_PV) {
3206             if (dtype == SVt_PVGV) {
3207                 SV *sref = SvREFCNT_inc(SvRV(sstr));
3208                 SV *dref = 0;
3209                 int intro = GvINTRO(dstr);
3210
3211 #ifdef GV_SHARED_CHECK
3212                 if (GvSHARED((GV*)dstr)) {
3213                     Perl_croak(aTHX_ PL_no_modify);
3214                 }
3215 #endif
3216
3217                 if (intro) {
3218                     GvINTRO_off(dstr);  /* one-shot flag */
3219                     GvLINE(dstr) = CopLINE(PL_curcop);
3220                     GvEGV(dstr) = (GV*)dstr;
3221                 }
3222                 GvMULTI_on(dstr);
3223                 switch (SvTYPE(sref)) {
3224                 case SVt_PVAV:
3225                     if (intro)
3226                         SAVESPTR(GvAV(dstr));
3227                     else
3228                         dref = (SV*)GvAV(dstr);
3229                     GvAV(dstr) = (AV*)sref;
3230                     if (!GvIMPORTED_AV(dstr)
3231                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3232                     {
3233                         GvIMPORTED_AV_on(dstr);
3234                     }
3235                     break;
3236                 case SVt_PVHV:
3237                     if (intro)
3238                         SAVESPTR(GvHV(dstr));
3239                     else
3240                         dref = (SV*)GvHV(dstr);
3241                     GvHV(dstr) = (HV*)sref;
3242                     if (!GvIMPORTED_HV(dstr)
3243                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3244                     {
3245                         GvIMPORTED_HV_on(dstr);
3246                     }
3247                     break;
3248                 case SVt_PVCV:
3249                     if (intro) {
3250                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3251                             SvREFCNT_dec(GvCV(dstr));
3252                             GvCV(dstr) = Nullcv;
3253                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3254                             PL_sub_generation++;
3255                         }
3256                         SAVESPTR(GvCV(dstr));
3257                     }
3258                     else
3259                         dref = (SV*)GvCV(dstr);
3260                     if (GvCV(dstr) != (CV*)sref) {
3261                         CV* cv = GvCV(dstr);
3262                         if (cv) {
3263                             if (!GvCVGEN((GV*)dstr) &&
3264                                 (CvROOT(cv) || CvXSUB(cv)))
3265                             {
3266                                 /* ahem, death to those who redefine
3267                                  * active sort subs */
3268                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3269                                       PL_sortcop == CvSTART(cv))
3270                                     Perl_croak(aTHX_
3271                                     "Can't redefine active sort subroutine %s",
3272                                           GvENAME((GV*)dstr));
3273                                 /* Redefining a sub - warning is mandatory if
3274                                    it was a const and its value changed. */
3275                                 if (ckWARN(WARN_REDEFINE)
3276                                     || (CvCONST(cv)
3277                                         && (!CvCONST((CV*)sref)
3278                                             || sv_cmp(cv_const_sv(cv),
3279                                                       cv_const_sv((CV*)sref)))))
3280                                 {
3281                                     Perl_warner(aTHX_ WARN_REDEFINE,
3282                                         CvCONST(cv)
3283                                         ? "Constant subroutine %s redefined"
3284                                         : "Subroutine %s redefined",
3285                                         GvENAME((GV*)dstr));
3286                                 }
3287                             }
3288                             cv_ckproto(cv, (GV*)dstr,
3289                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
3290                         }
3291                         GvCV(dstr) = (CV*)sref;
3292                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3293                         GvASSUMECV_on(dstr);
3294                         PL_sub_generation++;
3295                     }
3296                     if (!GvIMPORTED_CV(dstr)
3297                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3298                     {
3299                         GvIMPORTED_CV_on(dstr);
3300                     }
3301                     break;
3302                 case SVt_PVIO:
3303                     if (intro)
3304                         SAVESPTR(GvIOp(dstr));
3305                     else
3306                         dref = (SV*)GvIOp(dstr);
3307                     GvIOp(dstr) = (IO*)sref;
3308                     break;
3309                 case SVt_PVFM:
3310                     if (intro)
3311                         SAVESPTR(GvFORM(dstr));
3312                     else
3313                         dref = (SV*)GvFORM(dstr);
3314                     GvFORM(dstr) = (CV*)sref;
3315                     break;
3316                 default:
3317                     if (intro)
3318                         SAVESPTR(GvSV(dstr));
3319                     else
3320                         dref = (SV*)GvSV(dstr);
3321                     GvSV(dstr) = sref;
3322                     if (!GvIMPORTED_SV(dstr)
3323                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3324                     {
3325                         GvIMPORTED_SV_on(dstr);
3326                     }
3327                     break;
3328                 }
3329                 if (dref)
3330                     SvREFCNT_dec(dref);
3331                 if (intro)
3332                     SAVEFREESV(sref);
3333                 if (SvTAINTED(sstr))
3334                     SvTAINT(dstr);
3335                 return;
3336             }
3337             if (SvPVX(dstr)) {
3338                 (void)SvOOK_off(dstr);          /* backoff */
3339                 if (SvLEN(dstr))
3340                     Safefree(SvPVX(dstr));
3341                 SvLEN(dstr)=SvCUR(dstr)=0;
3342             }
3343         }
3344         (void)SvOK_off(dstr);
3345         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3346         SvROK_on(dstr);
3347         if (sflags & SVp_NOK) {
3348             SvNOKp_on(dstr);
3349             /* Only set the public OK flag if the source has public OK.  */
3350             if (sflags & SVf_NOK)
3351                 SvFLAGS(dstr) |= SVf_NOK;
3352             SvNVX(dstr) = SvNVX(sstr);
3353         }
3354         if (sflags & SVp_IOK) {
3355             (void)SvIOKp_on(dstr);
3356             if (sflags & SVf_IOK)
3357                 SvFLAGS(dstr) |= SVf_IOK;
3358             if (sflags & SVf_IVisUV)
3359                 SvIsUV_on(dstr);
3360             SvIVX(dstr) = SvIVX(sstr);
3361         }
3362         if (SvAMAGIC(sstr)) {
3363             SvAMAGIC_on(dstr);
3364         }
3365     }
3366     else if (sflags & SVp_POK) {
3367
3368         /*
3369          * Check to see if we can just swipe the string.  If so, it's a
3370          * possible small lose on short strings, but a big win on long ones.
3371          * It might even be a win on short strings if SvPVX(dstr)
3372          * has to be allocated and SvPVX(sstr) has to be freed.
3373          */
3374
3375         if (SvTEMP(sstr) &&             /* slated for free anyway? */
3376             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
3377             !(sflags & SVf_OOK) &&      /* and not involved in OOK hack? */
3378             SvLEN(sstr)         &&      /* and really is a string */
3379             !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3380         {
3381             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
3382                 if (SvOOK(dstr)) {
3383                     SvFLAGS(dstr) &= ~SVf_OOK;
3384                     Safefree(SvPVX(dstr) - SvIVX(dstr));
3385                 }
3386                 else if (SvLEN(dstr))
3387                     Safefree(SvPVX(dstr));
3388             }
3389             (void)SvPOK_only(dstr);
3390             SvPV_set(dstr, SvPVX(sstr));
3391             SvLEN_set(dstr, SvLEN(sstr));
3392             SvCUR_set(dstr, SvCUR(sstr));
3393
3394             SvTEMP_off(dstr);
3395             (void)SvOK_off(sstr);               /* NOTE: nukes most SvFLAGS on sstr */
3396             SvPV_set(sstr, Nullch);
3397             SvLEN_set(sstr, 0);
3398             SvCUR_set(sstr, 0);
3399             SvTEMP_off(sstr);
3400         }
3401         else {                                  /* have to copy actual string */
3402             STRLEN len = SvCUR(sstr);
3403
3404             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
3405             Move(SvPVX(sstr),SvPVX(dstr),len,char);
3406             SvCUR_set(dstr, len);
3407             *SvEND(dstr) = '\0';
3408             (void)SvPOK_only(dstr);
3409         }
3410         if (sflags & SVf_UTF8)
3411             SvUTF8_on(dstr);
3412         /*SUPPRESS 560*/
3413         if (sflags & SVp_NOK) {
3414             SvNOKp_on(dstr);
3415             if (sflags & SVf_NOK)
3416                 SvFLAGS(dstr) |= SVf_NOK;
3417             SvNVX(dstr) = SvNVX(sstr);
3418         }
3419         if (sflags & SVp_IOK) {
3420             (void)SvIOKp_on(dstr);
3421             if (sflags & SVf_IOK)
3422                 SvFLAGS(dstr) |= SVf_IOK;
3423             if (sflags & SVf_IVisUV)
3424                 SvIsUV_on(dstr);
3425             SvIVX(dstr) = SvIVX(sstr);
3426         }
3427     }
3428     else if (sflags & SVp_IOK) {
3429         if (sflags & SVf_IOK)
3430             (void)SvIOK_only(dstr);
3431         else {
3432             (void)SvOK_off(dstr);
3433             (void)SvIOKp_on(dstr);
3434         }
3435         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3436         if (sflags & SVf_IVisUV)
3437             SvIsUV_on(dstr);
3438         SvIVX(dstr) = SvIVX(sstr);
3439         if (sflags & SVp_NOK) {
3440             if (sflags & SVf_NOK)
3441                 (void)SvNOK_on(dstr);
3442             else
3443                 (void)SvNOKp_on(dstr);
3444             SvNVX(dstr) = SvNVX(sstr);
3445         }
3446     }
3447     else if (sflags & SVp_NOK) {
3448         if (sflags & SVf_NOK)
3449             (void)SvNOK_only(dstr);
3450         else {
3451             (void)SvOK_off(dstr);
3452             SvNOKp_on(dstr);
3453         }
3454         SvNVX(dstr) = SvNVX(sstr);
3455     }
3456     else {
3457         if (dtype == SVt_PVGV) {
3458             if (ckWARN(WARN_MISC))
3459                 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3460         }
3461         else
3462             (void)SvOK_off(dstr);
3463     }
3464     if (SvTAINTED(sstr))
3465         SvTAINT(dstr);
3466 }
3467
3468 /*
3469 =for apidoc sv_setsv_mg
3470
3471 Like C<sv_setsv>, but also handles 'set' magic.
3472
3473 =cut
3474 */
3475
3476 void
3477 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3478 {
3479     sv_setsv(dstr,sstr);
3480     SvSETMAGIC(dstr);
3481 }
3482
3483 /*
3484 =for apidoc sv_setpvn
3485
3486 Copies a string into an SV.  The C<len> parameter indicates the number of
3487 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
3488
3489 =cut
3490 */
3491
3492 void
3493 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3494 {
3495     register char *dptr;
3496
3497     SV_CHECK_THINKFIRST(sv);
3498     if (!ptr) {
3499         (void)SvOK_off(sv);
3500         return;
3501     }
3502     else {
3503         /* len is STRLEN which is unsigned, need to copy to signed */
3504         IV iv = len;
3505         if (iv < 0)
3506             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3507     }
3508     (void)SvUPGRADE(sv, SVt_PV);
3509
3510     SvGROW(sv, len + 1);
3511     dptr = SvPVX(sv);
3512     Move(ptr,dptr,len,char);
3513     dptr[len] = '\0';
3514     SvCUR_set(sv, len);
3515     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3516     SvTAINT(sv);
3517 }
3518
3519 /*
3520 =for apidoc sv_setpvn_mg
3521
3522 Like C<sv_setpvn>, but also handles 'set' magic.
3523
3524 =cut
3525 */
3526
3527 void
3528 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3529 {
3530     sv_setpvn(sv,ptr,len);
3531     SvSETMAGIC(sv);
3532 }
3533
3534 /*
3535 =for apidoc sv_setpv
3536
3537 Copies a string into an SV.  The string must be null-terminated.  Does not
3538 handle 'set' magic.  See C<sv_setpv_mg>.
3539
3540 =cut
3541 */
3542
3543 void
3544 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3545 {
3546     register STRLEN len;
3547
3548     SV_CHECK_THINKFIRST(sv);
3549     if (!ptr) {
3550         (void)SvOK_off(sv);
3551         return;
3552     }
3553     len = strlen(ptr);
3554     (void)SvUPGRADE(sv, SVt_PV);
3555
3556     SvGROW(sv, len + 1);
3557     Move(ptr,SvPVX(sv),len+1,char);
3558     SvCUR_set(sv, len);
3559     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3560     SvTAINT(sv);
3561 }
3562
3563 /*
3564 =for apidoc sv_setpv_mg
3565
3566 Like C<sv_setpv>, but also handles 'set' magic.
3567
3568 =cut
3569 */
3570
3571 void
3572 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3573 {
3574     sv_setpv(sv,ptr);
3575     SvSETMAGIC(sv);
3576 }
3577
3578 /*
3579 =for apidoc sv_usepvn
3580
3581 Tells an SV to use C<ptr> to find its string value.  Normally the string is
3582 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3583 The C<ptr> should point to memory that was allocated by C<malloc>.  The
3584 string length, C<len>, must be supplied.  This function will realloc the
3585 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3586 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
3587 See C<sv_usepvn_mg>.
3588
3589 =cut
3590 */
3591
3592 void
3593 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3594 {
3595     SV_CHECK_THINKFIRST(sv);
3596     (void)SvUPGRADE(sv, SVt_PV);
3597     if (!ptr) {
3598         (void)SvOK_off(sv);
3599         return;
3600     }
3601     (void)SvOOK_off(sv);
3602     if (SvPVX(sv) && SvLEN(sv))
3603         Safefree(SvPVX(sv));
3604     Renew(ptr, len+1, char);
3605     SvPVX(sv) = ptr;
3606     SvCUR_set(sv, len);
3607     SvLEN_set(sv, len+1);
3608     *SvEND(sv) = '\0';
3609     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3610     SvTAINT(sv);
3611 }
3612
3613 /*
3614 =for apidoc sv_usepvn_mg
3615
3616 Like C<sv_usepvn>, but also handles 'set' magic.
3617
3618 =cut
3619 */
3620
3621 void
3622 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3623 {
3624     sv_usepvn(sv,ptr,len);
3625     SvSETMAGIC(sv);
3626 }
3627
3628 void
3629 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3630 {
3631     if (SvREADONLY(sv)) {
3632         if (SvFAKE(sv)) {
3633             char *pvx = SvPVX(sv);
3634             STRLEN len = SvCUR(sv);
3635             U32 hash   = SvUVX(sv);
3636             SvGROW(sv, len + 1);
3637             Move(pvx,SvPVX(sv),len,char);
3638             *SvEND(sv) = '\0';
3639             SvFAKE_off(sv);
3640             SvREADONLY_off(sv);
3641             unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3642         }
3643         else if (PL_curcop != &PL_compiling)
3644             Perl_croak(aTHX_ PL_no_modify);
3645     }
3646     if (SvROK(sv))
3647         sv_unref_flags(sv, flags);
3648     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3649         sv_unglob(sv);
3650 }
3651
3652 void
3653 Perl_sv_force_normal(pTHX_ register SV *sv)
3654 {
3655     sv_force_normal_flags(sv, 0);
3656 }
3657
3658 /*
3659 =for apidoc sv_chop
3660
3661 Efficient removal of characters from the beginning of the string buffer.
3662 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3663 the string buffer.  The C<ptr> becomes the first character of the adjusted
3664 string.
3665
3666 =cut
3667 */
3668
3669 void
3670 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3671
3672
3673 {
3674     register STRLEN delta;
3675
3676     if (!ptr || !SvPOKp(sv))
3677         return;
3678     SV_CHECK_THINKFIRST(sv);
3679     if (SvTYPE(sv) < SVt_PVIV)
3680         sv_upgrade(sv,SVt_PVIV);
3681
3682     if (!SvOOK(sv)) {
3683         if (!SvLEN(sv)) { /* make copy of shared string */
3684             char *pvx = SvPVX(sv);
3685             STRLEN len = SvCUR(sv);
3686             SvGROW(sv, len + 1);
3687             Move(pvx,SvPVX(sv),len,char);
3688             *SvEND(sv) = '\0';
3689         }
3690         SvIVX(sv) = 0;
3691         SvFLAGS(sv) |= SVf_OOK;
3692     }
3693     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3694     delta = ptr - SvPVX(sv);
3695     SvLEN(sv) -= delta;
3696     SvCUR(sv) -= delta;
3697     SvPVX(sv) += delta;
3698     SvIVX(sv) += delta;
3699 }
3700
3701 /*
3702 =for apidoc sv_catpvn
3703
3704 Concatenates the string onto the end of the string which is in the SV.  The
3705 C<len> indicates number of bytes to copy.  If the SV has the UTF8
3706 status set, then the bytes appended should be valid UTF8.
3707 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
3708
3709 =cut
3710 */
3711
3712 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
3713    for binary compatibility only
3714 */
3715 void
3716 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
3717 {
3718     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
3719 }
3720
3721 /*
3722 =for apidoc sv_catpvn_flags
3723
3724 Concatenates the string onto the end of the string which is in the SV.  The
3725 C<len> indicates number of bytes to copy.  If the SV has the UTF8
3726 status set, then the bytes appended should be valid UTF8.
3727 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3728 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3729 in terms of this function.
3730
3731 =cut
3732 */
3733
3734 void
3735 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3736 {
3737     STRLEN dlen;
3738     char *dstr;
3739
3740     dstr = SvPV_force_flags(dsv, dlen, flags);
3741     SvGROW(dsv, dlen + slen + 1);
3742     if (sstr == dstr)
3743         sstr = SvPVX(dsv);
3744     Move(sstr, SvPVX(dsv) + dlen, slen, char);
3745     SvCUR(dsv) += slen;
3746     *SvEND(dsv) = '\0';
3747     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
3748     SvTAINT(dsv);
3749 }
3750
3751 /*
3752 =for apidoc sv_catpvn_mg
3753
3754 Like C<sv_catpvn>, but also handles 'set' magic.
3755
3756 =cut
3757 */
3758
3759 void
3760 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3761 {
3762     sv_catpvn(sv,ptr,len);
3763     SvSETMAGIC(sv);
3764 }
3765
3766 /*
3767 =for apidoc sv_catsv
3768
3769 Concatenates the string from SV C<ssv> onto the end of the string in
3770 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
3771 not 'set' magic.  See C<sv_catsv_mg>.
3772
3773 =cut */
3774
3775 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
3776    for binary compatibility only
3777 */
3778 void
3779 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3780 {
3781     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
3782 }
3783
3784 /*
3785 =for apidoc sv_catsv_flags
3786
3787 Concatenates the string from SV C<ssv> onto the end of the string in
3788 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
3789 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3790 and C<sv_catsv_nomg> are implemented in terms of this function.
3791
3792 =cut */
3793
3794 void
3795 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3796 {
3797     char *spv;
3798     STRLEN slen;
3799     if (!ssv)
3800         return;
3801     if ((spv = SvPV(ssv, slen))) {
3802         bool sutf8 = DO_UTF8(ssv);
3803         bool dutf8;
3804
3805         if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3806             mg_get(dsv);
3807         dutf8 = DO_UTF8(dsv);
3808
3809         if (dutf8 != sutf8) {
3810             if (dutf8) {
3811                 /* Not modifying source SV, so taking a temporary copy. */
3812                 SV* csv = sv_2mortal(newSVpvn(spv, slen));
3813
3814                 sv_utf8_upgrade(csv);
3815                 spv = SvPV(csv, slen);
3816             }
3817             else
3818                 sv_utf8_upgrade_nomg(dsv);
3819         }
3820         sv_catpvn_nomg(dsv, spv, slen);
3821     }
3822 }
3823
3824 /*
3825 =for apidoc sv_catsv_mg
3826
3827 Like C<sv_catsv>, but also handles 'set' magic.
3828
3829 =cut
3830 */
3831
3832 void
3833 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3834 {
3835     sv_catsv(dsv,ssv);
3836     SvSETMAGIC(dsv);
3837 }
3838
3839 /*
3840 =for apidoc sv_catpv
3841
3842 Concatenates the string onto the end of the string which is in the SV.
3843 If the SV has the UTF8 status set, then the bytes appended should be
3844 valid UTF8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
3845
3846 =cut */
3847
3848 void
3849 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3850 {
3851     register STRLEN len;
3852     STRLEN tlen;
3853     char *junk;
3854
3855     if (!ptr)
3856         return;
3857     junk = SvPV_force(sv, tlen);
3858     len = strlen(ptr);
3859     SvGROW(sv, tlen + len + 1);
3860     if (ptr == junk)
3861         ptr = SvPVX(sv);
3862     Move(ptr,SvPVX(sv)+tlen,len+1,char);
3863     SvCUR(sv) += len;
3864     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3865     SvTAINT(sv);
3866 }
3867
3868 /*
3869 =for apidoc sv_catpv_mg
3870
3871 Like C<sv_catpv>, but also handles 'set' magic.
3872
3873 =cut
3874 */
3875
3876 void
3877 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3878 {
3879     sv_catpv(sv,ptr);
3880     SvSETMAGIC(sv);
3881 }
3882
3883 SV *
3884 Perl_newSV(pTHX_ STRLEN len)
3885 {
3886     register SV *sv;
3887
3888     new_SV(sv);
3889     if (len) {
3890         sv_upgrade(sv, SVt_PV);
3891         SvGROW(sv, len + 1);
3892     }
3893     return sv;
3894 }
3895
3896 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3897
3898 /*
3899 =for apidoc sv_magic
3900
3901 Adds magic to an SV.
3902
3903 =cut
3904 */
3905
3906 void
3907 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3908 {
3909     MAGIC* mg;
3910
3911     if (SvREADONLY(sv)) {
3912         if (PL_curcop != &PL_compiling
3913             /* XXX this used to be !strchr("gBf", how), which seems to
3914              * implicity be equal to !strchr("gBf\0", how), ie \0 matches
3915              * too. I find this suprising, but have hadded PERL_MAGIC_sv
3916              * to the list of things to check - DAPM 19-May-01 */
3917             && how != PERL_MAGIC_regex_global
3918             && how != PERL_MAGIC_bm
3919             && how != PERL_MAGIC_fm
3920             && how != PERL_MAGIC_sv
3921            )
3922         {
3923             Perl_croak(aTHX_ PL_no_modify);
3924         }
3925     }
3926     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
3927         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3928             if (how == PERL_MAGIC_taint)
3929                 mg->mg_len |= 1;
3930             return;
3931         }
3932     }
3933     else {
3934         (void)SvUPGRADE(sv, SVt_PVMG);
3935     }
3936     Newz(702,mg, 1, MAGIC);
3937     mg->mg_moremagic = SvMAGIC(sv);
3938     SvMAGIC(sv) = mg;
3939
3940     /* Some magic sontains a reference loop, where the sv and object refer to
3941        each other.  To prevent a avoid a reference loop that would prevent such
3942        objects being freed, we look for such loops and if we find one we avoid
3943        incrementing the object refcount. */
3944     if (!obj || obj == sv ||
3945         how == PERL_MAGIC_arylen ||
3946         how == PERL_MAGIC_qr ||
3947         (SvTYPE(obj) == SVt_PVGV &&
3948             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
3949             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
3950             GvFORM(obj) == (CV*)sv)))
3951     {
3952         mg->mg_obj = obj;
3953     }
3954     else {
3955         mg->mg_obj = SvREFCNT_inc(obj);
3956         mg->mg_flags |= MGf_REFCOUNTED;
3957     }
3958     mg->mg_type = how;
3959     mg->mg_len = namlen;
3960     if (name) {
3961         if (namlen >= 0)
3962             mg->mg_ptr = savepvn(name, namlen);
3963         else if (namlen == HEf_SVKEY)
3964             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3965     }
3966
3967     switch (how) {
3968     case PERL_MAGIC_sv:
3969         mg->mg_virtual = &PL_vtbl_sv;
3970         break;
3971     case PERL_MAGIC_overload:
3972         mg->mg_virtual = &PL_vtbl_amagic;
3973         break;
3974     case PERL_MAGIC_overload_elem:
3975         mg->mg_virtual = &PL_vtbl_amagicelem;
3976         break;
3977     case PERL_MAGIC_overload_table:
3978         mg->mg_virtual = &PL_vtbl_ovrld;
3979         break;
3980     case PERL_MAGIC_bm:
3981         mg->mg_virtual = &PL_vtbl_bm;
3982         break;
3983     case PERL_MAGIC_regdata:
3984         mg->mg_virtual = &PL_vtbl_regdata;
3985         break;
3986     case PERL_MAGIC_regdatum:
3987         mg->mg_virtual = &PL_vtbl_regdatum;
3988         break;
3989     case PERL_MAGIC_env:
3990         mg->mg_virtual = &PL_vtbl_env;
3991         break;
3992     case PERL_MAGIC_fm:
3993         mg->mg_virtual = &PL_vtbl_fm;
3994         break;
3995     case PERL_MAGIC_envelem:
3996         mg->mg_virtual = &PL_vtbl_envelem;
3997         break;
3998     case PERL_MAGIC_regex_global:
3999         mg->mg_virtual = &PL_vtbl_mglob;
4000         break;
4001     case PERL_MAGIC_isa:
4002         mg->mg_virtual = &PL_vtbl_isa;
4003         break;
4004     case PERL_MAGIC_isaelem:
4005         mg->mg_virtual = &PL_vtbl_isaelem;
4006         break;
4007     case PERL_MAGIC_nkeys:
4008         mg->mg_virtual = &PL_vtbl_nkeys;
4009         break;
4010     case PERL_MAGIC_dbfile:
4011         SvRMAGICAL_on(sv);
4012         mg->mg_virtual = 0;
4013         break;
4014     case PERL_MAGIC_dbline:
4015         mg->mg_virtual = &PL_vtbl_dbline;
4016         break;
4017 #ifdef USE_THREADS
4018     case PERL_MAGIC_mutex:
4019         mg->mg_virtual = &PL_vtbl_mutex;
4020         break;
4021 #endif /* USE_THREADS */
4022 #ifdef USE_LOCALE_COLLATE
4023     case PERL_MAGIC_collxfrm:
4024         mg->mg_virtual = &PL_vtbl_collxfrm;
4025         break;
4026 #endif /* USE_LOCALE_COLLATE */
4027     case PERL_MAGIC_tied:
4028         mg->mg_virtual = &PL_vtbl_pack;
4029         break;
4030     case PERL_MAGIC_tiedelem:
4031     case PERL_MAGIC_tiedscalar:
4032         mg->mg_virtual = &PL_vtbl_packelem;
4033         break;
4034     case PERL_MAGIC_qr:
4035         mg->mg_virtual = &PL_vtbl_regexp;
4036         break;
4037     case PERL_MAGIC_sig:
4038         mg->mg_virtual = &PL_vtbl_sig;
4039         break;
4040     case PERL_MAGIC_sigelem:
4041         mg->mg_virtual = &PL_vtbl_sigelem;
4042         break;
4043     case PERL_MAGIC_taint:
4044         mg->mg_virtual = &PL_vtbl_taint;
4045         mg->mg_len = 1;
4046         break;
4047     case PERL_MAGIC_uvar:
4048         mg->mg_virtual = &PL_vtbl_uvar;
4049         break;
4050     case PERL_MAGIC_vec:
4051         mg->mg_virtual = &PL_vtbl_vec;
4052         break;
4053     case PERL_MAGIC_substr:
4054         mg->mg_virtual = &PL_vtbl_substr;
4055         break;
4056     case PERL_MAGIC_defelem:
4057         mg->mg_virtual = &PL_vtbl_defelem;
4058         break;
4059     case PERL_MAGIC_glob:
4060         mg->mg_virtual = &PL_vtbl_glob;
4061         break;
4062     case PERL_MAGIC_arylen:
4063         mg->mg_virtual = &PL_vtbl_arylen;
4064         break;
4065     case PERL_MAGIC_pos:
4066         mg->mg_virtual = &PL_vtbl_pos;
4067         break;
4068     case PERL_MAGIC_backref:
4069         mg->mg_virtual = &PL_vtbl_backref;
4070         break;
4071     case PERL_MAGIC_ext:
4072         /* Reserved for use by extensions not perl internals.           */
4073         /* Useful for attaching extension internal data to perl vars.   */
4074         /* Note that multiple extensions may clash if magical scalars   */
4075         /* etc holding private data from one are passed to another.     */
4076         SvRMAGICAL_on(sv);
4077         break;
4078     default:
4079         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4080     }
4081     mg_magical(sv);
4082     if (SvGMAGICAL(sv))
4083         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4084 }
4085
4086 /*
4087 =for apidoc sv_unmagic
4088
4089 Removes magic from an SV.
4090
4091 =cut
4092 */
4093
4094 int
4095 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4096 {
4097     MAGIC* mg;
4098     MAGIC** mgp;
4099     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4100         return 0;
4101     mgp = &SvMAGIC(sv);
4102     for (mg = *mgp; mg; mg = *mgp) {
4103         if (mg->mg_type == type) {
4104             MGVTBL* vtbl = mg->mg_virtual;
4105             *mgp = mg->mg_moremagic;
4106             if (vtbl && vtbl->svt_free)
4107                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4108             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4109                 if (mg->mg_len >= 0)
4110                     Safefree(mg->mg_ptr);
4111                 else if (mg->mg_len == HEf_SVKEY)
4112                     SvREFCNT_dec((SV*)mg->mg_ptr);
4113             }
4114             if (mg->mg_flags & MGf_REFCOUNTED)
4115                 SvREFCNT_dec(mg->mg_obj);
4116             Safefree(mg);
4117         }
4118         else
4119             mgp = &mg->mg_moremagic;
4120     }
4121     if (!SvMAGIC(sv)) {
4122         SvMAGICAL_off(sv);
4123        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4124     }
4125
4126     return 0;
4127 }
4128
4129 /*
4130 =for apidoc sv_rvweaken
4131
4132 Weaken a reference.
4133
4134 =cut
4135 */
4136
4137 SV *
4138 Perl_sv_rvweaken(pTHX_ SV *sv)
4139 {
4140     SV *tsv;
4141     if (!SvOK(sv))  /* let undefs pass */
4142         return sv;
4143     if (!SvROK(sv))
4144         Perl_croak(aTHX_ "Can't weaken a nonreference");
4145     else if (SvWEAKREF(sv)) {
4146         if (ckWARN(WARN_MISC))
4147             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4148         return sv;
4149     }
4150     tsv = SvRV(sv);
4151     sv_add_backref(tsv, sv);
4152     SvWEAKREF_on(sv);
4153     SvREFCNT_dec(tsv);
4154     return sv;
4155 }
4156
4157 STATIC void
4158 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4159 {
4160     AV *av;
4161     MAGIC *mg;
4162     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4163         av = (AV*)mg->mg_obj;
4164     else {
4165         av = newAV();
4166         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4167         SvREFCNT_dec(av);           /* for sv_magic */
4168     }
4169     av_push(av,sv);
4170 }
4171
4172 STATIC void
4173 S_sv_del_backref(pTHX_ SV *sv)
4174 {
4175     AV *av;
4176     SV **svp;
4177     I32 i;
4178     SV *tsv = SvRV(sv);
4179     MAGIC *mg;
4180     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4181         Perl_croak(aTHX_ "panic: del_backref");
4182     av = (AV *)mg->mg_obj;
4183     svp = AvARRAY(av);
4184     i = AvFILLp(av);
4185     while (i >= 0) {
4186         if (svp[i] == sv) {
4187             svp[i] = &PL_sv_undef; /* XXX */
4188         }
4189         i--;
4190     }
4191 }
4192
4193 /*
4194 =for apidoc sv_insert
4195
4196 Inserts a string at the specified offset/length within the SV. Similar to
4197 the Perl substr() function.
4198
4199 =cut
4200 */
4201
4202 void
4203 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4204 {
4205     register char *big;
4206     register char *mid;
4207     register char *midend;
4208     register char *bigend;
4209     register I32 i;
4210     STRLEN curlen;
4211
4212
4213     if (!bigstr)
4214         Perl_croak(aTHX_ "Can't modify non-existent substring");
4215     SvPV_force(bigstr, curlen);
4216     (void)SvPOK_only_UTF8(bigstr);
4217     if (offset + len > curlen) {
4218         SvGROW(bigstr, offset+len+1);
4219         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4220         SvCUR_set(bigstr, offset+len);
4221     }
4222
4223     SvTAINT(bigstr);
4224     i = littlelen - len;
4225     if (i > 0) {                        /* string might grow */
4226         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4227         mid = big + offset + len;
4228         midend = bigend = big + SvCUR(bigstr);
4229         bigend += i;
4230         *bigend = '\0';
4231         while (midend > mid)            /* shove everything down */
4232             *--bigend = *--midend;
4233         Move(little,big+offset,littlelen,char);
4234         SvCUR(bigstr) += i;
4235         SvSETMAGIC(bigstr);
4236         return;
4237     }
4238     else if (i == 0) {
4239         Move(little,SvPVX(bigstr)+offset,len,char);
4240         SvSETMAGIC(bigstr);
4241         return;
4242     }
4243
4244     big = SvPVX(bigstr);
4245     mid = big + offset;
4246     midend = mid + len;
4247     bigend = big + SvCUR(bigstr);
4248
4249     if (midend > bigend)
4250         Perl_croak(aTHX_ "panic: sv_insert");
4251
4252     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4253         if (littlelen) {
4254             Move(little, mid, littlelen,char);
4255             mid += littlelen;
4256         }
4257         i = bigend - midend;
4258         if (i > 0) {
4259             Move(midend, mid, i,char);
4260             mid += i;
4261         }
4262         *mid = '\0';
4263         SvCUR_set(bigstr, mid - big);
4264     }
4265     /*SUPPRESS 560*/
4266     else if ((i = mid - big)) { /* faster from front */
4267         midend -= littlelen;
4268         mid = midend;
4269         sv_chop(bigstr,midend-i);
4270         big += i;
4271         while (i--)
4272             *--midend = *--big;
4273         if (littlelen)
4274             Move(little, mid, littlelen,char);
4275     }
4276     else if (littlelen) {
4277         midend -= littlelen;
4278         sv_chop(bigstr,midend);
4279         Move(little,midend,littlelen,char);
4280     }
4281     else {
4282         sv_chop(bigstr,midend);
4283     }
4284     SvSETMAGIC(bigstr);
4285 }
4286
4287 /*
4288 =for apidoc sv_replace
4289
4290 Make the first argument a copy of the second, then delete the original.
4291
4292 =cut
4293 */
4294
4295 void
4296 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4297 {
4298     U32 refcnt = SvREFCNT(sv);
4299     SV_CHECK_THINKFIRST(sv);
4300     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4301         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4302     if (SvMAGICAL(sv)) {
4303         if (SvMAGICAL(nsv))
4304             mg_free(nsv);
4305         else
4306             sv_upgrade(nsv, SVt_PVMG);
4307         SvMAGIC(nsv) = SvMAGIC(sv);
4308         SvFLAGS(nsv) |= SvMAGICAL(sv);
4309         SvMAGICAL_off(sv);
4310         SvMAGIC(sv) = 0;
4311     }
4312     SvREFCNT(sv) = 0;
4313     sv_clear(sv);
4314     assert(!SvREFCNT(sv));
4315     StructCopy(nsv,sv,SV);
4316     SvREFCNT(sv) = refcnt;
4317     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
4318     del_SV(nsv);
4319 }
4320
4321 /*
4322 =for apidoc sv_clear
4323
4324 Clear an SV, making it empty. Does not free the memory used by the SV
4325 itself.
4326
4327 =cut
4328 */
4329
4330 void
4331 Perl_sv_clear(pTHX_ register SV *sv)
4332 {
4333     HV* stash;
4334     assert(sv);
4335     assert(SvREFCNT(sv) == 0);
4336
4337     if (SvOBJECT(sv)) {
4338         if (PL_defstash) {              /* Still have a symbol table? */
4339             dSP;
4340             CV* destructor;
4341             SV tmpref;
4342
4343             Zero(&tmpref, 1, SV);
4344             sv_upgrade(&tmpref, SVt_RV);
4345             SvROK_on(&tmpref);
4346             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
4347             SvREFCNT(&tmpref) = 1;
4348
4349             do {
4350                 stash = SvSTASH(sv);
4351                 destructor = StashHANDLER(stash,DESTROY);
4352                 if (destructor) {
4353                     ENTER;
4354                     PUSHSTACKi(PERLSI_DESTROY);
4355                     SvRV(&tmpref) = SvREFCNT_inc(sv);
4356                     EXTEND(SP, 2);
4357                     PUSHMARK(SP);
4358                     PUSHs(&tmpref);
4359                     PUTBACK;
4360                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4361                     SvREFCNT(sv)--;
4362                     POPSTACK;
4363                     SPAGAIN;
4364                     LEAVE;
4365                 }
4366             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4367
4368             del_XRV(SvANY(&tmpref));
4369
4370             if (SvREFCNT(sv)) {
4371                 if (PL_in_clean_objs)
4372                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4373                           HvNAME(stash));
4374                 /* DESTROY gave object new lease on life */
4375                 return;
4376             }
4377         }
4378
4379         if (SvOBJECT(sv)) {
4380             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
4381             SvOBJECT_off(sv);   /* Curse the object. */
4382             if (SvTYPE(sv) != SVt_PVIO)
4383                 --PL_sv_objcount;       /* XXX Might want something more general */
4384         }
4385     }
4386     if (SvTYPE(sv) >= SVt_PVMG) {
4387         if (SvMAGIC(sv))
4388             mg_free(sv);
4389         if (SvFLAGS(sv) & SVpad_TYPED)
4390             SvREFCNT_dec(SvSTASH(sv));
4391     }
4392     stash = NULL;
4393     switch (SvTYPE(sv)) {
4394     case SVt_PVIO:
4395         if (IoIFP(sv) &&
4396             IoIFP(sv) != PerlIO_stdin() &&
4397             IoIFP(sv) != PerlIO_stdout() &&
4398             IoIFP(sv) != PerlIO_stderr())
4399         {
4400             io_close((IO*)sv, FALSE);
4401         }
4402         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4403             PerlDir_close(IoDIRP(sv));
4404         IoDIRP(sv) = (DIR*)NULL;
4405         Safefree(IoTOP_NAME(sv));
4406         Safefree(IoFMT_NAME(sv));
4407         Safefree(IoBOTTOM_NAME(sv));
4408         /* FALL THROUGH */
4409     case SVt_PVBM:
4410         goto freescalar;
4411     case SVt_PVCV:
4412     case SVt_PVFM:
4413         cv_undef((CV*)sv);
4414         goto freescalar;
4415     case SVt_PVHV:
4416         hv_undef((HV*)sv);
4417         break;
4418     case SVt_PVAV:
4419         av_undef((AV*)sv);
4420         break;
4421     case SVt_PVLV:
4422         SvREFCNT_dec(LvTARG(sv));
4423         goto freescalar;
4424     case SVt_PVGV:
4425         gp_free((GV*)sv);
4426         Safefree(GvNAME(sv));
4427         /* cannot decrease stash refcount yet, as we might recursively delete
4428            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4429            of stash until current sv is completely gone.
4430            -- JohnPC, 27 Mar 1998 */
4431         stash = GvSTASH(sv);
4432         /* FALL THROUGH */
4433     case SVt_PVMG:
4434     case SVt_PVNV:
4435     case SVt_PVIV:
4436       freescalar:
4437         (void)SvOOK_off(sv);
4438         /* FALL THROUGH */
4439     case SVt_PV:
4440     case SVt_RV:
4441         if (SvROK(sv)) {
4442             if (SvWEAKREF(sv))
4443                 sv_del_backref(sv);
4444             else
4445                 SvREFCNT_dec(SvRV(sv));
4446         }
4447         else if (SvPVX(sv) && SvLEN(sv))
4448             Safefree(SvPVX(sv));
4449         else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4450             unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4451             SvFAKE_off(sv);
4452         }
4453         break;
4454 /*
4455     case SVt_NV:
4456     case SVt_IV:
4457     case SVt_NULL:
4458         break;
4459 */
4460     }
4461
4462     switch (SvTYPE(sv)) {
4463     case SVt_NULL:
4464         break;
4465     case SVt_IV:
4466         del_XIV(SvANY(sv));
4467         break;
4468     case SVt_NV:
4469         del_XNV(SvANY(sv));
4470         break;
4471     case SVt_RV:
4472         del_XRV(SvANY(sv));
4473         break;
4474     case SVt_PV:
4475         del_XPV(SvANY(sv));
4476         break;
4477     case SVt_PVIV:
4478         del_XPVIV(SvANY(sv));
4479         break;
4480     case SVt_PVNV:
4481         del_XPVNV(SvANY(sv));
4482         break;
4483     case SVt_PVMG:
4484         del_XPVMG(SvANY(sv));
4485         break;
4486     case SVt_PVLV:
4487         del_XPVLV(SvANY(sv));
4488         break;
4489     case SVt_PVAV:
4490         del_XPVAV(SvANY(sv));
4491         break;
4492     case SVt_PVHV:
4493         del_XPVHV(SvANY(sv));
4494         break;
4495     case SVt_PVCV:
4496         del_XPVCV(SvANY(sv));
4497         break;
4498     case SVt_PVGV:
4499         del_XPVGV(SvANY(sv));
4500         /* code duplication for increased performance. */
4501         SvFLAGS(sv) &= SVf_BREAK;
4502         SvFLAGS(sv) |= SVTYPEMASK;
4503         /* decrease refcount of the stash that owns this GV, if any */
4504         if (stash)
4505             SvREFCNT_dec(stash);
4506         return; /* not break, SvFLAGS reset already happened */
4507     case SVt_PVBM:
4508         del_XPVBM(SvANY(sv));
4509         break;
4510     case SVt_PVFM:
4511         del_XPVFM(SvANY(sv));
4512         break;
4513     case SVt_PVIO:
4514         del_XPVIO(SvANY(sv));
4515         break;
4516     }
4517     SvFLAGS(sv) &= SVf_BREAK;
4518     SvFLAGS(sv) |= SVTYPEMASK;
4519 }
4520
4521 SV *
4522 Perl_sv_newref(pTHX_ SV *sv)
4523 {
4524     if (sv)
4525         ATOMIC_INC(SvREFCNT(sv));
4526     return sv;
4527 }
4528
4529 /*
4530 =for apidoc sv_free
4531
4532 Free the memory used by an SV.
4533
4534 =cut
4535 */
4536
4537 void
4538 Perl_sv_free(pTHX_ SV *sv)
4539 {
4540     int refcount_is_zero;
4541
4542     if (!sv)
4543         return;
4544     if (SvREFCNT(sv) == 0) {
4545         if (SvFLAGS(sv) & SVf_BREAK)
4546             return;
4547         if (PL_in_clean_all) /* All is fair */
4548             return;
4549         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4550             /* make sure SvREFCNT(sv)==0 happens very seldom */
4551             SvREFCNT(sv) = (~(U32)0)/2;
4552             return;
4553         }
4554         if (ckWARN_d(WARN_INTERNAL))
4555             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4556         return;
4557     }
4558     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4559     if (!refcount_is_zero)
4560         return;
4561 #ifdef DEBUGGING
4562     if (SvTEMP(sv)) {
4563         if (ckWARN_d(WARN_DEBUGGING))
4564             Perl_warner(aTHX_ WARN_DEBUGGING,
4565                         "Attempt to free temp prematurely: SV 0x%"UVxf,
4566                         PTR2UV(sv));
4567         return;
4568     }
4569 #endif
4570     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4571         /* make sure SvREFCNT(sv)==0 happens very seldom */
4572         SvREFCNT(sv) = (~(U32)0)/2;
4573         return;
4574     }
4575     sv_clear(sv);
4576     if (! SvREFCNT(sv))
4577         del_SV(sv);
4578 }
4579
4580 /*
4581 =for apidoc sv_len
4582
4583 Returns the length of the string in the SV.  See also C<SvCUR>.
4584
4585 =cut
4586 */
4587
4588 STRLEN
4589 Perl_sv_len(pTHX_ register SV *sv)
4590 {
4591     char *junk;
4592     STRLEN len;
4593
4594     if (!sv)
4595         return 0;
4596
4597     if (SvGMAGICAL(sv))
4598         len = mg_length(sv);
4599     else
4600         junk = SvPV(sv, len);
4601     return len;
4602 }
4603
4604 /*
4605 =for apidoc sv_len_utf8
4606
4607 Returns the number of characters in the string in an SV, counting wide
4608 UTF8 bytes as a single character.
4609
4610 =cut
4611 */
4612
4613 STRLEN
4614 Perl_sv_len_utf8(pTHX_ register SV *sv)
4615 {
4616     if (!sv)
4617         return 0;
4618
4619     if (SvGMAGICAL(sv))
4620         return mg_length(sv);
4621     else
4622     {
4623         STRLEN len;
4624         U8 *s = (U8*)SvPV(sv, len);
4625
4626         return Perl_utf8_length(aTHX_ s, s + len);
4627     }
4628 }
4629
4630 void
4631 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4632 {
4633     U8 *start;
4634     U8 *s;
4635     U8 *send;
4636     I32 uoffset = *offsetp;
4637     STRLEN len;
4638
4639     if (!sv)
4640         return;
4641
4642     start = s = (U8*)SvPV(sv, len);
4643     send = s + len;
4644     while (s < send && uoffset--)
4645         s += UTF8SKIP(s);
4646     if (s >= send)
4647         s = send;
4648     *offsetp = s - start;
4649     if (lenp) {
4650         I32 ulen = *lenp;
4651         start = s;
4652         while (s < send && ulen--)
4653             s += UTF8SKIP(s);
4654         if (s >= send)
4655             s = send;
4656         *lenp = s - start;
4657     }
4658     return;
4659 }
4660
4661 void
4662 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4663 {
4664     U8 *s;
4665     U8 *send;
4666     STRLEN len;
4667
4668     if (!sv)
4669         return;
4670
4671     s = (U8*)SvPV(sv, len);
4672     if (len < *offsetp)
4673         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4674     send = s + *offsetp;
4675     len = 0;
4676     while (s < send) {
4677         STRLEN n;
4678         /* Call utf8n_to_uvchr() to validate the sequence */
4679         utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4680         if (n > 0) {
4681             s += n;
4682             len++;
4683         }
4684         else
4685             break;
4686     }
4687     *offsetp = len;
4688     return;
4689 }
4690
4691 /*
4692 =for apidoc sv_eq
4693
4694 Returns a boolean indicating whether the strings in the two SVs are
4695 identical.
4696
4697 =cut
4698 */
4699
4700 I32
4701 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4702 {
4703     char *pv1;
4704     STRLEN cur1;
4705     char *pv2;
4706     STRLEN cur2;
4707     I32  eq     = 0;
4708     char *tpv   = Nullch;
4709
4710     if (!sv1) {
4711         pv1 = "";
4712         cur1 = 0;
4713     }
4714     else
4715         pv1 = SvPV(sv1, cur1);
4716
4717     if (!sv2){
4718         pv2 = "";
4719         cur2 = 0;
4720     }
4721     else
4722         pv2 = SvPV(sv2, cur2);
4723
4724     /* do not utf8ize the comparands as a side-effect */
4725     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4726         bool is_utf8 = TRUE;
4727         /* UTF-8ness differs */
4728         if (PL_hints & HINT_UTF8_DISTINCT)
4729             return FALSE;
4730
4731         if (SvUTF8(sv1)) {
4732             /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4733             char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4734             if (pv != pv1)
4735                 pv1 = tpv = pv;
4736         }
4737         else {
4738             /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4739             char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4740             if (pv != pv2)
4741                 pv2 = tpv = pv;
4742         }
4743         if (is_utf8) {
4744             /* Downgrade not possible - cannot be eq */
4745             return FALSE;
4746         }
4747     }
4748
4749     if (cur1 == cur2)
4750         eq = memEQ(pv1, pv2, cur1);
4751
4752     if (tpv != Nullch)
4753         Safefree(tpv);
4754
4755     return eq;
4756 }
4757
4758 /*
4759 =for apidoc sv_cmp
4760
4761 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
4762 string in C<sv1> is less than, equal to, or greater than the string in
4763 C<sv2>.
4764
4765 =cut
4766 */
4767
4768 I32
4769 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4770 {
4771     STRLEN cur1, cur2;
4772     char *pv1, *pv2;
4773     I32  cmp;
4774     bool pv1tmp = FALSE;
4775     bool pv2tmp = FALSE;
4776
4777     if (!sv1) {
4778         pv1 = "";
4779         cur1 = 0;
4780     }
4781     else
4782         pv1 = SvPV(sv1, cur1);
4783
4784     if (!sv2){
4785         pv2 = "";
4786         cur2 = 0;
4787     }
4788     else
4789         pv2 = SvPV(sv2, cur2);
4790
4791     /* do not utf8ize the comparands as a side-effect */
4792     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4793         if (PL_hints & HINT_UTF8_DISTINCT)
4794             return SvUTF8(sv1) ? 1 : -1;
4795
4796         if (SvUTF8(sv1)) {
4797             pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4798             pv2tmp = TRUE;
4799         }
4800         else {
4801             pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4802             pv1tmp = TRUE;
4803         }
4804     }
4805
4806     if (!cur1) {
4807         cmp = cur2 ? -1 : 0;
4808     } else if (!cur2) {
4809         cmp = 1;
4810     } else {
4811         I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4812
4813         if (retval) {
4814             cmp = retval < 0 ? -1 : 1;
4815         } else if (cur1 == cur2) {
4816             cmp = 0;
4817         } else {
4818             cmp = cur1 < cur2 ? -1 : 1;
4819         }
4820     }
4821
4822     if (pv1tmp)
4823         Safefree(pv1);
4824     if (pv2tmp)
4825         Safefree(pv2);
4826
4827     return cmp;
4828 }
4829
4830 /*
4831 =for apidoc sv_cmp_locale
4832
4833 Compares the strings in two SVs in a locale-aware manner. See
4834 L</sv_cmp_locale>
4835
4836 =cut
4837 */
4838
4839 I32
4840 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4841 {
4842 #ifdef USE_LOCALE_COLLATE
4843
4844     char *pv1, *pv2;
4845     STRLEN len1, len2;
4846     I32 retval;
4847
4848     if (PL_collation_standard)
4849         goto raw_compare;
4850
4851     len1 = 0;
4852     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4853     len2 = 0;
4854     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4855
4856     if (!pv1 || !len1) {
4857         if (pv2 && len2)
4858             return -1;
4859         else
4860             goto raw_compare;
4861     }
4862     else {
4863         if (!pv2 || !len2)
4864             return 1;
4865     }
4866
4867     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4868
4869     if (retval)
4870         return retval < 0 ? -1 : 1;
4871
4872     /*
4873      * When the result of collation is equality, that doesn't mean
4874      * that there are no differences -- some locales exclude some
4875      * characters from consideration.  So to avoid false equalities,
4876      * we use the raw string as a tiebreaker.