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 /* the number can be converted to integer with atol() or atoll() although */
1490 #define IS_NUMBER_TO_INT_BY_ATOL     0x01 /* integer (may have decimals) */
1491 #define IS_NUMBER_TO_INT_BY_STRTOL   0x02 /* it may exceed IV_MAX */
1492 #define IS_NUMBER_TO_INT_BY_ATOF     0x04 /* seen something like 123e4 */
1493 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1494 #define IS_NUMBER_AS_LONG_AS_IV_MAX  0x10 /* may(be not) larger than IV_MAX */
1495 #define IS_NUMBER_NOT_INT            0x20 /* seen a decimal point or e */
1496 #define IS_NUMBER_NEG                0x40 /* seen a leading - */
1497 #define IS_NUMBER_INFINITY           0x80 /* /^\s*-?Infinity\s*$/i */
1498
1499 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1500    until proven guilty, assume that things are not that bad... */
1501
1502 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1503    an IV (an assumption perl has been based on to date) it becomes necessary
1504    to remove the assumption that the NV always carries enough precision to
1505    recreate the IV whenever needed, and that the NV is the canonical form.
1506    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1507    precision as an side effect of conversion (which would lead to insanity
1508    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1509    1) to distinguish between IV/UV/NV slots that have cached a valid
1510       conversion where precision was lost and IV/UV/NV slots that have a
1511       valid conversion which has lost no precision
1512    2) to ensure that if a numeric conversion to one form is request that
1513       would lose precision, the precise conversion (or differently
1514       imprecise conversion) is also performed and cached, to prevent
1515       requests for different numeric formats on the same SV causing
1516       lossy conversion chains. (lossless conversion chains are perfectly
1517       acceptable (still))
1518
1519
1520    flags are used:
1521    SvIOKp is true if the IV slot contains a valid value
1522    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1523    SvNOKp is true if the NV slot contains a valid value
1524    SvNOK  is true only if the NV value is accurate
1525
1526    so
1527    while converting from PV to NV check to see if converting that NV to an
1528    IV(or UV) would lose accuracy over a direct conversion from PV to
1529    IV(or UV). If it would, cache both conversions, return NV, but mark
1530    SV as IOK NOKp (ie not NOK).
1531
1532    while converting from PV to IV check to see if converting that IV to an
1533    NV would lose accuracy over a direct conversion from PV to NV. If it
1534    would, cache both conversions, flag similarly.
1535
1536    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1537    correctly because if IV & NV were set NV *always* overruled.
1538    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1539    changes - now IV and NV together means that the two are interchangeable
1540    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1541
1542    The benefit of this is operations such as pp_add know that if SvIOK is
1543    true for both left and right operands, then integer addition can be
1544    used instead of floating point. (for cases where the result won't
1545    overflow) Before, floating point was always used, which could lead to
1546    loss of precision compared with integer addition.
1547
1548    * making IV and NV equal status should make maths accurate on 64 bit
1549      platforms
1550    * may speed up maths somewhat if pp_add and friends start to use
1551      integers when possible instead of fp. (hopefully the overhead in
1552      looking for SvIOK and checking for overflow will not outweigh the
1553      fp to integer speedup)
1554    * will slow down integer operations (callers of SvIV) on "inaccurate"
1555      values, as the change from SvIOK to SvIOKp will cause a call into
1556      sv_2iv each time rather than a macro access direct to the IV slot
1557    * should speed up number->string conversion on integers as IV is
1558      favoured when IV and NV equally accurate
1559
1560    ####################################################################
1561    You had better be using SvIOK_notUV if you want an IV for arithmetic
1562    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1563    SvUOK is true iff UV.
1564    ####################################################################
1565
1566    Your mileage will vary depending your CPUs relative fp to integer
1567    performance ratio.
1568 */
1569
1570 #ifndef NV_PRESERVES_UV
1571 #define IS_NUMBER_UNDERFLOW_IV 1
1572 #define IS_NUMBER_UNDERFLOW_UV 2
1573 #define IS_NUMBER_IV_AND_UV 2
1574 #define IS_NUMBER_OVERFLOW_IV 4
1575 #define IS_NUMBER_OVERFLOW_UV 5
1576 /* Hopefully your optimiser will consider inlining these two functions.  */
1577 STATIC int
1578 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1579     NV nv = SvNVX(sv);          /* Code simpler and had compiler problems if */
1580     UV nv_as_uv = U_V(nv);      /*  these are not in simple variables.   */
1581     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, (UV)numtype));
1582     if (nv_as_uv <= (UV)IV_MAX) {
1583         (void)SvIOKp_on(sv);
1584         (void)SvNOKp_on(sv);
1585         /* Within suitable range to fit in an IV,  atol won't overflow */
1586         /* XXX quite sure? Is that your final answer? not really, I'm
1587            trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1588         SvIVX(sv) = (IV)Atol(SvPVX(sv));
1589         if (numtype & IS_NUMBER_NOT_INT) {
1590             /* I believe that even if the original PV had decimals, they
1591                are lost beyond the limit of the FP precision.
1592                However, neither is canonical, so both only get p flags.
1593                NWC, 2000/11/25 */
1594             /* Both already have p flags, so do nothing */
1595         } else if (SvIVX(sv) == I_V(nv)) {
1596             SvNOK_on(sv);
1597             SvIOK_on(sv);
1598         } else {
1599             SvIOK_on(sv);
1600             /* It had no "." so it must be integer.  assert (get in here from
1601                sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1602                IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1603                conversion routines need audit.  */
1604         }
1605         return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1606     }
1607     /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1608     (void)SvIOKp_on(sv);
1609     (void)SvNOKp_on(sv);
1610 #ifdef HAS_STRTOUL
1611     {
1612         int save_errno = errno;
1613         errno = 0;
1614         SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1615         if (errno == 0) {
1616             if (numtype & IS_NUMBER_NOT_INT) {
1617                 /* UV and NV both imprecise.  */
1618                 SvIsUV_on(sv);
1619             } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1620                 SvNOK_on(sv);
1621                 SvIOK_on(sv);
1622                 SvIsUV_on(sv);
1623             } else {
1624                 SvIOK_on(sv);
1625                 SvIsUV_on(sv);
1626             }
1627             errno = save_errno;
1628             return IS_NUMBER_OVERFLOW_IV;
1629         }
1630         errno = save_errno;
1631         SvNOK_on(sv);
1632         /* Must have just overflowed UV, but not enough that an NV could spot
1633            this.. */
1634         return IS_NUMBER_OVERFLOW_UV;
1635     }
1636 #else
1637     /* We've just lost integer precision, nothing we could do. */
1638     SvUVX(sv) = nv_as_uv;
1639     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, (UV)numtype));
1640     /* UV and NV slots equally valid only if we have casting symmetry. */
1641     if (numtype & IS_NUMBER_NOT_INT) {
1642         SvIsUV_on(sv);
1643     } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1644         /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1645            UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1646            get to this point if NVs don't preserve UVs) */
1647         SvNOK_on(sv);
1648         SvIOK_on(sv);
1649         SvIsUV_on(sv);
1650     } else {
1651         /* As above, I believe UV at least as good as NV */
1652         SvIsUV_on(sv);
1653     }
1654 #endif /* HAS_STRTOUL */
1655     return IS_NUMBER_OVERFLOW_IV;
1656 }
1657
1658 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1659 STATIC int
1660 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1661 {
1662     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));
1663     if (SvNVX(sv) < (NV)IV_MIN) {
1664         (void)SvIOKp_on(sv);
1665         (void)SvNOK_on(sv);
1666         SvIVX(sv) = IV_MIN;
1667         return IS_NUMBER_UNDERFLOW_IV;
1668     }
1669     if (SvNVX(sv) > (NV)UV_MAX) {
1670         (void)SvIOKp_on(sv);
1671         (void)SvNOK_on(sv);
1672         SvIsUV_on(sv);
1673         SvUVX(sv) = UV_MAX;
1674         return IS_NUMBER_OVERFLOW_UV;
1675     }
1676     if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1677         (void)SvIOKp_on(sv);
1678         (void)SvNOK_on(sv);
1679         /* Can't use strtol etc to convert this string */
1680         if (SvNVX(sv) <= (UV)IV_MAX) {
1681             SvIVX(sv) = I_V(SvNVX(sv));
1682             if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1683                 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1684             } else {
1685                 /* Integer is imprecise. NOK, IOKp */
1686             }
1687             return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1688         }
1689         SvIsUV_on(sv);
1690         SvUVX(sv) = U_V(SvNVX(sv));
1691         if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1692             if (SvUVX(sv) == UV_MAX) {
1693                 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1694                    possibly be preserved by NV. Hence, it must be overflow.
1695                    NOK, IOKp */
1696                 return IS_NUMBER_OVERFLOW_UV;
1697             }
1698             SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1699         } else {
1700             /* Integer is imprecise. NOK, IOKp */
1701         }
1702         return IS_NUMBER_OVERFLOW_IV;
1703     }
1704     return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1705 }
1706 #endif /* NV_PRESERVES_UV*/
1707
1708 IV
1709 Perl_sv_2iv(pTHX_ register SV *sv)
1710 {
1711     if (!sv)
1712         return 0;
1713     if (SvGMAGICAL(sv)) {
1714         mg_get(sv);
1715         if (SvIOKp(sv))
1716             return SvIVX(sv);
1717         if (SvNOKp(sv)) {
1718             return I_V(SvNVX(sv));
1719         }
1720         if (SvPOKp(sv) && SvLEN(sv))
1721             return asIV(sv);
1722         if (!SvROK(sv)) {
1723             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1724                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1725                     report_uninit();
1726             }
1727             return 0;
1728         }
1729     }
1730     if (SvTHINKFIRST(sv)) {
1731         if (SvROK(sv)) {
1732           SV* tmpstr;
1733           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1734                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1735               return SvIV(tmpstr);
1736           return PTR2IV(SvRV(sv));
1737         }
1738         if (SvREADONLY(sv) && SvFAKE(sv)) {
1739             sv_force_normal(sv);
1740         }
1741         if (SvREADONLY(sv) && !SvOK(sv)) {
1742             if (ckWARN(WARN_UNINITIALIZED))
1743                 report_uninit();
1744             return 0;
1745         }
1746     }
1747     if (SvIOKp(sv)) {
1748         if (SvIsUV(sv)) {
1749             return (IV)(SvUVX(sv));
1750         }
1751         else {
1752             return SvIVX(sv);
1753         }
1754     }
1755     if (SvNOKp(sv)) {
1756         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1757          * without also getting a cached IV/UV from it at the same time
1758          * (ie PV->NV conversion should detect loss of accuracy and cache
1759          * IV or UV at same time to avoid this.  NWC */
1760
1761         if (SvTYPE(sv) == SVt_NV)
1762             sv_upgrade(sv, SVt_PVNV);
1763
1764         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1765         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1766            certainly cast into the IV range at IV_MAX, whereas the correct
1767            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1768            cases go to UV */
1769         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1770             SvIVX(sv) = I_V(SvNVX(sv));
1771             if (SvNVX(sv) == (NV) SvIVX(sv)
1772 #ifndef NV_PRESERVES_UV
1773                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1774                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1775                 /* Don't flag it as "accurately an integer" if the number
1776                    came from a (by definition imprecise) NV operation, and
1777                    we're outside the range of NV integer precision */
1778 #endif
1779                 ) {
1780                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
1781                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1782                                       "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1783                                       PTR2UV(sv),
1784                                       SvNVX(sv),
1785                                       SvIVX(sv)));
1786
1787             } else {
1788                 /* IV not precise.  No need to convert from PV, as NV
1789                    conversion would already have cached IV if it detected
1790                    that PV->IV would be better than PV->NV->IV
1791                    flags already correct - don't set public IOK.  */
1792                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1793                                       "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1794                                       PTR2UV(sv),
1795                                       SvNVX(sv),
1796                                       SvIVX(sv)));
1797             }
1798             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1799                but the cast (NV)IV_MIN rounds to a the value less (more
1800                negative) than IV_MIN which happens to be equal to SvNVX ??
1801                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1802                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1803                (NV)UVX == NVX are both true, but the values differ. :-(
1804                Hopefully for 2s complement IV_MIN is something like
1805                0x8000000000000000 which will be exact. NWC */
1806         }
1807         else {
1808             SvUVX(sv) = U_V(SvNVX(sv));
1809             if (
1810                 (SvNVX(sv) == (NV) SvUVX(sv))
1811 #ifndef  NV_PRESERVES_UV
1812                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1813                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1814                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1815                 /* Don't flag it as "accurately an integer" if the number
1816                    came from a (by definition imprecise) NV operation, and
1817                    we're outside the range of NV integer precision */
1818 #endif
1819                 )
1820                 SvIOK_on(sv);
1821             SvIsUV_on(sv);
1822           ret_iv_max:
1823             DEBUG_c(PerlIO_printf(Perl_debug_log,
1824                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1825                                   PTR2UV(sv),
1826                                   SvUVX(sv),
1827                                   SvUVX(sv)));
1828             return (IV)SvUVX(sv);
1829         }
1830     }
1831     else if (SvPOKp(sv) && SvLEN(sv)) {
1832         I32 numtype = looks_like_number(sv);
1833
1834         /* We want to avoid a possible problem when we cache an IV which
1835            may be later translated to an NV, and the resulting NV is not
1836            the translation of the initial data.
1837
1838            This means that if we cache such an IV, we need to cache the
1839            NV as well.  Moreover, we trade speed for space, and do not
1840            cache the NV if we are sure it's not needed.
1841          */
1842
1843         if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1844             /* The NV may be reconstructed from IV - safe to cache IV,
1845                 which may be calculated by atol(). */
1846             if (SvTYPE(sv) < SVt_PVIV)
1847                 sv_upgrade(sv, SVt_PVIV);
1848             (void)SvIOK_on(sv);
1849             SvIVX(sv) = Atol(SvPVX(sv));
1850         } else {
1851 #ifdef HAS_STRTOL
1852             IV i;
1853             int save_errno = errno;
1854             /* Is it an integer that we could convert with strtol?
1855                So try it, and if it doesn't set errno then it's pukka.
1856                This should be faster than going atof and then thinking.  */
1857             if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1858                   == IS_NUMBER_TO_INT_BY_STRTOL)
1859                 /* && is a sequence point. Without it not sure if I'm trying
1860                    to do too much between sequence points and hence going
1861                    undefined */
1862                 && ((errno = 0), 1) /* , 1 so always true */
1863                 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1864                 && (errno == 0)) {
1865                 if (SvTYPE(sv) < SVt_PVIV)
1866                     sv_upgrade(sv, SVt_PVIV);
1867                 (void)SvIOK_on(sv);
1868                 SvIVX(sv) = i;
1869                 errno = save_errno;
1870             } else
1871 #endif
1872             {
1873                 NV d;
1874 #ifdef HAS_STRTOL
1875                 /* Hopefully trace flow will optimise this away where possible
1876                  */
1877                 errno = save_errno;
1878 #endif
1879                 /* It wasn't an integer, or it overflowed, or we don't have
1880                    strtol. Do things the slow way - check if it's a UV etc. */
1881                 d = Atof(SvPVX(sv));
1882
1883                 if (SvTYPE(sv) < SVt_PVNV)
1884                     sv_upgrade(sv, SVt_PVNV);
1885                 SvNVX(sv) = d;
1886
1887                 if (! numtype && ckWARN(WARN_NUMERIC))
1888                     not_a_number(sv);
1889
1890 #if defined(USE_LONG_DOUBLE)
1891                 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1892                                       PTR2UV(sv), SvNVX(sv)));
1893 #else
1894                 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1895                                       PTR2UV(sv), SvNVX(sv)));
1896 #endif
1897
1898
1899 #ifdef NV_PRESERVES_UV
1900                 (void)SvIOKp_on(sv);
1901                 (void)SvNOK_on(sv);
1902                 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1903                     SvIVX(sv) = I_V(SvNVX(sv));
1904                     if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1905                         SvIOK_on(sv);
1906                     } else {
1907                         /* Integer is imprecise. NOK, IOKp */
1908                     }
1909                     /* UV will not work better than IV */
1910                 } else {
1911                     if (SvNVX(sv) > (NV)UV_MAX) {
1912                         SvIsUV_on(sv);
1913                         /* Integer is inaccurate. NOK, IOKp, is UV */
1914                         SvUVX(sv) = UV_MAX;
1915                         SvIsUV_on(sv);
1916                     } else {
1917                         SvUVX(sv) = U_V(SvNVX(sv));
1918                         /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1919                         if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1920                             SvIOK_on(sv);
1921                             SvIsUV_on(sv);
1922                         } else {
1923                             /* Integer is imprecise. NOK, IOKp, is UV */
1924                             SvIsUV_on(sv);
1925                         }
1926                     }
1927                     goto ret_iv_max;
1928                 }
1929 #else /* NV_PRESERVES_UV */
1930                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1931                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1932                     /* Small enough to preserve all bits. */
1933                     (void)SvIOKp_on(sv);
1934                     SvNOK_on(sv);
1935                     SvIVX(sv) = I_V(SvNVX(sv));
1936                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
1937                         SvIOK_on(sv);
1938                     /* Assumption: first non-preserved integer is < IV_MAX,
1939                        this NV is in the preserved range, therefore: */
1940                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1941                           < (UV)IV_MAX)) {
1942                         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);
1943                     }
1944                 } else if (sv_2iuv_non_preserve (sv, numtype)
1945                            >= IS_NUMBER_OVERFLOW_IV)
1946                     goto ret_iv_max;
1947 #endif /* NV_PRESERVES_UV */
1948             }
1949         }
1950     } else  {
1951         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1952             report_uninit();
1953         if (SvTYPE(sv) < SVt_IV)
1954             /* Typically the caller expects that sv_any is not NULL now.  */
1955             sv_upgrade(sv, SVt_IV);
1956         return 0;
1957     }
1958     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1959         PTR2UV(sv),SvIVX(sv)));
1960     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1961 }
1962
1963 UV
1964 Perl_sv_2uv(pTHX_ register SV *sv)
1965 {
1966     if (!sv)
1967         return 0;
1968     if (SvGMAGICAL(sv)) {
1969         mg_get(sv);
1970         if (SvIOKp(sv))
1971             return SvUVX(sv);
1972         if (SvNOKp(sv))
1973             return U_V(SvNVX(sv));
1974         if (SvPOKp(sv) && SvLEN(sv))
1975             return asUV(sv);
1976         if (!SvROK(sv)) {
1977             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1978                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1979                     report_uninit();
1980             }
1981             return 0;
1982         }
1983     }
1984     if (SvTHINKFIRST(sv)) {
1985         if (SvROK(sv)) {
1986           SV* tmpstr;
1987           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1988                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1989               return SvUV(tmpstr);
1990           return PTR2UV(SvRV(sv));
1991         }
1992         if (SvREADONLY(sv) && SvFAKE(sv)) {
1993             sv_force_normal(sv);
1994         }
1995         if (SvREADONLY(sv) && !SvOK(sv)) {
1996             if (ckWARN(WARN_UNINITIALIZED))
1997                 report_uninit();
1998             return 0;
1999         }
2000     }
2001     if (SvIOKp(sv)) {
2002         if (SvIsUV(sv)) {
2003             return SvUVX(sv);
2004         }
2005         else {
2006             return (UV)SvIVX(sv);
2007         }
2008     }
2009     if (SvNOKp(sv)) {
2010         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2011          * without also getting a cached IV/UV from it at the same time
2012          * (ie PV->NV conversion should detect loss of accuracy and cache
2013          * IV or UV at same time to avoid this. */
2014         /* IV-over-UV optimisation - choose to cache IV if possible */
2015
2016         if (SvTYPE(sv) == SVt_NV)
2017             sv_upgrade(sv, SVt_PVNV);
2018
2019         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2020         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2021             SvIVX(sv) = I_V(SvNVX(sv));
2022             if (SvNVX(sv) == (NV) SvIVX(sv)
2023 #ifndef NV_PRESERVES_UV
2024                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2025                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2026                 /* Don't flag it as "accurately an integer" if the number
2027                    came from a (by definition imprecise) NV operation, and
2028                    we're outside the range of NV integer precision */
2029 #endif
2030                 ) {
2031                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2032                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2033                                       "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2034                                       PTR2UV(sv),
2035                                       SvNVX(sv),
2036                                       SvIVX(sv)));
2037
2038             } else {
2039                 /* IV not precise.  No need to convert from PV, as NV
2040                    conversion would already have cached IV if it detected
2041                    that PV->IV would be better than PV->NV->IV
2042                    flags already correct - don't set public IOK.  */
2043                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2044                                       "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2045                                       PTR2UV(sv),
2046                                       SvNVX(sv),
2047                                       SvIVX(sv)));
2048             }
2049             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2050                but the cast (NV)IV_MIN rounds to a the value less (more
2051                negative) than IV_MIN which happens to be equal to SvNVX ??
2052                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2053                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2054                (NV)UVX == NVX are both true, but the values differ. :-(
2055                Hopefully for 2s complement IV_MIN is something like
2056                0x8000000000000000 which will be exact. NWC */
2057         }
2058         else {
2059             SvUVX(sv) = U_V(SvNVX(sv));
2060             if (
2061                 (SvNVX(sv) == (NV) SvUVX(sv))
2062 #ifndef  NV_PRESERVES_UV
2063                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2064                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2065                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2066                 /* Don't flag it as "accurately an integer" if the number
2067                    came from a (by definition imprecise) NV operation, and
2068                    we're outside the range of NV integer precision */
2069 #endif
2070                 )
2071                 SvIOK_on(sv);
2072             SvIsUV_on(sv);
2073             DEBUG_c(PerlIO_printf(Perl_debug_log,
2074                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2075                                   PTR2UV(sv),
2076                                   SvUVX(sv),
2077                                   SvUVX(sv)));
2078         }
2079     }
2080     else if (SvPOKp(sv) && SvLEN(sv)) {
2081         I32 numtype = looks_like_number(sv);
2082
2083         /* We want to avoid a possible problem when we cache a UV which
2084            may be later translated to an NV, and the resulting NV is not
2085            the translation of the initial data.
2086
2087            This means that if we cache such a UV, we need to cache the
2088            NV as well.  Moreover, we trade speed for space, and do not
2089            cache the NV if not needed.
2090          */
2091
2092         if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2093             /* The NV may be reconstructed from IV - safe to cache IV,
2094                 which may be calculated by atol(). */
2095             if (SvTYPE(sv) < SVt_PVIV)
2096                 sv_upgrade(sv, SVt_PVIV);
2097             (void)SvIOK_on(sv);
2098             SvIVX(sv) = Atol(SvPVX(sv));
2099         } else {
2100 #ifdef HAS_STRTOUL
2101             UV u;
2102             char *num_begin = SvPVX(sv);
2103             int save_errno = errno;
2104
2105             /* seems that strtoul taking numbers that start with - is
2106                implementation dependant, and can't be relied upon.  */
2107             if (numtype & IS_NUMBER_NEG) {
2108                 /* Not totally defensive. assumine that looks_like_num
2109                    didn't lie about a - sign */
2110                 while (isSPACE(*num_begin))
2111                     num_begin++;
2112                 if (*num_begin == '-')
2113                     num_begin++;
2114             }
2115
2116             /* Is it an integer that we could convert with strtoul?
2117                So try it, and if it doesn't set errno then it's pukka.
2118                This should be faster than going atof and then thinking.  */
2119             if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2120                  == IS_NUMBER_TO_INT_BY_STRTOL)
2121                 && ((errno = 0), 1) /* always true */
2122                 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2123                 && (errno == 0)
2124                 /* If known to be negative, check it didn't undeflow IV
2125                    XXX possibly we should put more negative values as NVs
2126                    direct rather than go via atof below */
2127                 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2128                 errno = save_errno;
2129
2130                 if (SvTYPE(sv) < SVt_PVIV)
2131                     sv_upgrade(sv, SVt_PVIV);
2132                 (void)SvIOK_on(sv);
2133
2134                 /* If it's negative must use IV.
2135                    IV-over-UV optimisation */
2136                 if (numtype & IS_NUMBER_NEG) {
2137                     SvIVX(sv) = -(IV)u;
2138                 } else if (u <= (UV) IV_MAX) {
2139                     SvIVX(sv) = (IV)u;
2140                 } else {
2141                     /* it didn't overflow, and it was positive. */
2142                     SvUVX(sv) = u;
2143                     SvIsUV_on(sv);
2144                 }
2145             } else
2146 #endif
2147             {
2148                 NV d;
2149 #ifdef HAS_STRTOUL
2150                 /* Hopefully trace flow will optimise this away where possible
2151                  */
2152                 errno = save_errno;
2153 #endif
2154                 /* It wasn't an integer, or it overflowed, or we don't have
2155                    strtol. Do things the slow way - check if it's a IV etc. */
2156                 d = Atof(SvPVX(sv));
2157
2158                 if (SvTYPE(sv) < SVt_PVNV)
2159                     sv_upgrade(sv, SVt_PVNV);
2160                 SvNVX(sv) = d;
2161
2162                 if (! numtype && ckWARN(WARN_NUMERIC))
2163                     not_a_number(sv);
2164
2165 #if defined(USE_LONG_DOUBLE)
2166                 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2167                                       PTR2UV(sv), SvNVX(sv)));
2168 #else
2169                 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2170                                       PTR2UV(sv), SvNVX(sv)));
2171 #endif
2172
2173 #ifdef NV_PRESERVES_UV
2174                 (void)SvIOKp_on(sv);
2175                 (void)SvNOK_on(sv);
2176                 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2177                     SvIVX(sv) = I_V(SvNVX(sv));
2178                     if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2179                         SvIOK_on(sv);
2180                     } else {
2181                         /* Integer is imprecise. NOK, IOKp */
2182                     }
2183                     /* UV will not work better than IV */
2184                 } else {
2185                     if (SvNVX(sv) > (NV)UV_MAX) {
2186                         SvIsUV_on(sv);
2187                         /* Integer is inaccurate. NOK, IOKp, is UV */
2188                         SvUVX(sv) = UV_MAX;
2189                         SvIsUV_on(sv);
2190                     } else {
2191                         SvUVX(sv) = U_V(SvNVX(sv));
2192                         /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2193                            NV preservse UV so can do correct comparison.  */
2194                         if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2195                             SvIOK_on(sv);
2196                             SvIsUV_on(sv);
2197                         } else {
2198                             /* Integer is imprecise. NOK, IOKp, is UV */
2199                             SvIsUV_on(sv);
2200                         }
2201                     }
2202                 }
2203 #else /* NV_PRESERVES_UV */
2204                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2205                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2206                     /* Small enough to preserve all bits. */
2207                     (void)SvIOKp_on(sv);
2208                     SvNOK_on(sv);
2209                     SvIVX(sv) = I_V(SvNVX(sv));
2210                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2211                         SvIOK_on(sv);
2212                     /* Assumption: first non-preserved integer is < IV_MAX,
2213                        this NV is in the preserved range, therefore: */
2214                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2215                           < (UV)IV_MAX)) {
2216                         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);
2217                     }
2218                 } else
2219                     sv_2iuv_non_preserve (sv, numtype);
2220 #endif /* NV_PRESERVES_UV */
2221             }
2222         }
2223     }
2224     else  {
2225         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2226             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2227                 report_uninit();
2228         }
2229         if (SvTYPE(sv) < SVt_IV)
2230             /* Typically the caller expects that sv_any is not NULL now.  */
2231             sv_upgrade(sv, SVt_IV);
2232         return 0;
2233     }
2234
2235     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2236                           PTR2UV(sv),SvUVX(sv)));
2237     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2238 }
2239
2240 NV
2241 Perl_sv_2nv(pTHX_ register SV *sv)
2242 {
2243     if (!sv)
2244         return 0.0;
2245     if (SvGMAGICAL(sv)) {
2246         mg_get(sv);
2247         if (SvNOKp(sv))
2248             return SvNVX(sv);
2249         if (SvPOKp(sv) && SvLEN(sv)) {
2250             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2251                 not_a_number(sv);
2252             return Atof(SvPVX(sv));
2253         }
2254         if (SvIOKp(sv)) {
2255             if (SvIsUV(sv))
2256                 return (NV)SvUVX(sv);
2257             else
2258                 return (NV)SvIVX(sv);
2259         }
2260         if (!SvROK(sv)) {
2261             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2262                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2263                     report_uninit();
2264             }
2265             return 0;
2266         }
2267     }
2268     if (SvTHINKFIRST(sv)) {
2269         if (SvROK(sv)) {
2270           SV* tmpstr;
2271           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2272                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2273               return SvNV(tmpstr);
2274           return PTR2NV(SvRV(sv));
2275         }
2276         if (SvREADONLY(sv) && SvFAKE(sv)) {
2277             sv_force_normal(sv);
2278         }
2279         if (SvREADONLY(sv) && !SvOK(sv)) {
2280             if (ckWARN(WARN_UNINITIALIZED))
2281                 report_uninit();
2282             return 0.0;
2283         }
2284     }
2285     if (SvTYPE(sv) < SVt_NV) {
2286         if (SvTYPE(sv) == SVt_IV)
2287             sv_upgrade(sv, SVt_PVNV);
2288         else
2289             sv_upgrade(sv, SVt_NV);
2290 #if defined(USE_LONG_DOUBLE)
2291         DEBUG_c({
2292             STORE_NUMERIC_LOCAL_SET_STANDARD();
2293             PerlIO_printf(Perl_debug_log,
2294                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2295                           PTR2UV(sv), SvNVX(sv));
2296             RESTORE_NUMERIC_LOCAL();
2297         });
2298 #else
2299         DEBUG_c({
2300             STORE_NUMERIC_LOCAL_SET_STANDARD();
2301             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2302                           PTR2UV(sv), SvNVX(sv));
2303             RESTORE_NUMERIC_LOCAL();
2304         });
2305 #endif
2306     }
2307     else if (SvTYPE(sv) < SVt_PVNV)
2308         sv_upgrade(sv, SVt_PVNV);
2309     if (SvIOKp(sv) &&
2310             (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2311     {
2312         SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2313 #ifdef NV_PRESERVES_UV
2314         SvNOK_on(sv);
2315 #else
2316         /* Only set the public NV OK flag if this NV preserves the IV  */
2317         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2318         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2319                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2320             SvNOK_on(sv);
2321         else
2322             SvNOKp_on(sv);
2323 #endif
2324     }
2325     else if (SvPOKp(sv) && SvLEN(sv)) {
2326         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2327             not_a_number(sv);
2328         SvNVX(sv) = Atof(SvPVX(sv));
2329 #ifdef NV_PRESERVES_UV
2330         SvNOK_on(sv);
2331 #else
2332         /* Only set the public NV OK flag if this NV preserves the value in
2333            the PV at least as well as an IV/UV would.
2334            Not sure how to do this 100% reliably. */
2335         /* if that shift count is out of range then Configure's test is
2336            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2337            UV_BITS */
2338         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2339             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2340             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2341         else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2342                 /* Definitely too large/small to fit in an integer, so no loss
2343                    of precision going to integer in the future via NV */
2344             SvNOK_on(sv);
2345         } else {
2346             /* Is it something we can run through strtol etc (ie no
2347                trailing exponent part)? */
2348             int numtype = looks_like_number(sv);
2349             /* XXX probably should cache this if called above */
2350
2351             if (!(numtype &
2352                   (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2353                 /* Can't use strtol etc to convert this string, so don't try */
2354                 SvNOK_on(sv);
2355             } else
2356                 sv_2inuv_non_preserve (sv, numtype);
2357         }
2358 #endif /* NV_PRESERVES_UV */
2359     }
2360     else  {
2361         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2362             report_uninit();
2363         if (SvTYPE(sv) < SVt_NV)
2364             /* Typically the caller expects that sv_any is not NULL now.  */
2365             /* XXX Ilya implies that this is a bug in callers that assume this
2366                and ideally should be fixed.  */
2367             sv_upgrade(sv, SVt_NV);
2368         return 0.0;
2369     }
2370 #if defined(USE_LONG_DOUBLE)
2371     DEBUG_c({
2372         STORE_NUMERIC_LOCAL_SET_STANDARD();
2373         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2374                       PTR2UV(sv), SvNVX(sv));
2375         RESTORE_NUMERIC_LOCAL();
2376     });
2377 #else
2378     DEBUG_c({
2379         STORE_NUMERIC_LOCAL_SET_STANDARD();
2380         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2381                       PTR2UV(sv), SvNVX(sv));
2382         RESTORE_NUMERIC_LOCAL();
2383     });
2384 #endif
2385     return SvNVX(sv);
2386 }
2387
2388 STATIC IV
2389 S_asIV(pTHX_ SV *sv)
2390 {
2391     I32 numtype = looks_like_number(sv);
2392     NV d;
2393
2394     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2395         return Atol(SvPVX(sv));
2396     if (!numtype) {
2397         if (ckWARN(WARN_NUMERIC))
2398             not_a_number(sv);
2399     }
2400     d = Atof(SvPVX(sv));
2401     return I_V(d);
2402 }
2403
2404 STATIC UV
2405 S_asUV(pTHX_ SV *sv)
2406 {
2407     I32 numtype = looks_like_number(sv);
2408
2409 #ifdef HAS_STRTOUL
2410     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2411         return Strtoul(SvPVX(sv), Null(char**), 10);
2412 #endif
2413     if (!numtype) {
2414         if (ckWARN(WARN_NUMERIC))
2415             not_a_number(sv);
2416     }
2417     return U_V(Atof(SvPVX(sv)));
2418 }
2419
2420 /*
2421  * Returns a combination of (advisory only - can get false negatives)
2422  * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2423  * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2424  * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2425  * 0 if does not look like number.
2426  *
2427  * (atol and strtol stop when they hit a decimal point. strtol will return
2428  * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2429  * do this, and vendors have had 11 years to get it right.
2430  * However, will try to make it still work with only atol
2431  *
2432  * IS_NUMBER_TO_INT_BY_ATOL     123456789 or 123456789.3  definitely < IV_MAX
2433  * IS_NUMBER_TO_INT_BY_STRTOL   123456789 or 123456789.3  if digits = IV_MAX
2434  * IS_NUMBER_TO_INT_BY_ATOF     123456789e0               or >> IV_MAX
2435  * IS_NUMBER_LONGER_THAN_IV_MAX   lots of digits, don't bother with atol
2436  * IS_NUMBER_AS_LONG_AS_IV_MAX    atol might hit LONG_MAX, might not.
2437  * IS_NUMBER_NOT_INT            saw "." or "e"
2438  * IS_NUMBER_NEG
2439  * IS_NUMBER_INFINITY
2440  */
2441
2442 /*
2443 =for apidoc looks_like_number
2444
2445 Test if an the content of an SV looks like a number (or is a
2446 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2447 issue a non-numeric warning), even if your atof() doesn't grok them.
2448
2449 =cut
2450 */
2451
2452 I32
2453 Perl_looks_like_number(pTHX_ SV *sv)
2454 {
2455     register char *s;
2456     register char *send;
2457     register char *sbegin;
2458     register char *nbegin;
2459     I32 numtype = 0;
2460     I32 sawinf  = 0;
2461     STRLEN len;
2462 #ifdef USE_LOCALE_NUMERIC
2463     bool specialradix = FALSE;
2464 #endif
2465
2466     if (SvPOK(sv)) {
2467         sbegin = SvPVX(sv);
2468         len = SvCUR(sv);
2469     }
2470     else if (SvPOKp(sv))
2471         sbegin = SvPV(sv, len);
2472     else
2473         return 1;
2474     send = sbegin + len;
2475
2476     s = sbegin;
2477     while (isSPACE(*s))
2478         s++;
2479     if (*s == '-') {
2480         s++;
2481         numtype = IS_NUMBER_NEG;
2482     }
2483     else if (*s == '+')
2484         s++;
2485
2486     nbegin = s;
2487     /*
2488      * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2489      * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2490      * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2491      * will need (int)atof().
2492      */
2493
2494     /* next must be digit or the radix separator or beginning of infinity */
2495     if (isDIGIT(*s)) {
2496         do {
2497             s++;
2498         } while (isDIGIT(*s));
2499
2500         /* Aaargh. long long really is irritating.
2501            In the gospel according to ANSI 1989, it is an axiom that "long"
2502            is the longest integer type, and that if you don't know how long
2503            something is you can cast it to long, and nothing will be lost
2504            (except possibly speed of execution if long is slower than the
2505            type is was).
2506            Now, one can't be sure if the old rules apply, or long long
2507            (or some other newfangled thing) is actually longer than the
2508            (formerly) longest thing.
2509         */
2510         /* This lot will work for 64 bit  *as long as* either
2511            either long is 64 bit
2512            or     we can find both strtol/strtoq and strtoul/strtouq
2513            If not, we really should refuse to let the user use 64 bit IVs
2514            By "64 bit" I really mean IVs that don't get preserved by NVs
2515            It also should work for 128 bit IVs. Can any lend me a machine to
2516            test this?
2517         */
2518         if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2519             numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2520         else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2521                                           ? sizeof(long) : sizeof (IV))*8-1))
2522             numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2523         else
2524             /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2525                digit less (IV_MAX=  9223372036854775807,
2526                            UV_MAX= 18446744073709551615) so be cautious  */
2527             numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2528
2529         if (*s == '.'
2530 #ifdef USE_LOCALE_NUMERIC
2531             || (specialradix = IS_NUMERIC_RADIX(s))
2532 #endif
2533             ) {
2534 #ifdef USE_LOCALE_NUMERIC
2535             if (specialradix)
2536                 s += SvCUR(PL_numeric_radix_sv);
2537             else
2538 #endif
2539                 s++;
2540             numtype |= IS_NUMBER_NOT_INT;
2541             while (isDIGIT(*s))  /* optional digits after the radix */
2542                 s++;
2543         }
2544     }
2545     else if (*s == '.'
2546 #ifdef USE_LOCALE_NUMERIC
2547             || (specialradix = IS_NUMERIC_RADIX(s))
2548 #endif
2549             ) {
2550 #ifdef USE_LOCALE_NUMERIC
2551         if (specialradix)
2552             s += SvCUR(PL_numeric_radix_sv);
2553         else
2554 #endif
2555             s++;
2556         numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2557         /* no digits before the radix means we need digits after it */
2558         if (isDIGIT(*s)) {
2559             do {
2560                 s++;
2561             } while (isDIGIT(*s));
2562         }
2563         else
2564             return 0;
2565     }
2566     else if (*s == 'I' || *s == 'i') {
2567         s++; if (*s != 'N' && *s != 'n') return 0;
2568         s++; if (*s != 'F' && *s != 'f') return 0;
2569         s++; if (*s == 'I' || *s == 'i') {
2570             s++; if (*s != 'N' && *s != 'n') return 0;
2571             s++; if (*s != 'I' && *s != 'i') return 0;
2572             s++; if (*s != 'T' && *s != 't') return 0;
2573             s++; if (*s != 'Y' && *s != 'y') return 0;
2574             s++;
2575         }
2576         sawinf = 1;
2577     }
2578     else
2579         return 0;
2580
2581     if (sawinf)
2582         numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign  */
2583           | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2584     else {
2585         /* we can have an optional exponent part */
2586         if (*s == 'e' || *s == 'E') {
2587             numtype &= IS_NUMBER_NEG;
2588             numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2589             s++;
2590             if (*s == '+' || *s == '-')
2591                 s++;
2592             if (isDIGIT(*s)) {
2593                 do {
2594                     s++;
2595                 } while (isDIGIT(*s));
2596             }
2597             else
2598                 return 0;
2599         }
2600     }
2601     while (isSPACE(*s))
2602         s++;
2603     if (s >= send)
2604         return numtype;
2605     if (len == 10 && memEQ(sbegin, "0 but true", 10))
2606         return IS_NUMBER_TO_INT_BY_ATOL;
2607     return 0;
2608 }
2609
2610 char *
2611 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2612 {
2613     STRLEN n_a;
2614     return sv_2pv(sv, &n_a);
2615 }
2616
2617 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2618 static char *
2619 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2620 {
2621     char *ptr = buf + TYPE_CHARS(UV);
2622     char *ebuf = ptr;
2623     int sign;
2624
2625     if (is_uv)
2626         sign = 0;
2627     else if (iv >= 0) {
2628         uv = iv;
2629         sign = 0;
2630     } else {
2631         uv = -iv;
2632         sign = 1;
2633     }
2634     do {
2635         *--ptr = '0' + (uv % 10);
2636     } while (uv /= 10);
2637     if (sign)
2638         *--ptr = '-';
2639     *peob = ebuf;
2640     return ptr;
2641 }
2642
2643 char *
2644 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2645 {
2646     register char *s;
2647     int olderrno;
2648     SV *tsv;
2649     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2650     char *tmpbuf = tbuf;
2651
2652     if (!sv) {
2653         *lp = 0;
2654         return "";
2655     }
2656     if (SvGMAGICAL(sv)) {
2657         mg_get(sv);
2658         if (SvPOKp(sv)) {
2659             *lp = SvCUR(sv);
2660             return SvPVX(sv);
2661         }
2662         if (SvIOKp(sv)) {
2663             if (SvIsUV(sv))
2664                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2665             else
2666                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2667             tsv = Nullsv;
2668             goto tokensave;
2669         }
2670         if (SvNOKp(sv)) {
2671             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2672             tsv = Nullsv;
2673             goto tokensave;
2674         }
2675         if (!SvROK(sv)) {
2676             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2677                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2678                     report_uninit();
2679             }
2680             *lp = 0;
2681             return "";
2682         }
2683     }
2684     if (SvTHINKFIRST(sv)) {
2685         if (SvROK(sv)) {
2686             SV* tmpstr;
2687             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2688                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2689                 return SvPV(tmpstr,*lp);
2690             sv = (SV*)SvRV(sv);
2691             if (!sv)
2692                 s = "NULLREF";
2693             else {
2694                 MAGIC *mg;
2695
2696                 switch (SvTYPE(sv)) {
2697                 case SVt_PVMG:
2698                     if ( ((SvFLAGS(sv) &
2699                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2700                           == (SVs_OBJECT|SVs_RMG))
2701                          && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2702                          && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2703                         regexp *re = (regexp *)mg->mg_obj;
2704
2705                         if (!mg->mg_ptr) {
2706                             char *fptr = "msix";
2707                             char reflags[6];
2708                             char ch;
2709                             int left = 0;
2710                             int right = 4;
2711                             U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2712
2713                             while((ch = *fptr++)) {
2714                                 if(reganch & 1) {
2715                                     reflags[left++] = ch;
2716                                 }
2717                                 else {
2718                                     reflags[right--] = ch;
2719                                 }
2720                                 reganch >>= 1;
2721                             }
2722                             if(left != 4) {
2723                                 reflags[left] = '-';
2724                                 left = 5;
2725                             }
2726
2727                             mg->mg_len = re->prelen + 4 + left;
2728                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2729                             Copy("(?", mg->mg_ptr, 2, char);
2730                             Copy(reflags, mg->mg_ptr+2, left, char);
2731                             Copy(":", mg->mg_ptr+left+2, 1, char);
2732                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2733                             mg->mg_ptr[mg->mg_len - 1] = ')';
2734                             mg->mg_ptr[mg->mg_len] = 0;
2735                         }
2736                         PL_reginterp_cnt += re->program[0].next_off;
2737                         *lp = mg->mg_len;
2738                         return mg->mg_ptr;
2739                     }
2740                                         /* Fall through */
2741                 case SVt_NULL:
2742                 case SVt_IV:
2743                 case SVt_NV:
2744                 case SVt_RV:
2745                 case SVt_PV:
2746                 case SVt_PVIV:
2747                 case SVt_PVNV:
2748                 case SVt_PVBM:  if (SvROK(sv))
2749                                     s = "REF";
2750                                 else
2751                                     s = "SCALAR";               break;
2752                 case SVt_PVLV:  s = "LVALUE";                   break;
2753                 case SVt_PVAV:  s = "ARRAY";                    break;
2754                 case SVt_PVHV:  s = "HASH";                     break;
2755                 case SVt_PVCV:  s = "CODE";                     break;
2756                 case SVt_PVGV:  s = "GLOB";                     break;
2757                 case SVt_PVFM:  s = "FORMAT";                   break;
2758                 case SVt_PVIO:  s = "IO";                       break;
2759                 default:        s = "UNKNOWN";                  break;
2760                 }
2761                 tsv = NEWSV(0,0);
2762                 if (SvOBJECT(sv))
2763                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2764                 else
2765                     sv_setpv(tsv, s);
2766                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2767                 goto tokensaveref;
2768             }
2769             *lp = strlen(s);
2770             return s;
2771         }
2772         if (SvREADONLY(sv) && !SvOK(sv)) {
2773             if (ckWARN(WARN_UNINITIALIZED))
2774                 report_uninit();
2775             *lp = 0;
2776             return "";
2777         }
2778     }
2779     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2780         /* I'm assuming that if both IV and NV are equally valid then
2781            converting the IV is going to be more efficient */
2782         U32 isIOK = SvIOK(sv);
2783         U32 isUIOK = SvIsUV(sv);
2784         char buf[TYPE_CHARS(UV)];
2785         char *ebuf, *ptr;
2786
2787         if (SvTYPE(sv) < SVt_PVIV)
2788             sv_upgrade(sv, SVt_PVIV);
2789         if (isUIOK)
2790             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2791         else
2792             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2793         SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
2794         Move(ptr,SvPVX(sv),ebuf - ptr,char);
2795         SvCUR_set(sv, ebuf - ptr);
2796         s = SvEND(sv);
2797         *s = '\0';
2798         if (isIOK)
2799             SvIOK_on(sv);
2800         else
2801             SvIOKp_on(sv);
2802         if (isUIOK)
2803             SvIsUV_on(sv);
2804     }
2805     else if (SvNOKp(sv)) {
2806         if (SvTYPE(sv) < SVt_PVNV)
2807             sv_upgrade(sv, SVt_PVNV);
2808         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2809         SvGROW(sv, NV_DIG + 20);
2810         s = SvPVX(sv);
2811         olderrno = errno;       /* some Xenix systems wipe out errno here */
2812 #ifdef apollo
2813         if (SvNVX(sv) == 0.0)
2814             (void)strcpy(s,"0");
2815         else
2816 #endif /*apollo*/
2817         {
2818             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2819         }
2820         errno = olderrno;
2821 #ifdef FIXNEGATIVEZERO
2822         if (*s == '-' && s[1] == '0' && !s[2])
2823             strcpy(s,"0");
2824 #endif
2825         while (*s) s++;
2826 #ifdef hcx
2827         if (s[-1] == '.')
2828             *--s = '\0';
2829 #endif
2830     }
2831     else {
2832         if (ckWARN(WARN_UNINITIALIZED)
2833             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2834             report_uninit();
2835         *lp = 0;
2836         if (SvTYPE(sv) < SVt_PV)
2837             /* Typically the caller expects that sv_any is not NULL now.  */
2838             sv_upgrade(sv, SVt_PV);
2839         return "";
2840     }
2841     *lp = s - SvPVX(sv);
2842     SvCUR_set(sv, *lp);
2843     SvPOK_on(sv);
2844     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2845                           PTR2UV(sv),SvPVX(sv)));
2846     return SvPVX(sv);
2847
2848   tokensave:
2849     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
2850         /* Sneaky stuff here */
2851
2852       tokensaveref:
2853         if (!tsv)
2854             tsv = newSVpv(tmpbuf, 0);
2855         sv_2mortal(tsv);
2856         *lp = SvCUR(tsv);
2857         return SvPVX(tsv);
2858     }
2859     else {
2860         STRLEN len;
2861         char *t;
2862
2863         if (tsv) {
2864             sv_2mortal(tsv);
2865             t = SvPVX(tsv);
2866             len = SvCUR(tsv);
2867         }
2868         else {
2869             t = tmpbuf;
2870             len = strlen(tmpbuf);
2871         }
2872 #ifdef FIXNEGATIVEZERO
2873         if (len == 2 && t[0] == '-' && t[1] == '0') {
2874             t = "0";
2875             len = 1;
2876         }
2877 #endif
2878         (void)SvUPGRADE(sv, SVt_PV);
2879         *lp = len;
2880         s = SvGROW(sv, len + 1);
2881         SvCUR_set(sv, len);
2882         (void)strcpy(s, t);
2883         SvPOKp_on(sv);
2884         return s;
2885     }
2886 }
2887
2888 char *
2889 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2890 {
2891     STRLEN n_a;
2892     return sv_2pvbyte(sv, &n_a);
2893 }
2894
2895 char *
2896 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2897 {
2898     sv_utf8_downgrade(sv,0);
2899     return SvPV(sv,*lp);
2900 }
2901
2902 char *
2903 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2904 {
2905     STRLEN n_a;
2906     return sv_2pvutf8(sv, &n_a);
2907 }
2908
2909 char *
2910 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2911 {
2912     sv_utf8_upgrade(sv);
2913     return SvPV(sv,*lp);
2914 }
2915
2916 /* This function is only called on magical items */
2917 bool
2918 Perl_sv_2bool(pTHX_ register SV *sv)
2919 {
2920     if (SvGMAGICAL(sv))
2921         mg_get(sv);
2922
2923     if (!SvOK(sv))
2924         return 0;
2925     if (SvROK(sv)) {
2926         SV* tmpsv;
2927         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2928                 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2929             return SvTRUE(tmpsv);
2930       return SvRV(sv) != 0;
2931     }
2932     if (SvPOKp(sv)) {
2933         register XPV* Xpvtmp;
2934         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2935                 (*Xpvtmp->xpv_pv > '0' ||
2936                 Xpvtmp->xpv_cur > 1 ||
2937                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2938             return 1;
2939         else
2940             return 0;
2941     }
2942     else {
2943         if (SvIOKp(sv))
2944             return SvIVX(sv) != 0;
2945         else {
2946             if (SvNOKp(sv))
2947                 return SvNVX(sv) != 0.0;
2948             else
2949                 return FALSE;
2950         }
2951     }
2952 }
2953
2954 /*
2955 =for apidoc sv_utf8_upgrade
2956
2957 Convert the PV of an SV to its UTF8-encoded form.
2958 Forces the SV to string form it it is not already.
2959 Always sets the SvUTF8 flag to avoid future validity checks even
2960 if all the bytes have hibit clear.
2961
2962 =cut
2963 */
2964
2965 STRLEN
2966 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2967 {
2968     U8 *s, *t, *e;
2969     int  hibit = 0;
2970
2971     if (!sv)
2972         return 0;
2973
2974     if (!SvPOK(sv)) {
2975         STRLEN len = 0;
2976         (void) sv_2pv(sv,&len);
2977         if (!SvPOK(sv))
2978              return len;
2979     }
2980
2981     if (SvUTF8(sv))
2982         return SvCUR(sv);
2983
2984     if (SvREADONLY(sv) && SvFAKE(sv)) {
2985         sv_force_normal(sv);
2986     }
2987
2988     /* This function could be much more efficient if we had a FLAG in SVs
2989      * to signal if there are any hibit chars in the PV.
2990      * Given that there isn't make loop fast as possible
2991      */
2992     s = (U8 *) SvPVX(sv);
2993     e = (U8 *) SvEND(sv);
2994     t = s;
2995     while (t < e) {
2996         U8 ch = *t++;
2997         if ((hibit = !NATIVE_IS_INVARIANT(ch)))
2998             break;
2999     }
3000     if (hibit) {
3001         STRLEN len;
3002
3003         len = SvCUR(sv) + 1; /* Plus the \0 */
3004         SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3005         SvCUR(sv) = len - 1;
3006         if (SvLEN(sv) != 0)
3007             Safefree(s); /* No longer using what was there before. */
3008         SvLEN(sv) = len; /* No longer know the real size. */
3009     }
3010     /* Mark as UTF-8 even if no hibit - saves scanning loop */
3011     SvUTF8_on(sv);
3012     return SvCUR(sv);
3013 }
3014
3015 /*
3016 =for apidoc sv_utf8_downgrade
3017
3018 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3019 This may not be possible if the PV contains non-byte encoding characters;
3020 if this is the case, either returns false or, if C<fail_ok> is not
3021 true, croaks.
3022
3023 =cut
3024 */
3025
3026 bool
3027 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3028 {
3029     if (SvPOK(sv) && SvUTF8(sv)) {
3030         if (SvCUR(sv)) {
3031             U8 *s;
3032             STRLEN len;
3033
3034             if (SvREADONLY(sv) && SvFAKE(sv))
3035                 sv_force_normal(sv);
3036             s = (U8 *) SvPV(sv, len);
3037             if (!utf8_to_bytes(s, &len)) {
3038                 if (fail_ok)
3039                     return FALSE;
3040 #ifdef USE_BYTES_DOWNGRADES
3041                 else if (IN_BYTE) {
3042                     U8 *d = s;
3043                     U8 *e = (U8 *) SvEND(sv);
3044                     int first = 1;
3045                     while (s < e) {
3046                         UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3047                         if (first && ch > 255) {
3048                             if (PL_op)
3049                                 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3050                                            PL_op_desc[PL_op->op_type]);
3051                             else
3052                                 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3053                             first = 0;
3054                         }
3055                         *d++ = ch;
3056                         s += len;
3057                     }
3058                     *d = '\0';
3059                     len = (d - (U8 *) SvPVX(sv));
3060                 }
3061 #endif
3062                 else {
3063                     if (PL_op)
3064                         Perl_croak(aTHX_ "Wide character in %s",
3065                                    PL_op_desc[PL_op->op_type]);
3066                     else
3067                         Perl_croak(aTHX_ "Wide character");
3068                 }
3069             }
3070             SvCUR(sv) = len;
3071         }
3072     }
3073     SvUTF8_off(sv);
3074     return TRUE;
3075 }
3076
3077 /*
3078 =for apidoc sv_utf8_encode
3079
3080 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3081 flag so that it looks like octets again. Used as a building block
3082 for encode_utf8 in Encode.xs
3083
3084 =cut
3085 */
3086
3087 void
3088 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3089 {
3090     (void) sv_utf8_upgrade(sv);
3091     SvUTF8_off(sv);
3092 }
3093
3094 /*
3095 =for apidoc sv_utf8_decode
3096
3097 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3098 turn of SvUTF8 if needed so that we see characters. Used as a building block
3099 for decode_utf8 in Encode.xs
3100
3101 =cut
3102 */
3103
3104
3105
3106 bool
3107 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3108 {
3109     if (SvPOK(sv)) {
3110         U8 *c;
3111         U8 *e;
3112
3113         /* The octets may have got themselves encoded - get them back as bytes */
3114         if (!sv_utf8_downgrade(sv, TRUE))
3115             return FALSE;
3116
3117         /* it is actually just a matter of turning the utf8 flag on, but
3118          * we want to make sure everything inside is valid utf8 first.
3119          */
3120         c = (U8 *) SvPVX(sv);
3121         if (!is_utf8_string(c, SvCUR(sv)+1))
3122             return FALSE;
3123         e = (U8 *) SvEND(sv);
3124         while (c < e) {
3125             U8 ch = *c++;
3126             if (!UTF8_IS_INVARIANT(ch)) {
3127                 SvUTF8_on(sv);
3128                 break;
3129             }
3130         }
3131     }
3132     return TRUE;
3133 }
3134
3135
3136 /* Note: sv_setsv() should not be called with a source string that needs
3137  * to be reused, since it may destroy the source string if it is marked
3138  * as temporary.
3139  */
3140
3141 /*
3142 =for apidoc sv_setsv
3143
3144 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3145 The source SV may be destroyed if it is mortal.  Does not handle 'set'
3146 magic.  See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3147 C<sv_setsv_mg>.
3148
3149 =cut
3150 */
3151
3152 void
3153 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3154 {
3155     register U32 sflags;
3156     register int dtype;
3157     register int stype;
3158
3159     if (sstr == dstr)
3160         return;
3161     SV_CHECK_THINKFIRST(dstr);
3162     if (!sstr)
3163         sstr = &PL_sv_undef;
3164     stype = SvTYPE(sstr);
3165     dtype = SvTYPE(dstr);
3166
3167     SvAMAGIC_off(dstr);
3168
3169     /* There's a lot of redundancy below but we're going for speed here */
3170
3171     switch (stype) {
3172     case SVt_NULL:
3173       undef_sstr:
3174         if (dtype != SVt_PVGV) {
3175             (void)SvOK_off(dstr);
3176             return;
3177         }
3178         break;
3179     case SVt_IV:
3180         if (SvIOK(sstr)) {
3181             switch (dtype) {
3182             case SVt_NULL:
3183                 sv_upgrade(dstr, SVt_IV);
3184                 break;
3185             case SVt_NV:
3186                 sv_upgrade(dstr, SVt_PVNV);
3187                 break;
3188             case SVt_RV:
3189             case SVt_PV:
3190                 sv_upgrade(dstr, SVt_PVIV);
3191                 break;
3192             }
3193             (void)SvIOK_only(dstr);
3194             SvIVX(dstr) = SvIVX(sstr);
3195             if (SvIsUV(sstr))
3196                 SvIsUV_on(dstr);
3197             if (SvTAINTED(sstr))
3198                 SvTAINT(dstr);
3199             return;
3200         }
3201         goto undef_sstr;
3202
3203     case SVt_NV:
3204         if (SvNOK(sstr)) {
3205             switch (dtype) {
3206             case SVt_NULL:
3207             case SVt_IV:
3208                 sv_upgrade(dstr, SVt_NV);
3209                 break;
3210             case SVt_RV:
3211             case SVt_PV:
3212             case SVt_PVIV:
3213                 sv_upgrade(dstr, SVt_PVNV);
3214                 break;
3215             }
3216             SvNVX(dstr) = SvNVX(sstr);
3217             (void)SvNOK_only(dstr);
3218             if (SvTAINTED(sstr))
3219                 SvTAINT(dstr);
3220             return;
3221         }
3222         goto undef_sstr;
3223
3224     case SVt_RV:
3225         if (dtype < SVt_RV)
3226             sv_upgrade(dstr, SVt_RV);
3227         else if (dtype == SVt_PVGV &&
3228                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3229             sstr = SvRV(sstr);
3230             if (sstr == dstr) {
3231                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3232                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3233                 {
3234                     GvIMPORTED_on(dstr);
3235                 }
3236                 GvMULTI_on(dstr);
3237                 return;
3238             }
3239             goto glob_assign;
3240         }
3241         break;
3242     case SVt_PV:
3243     case SVt_PVFM:
3244         if (dtype < SVt_PV)
3245             sv_upgrade(dstr, SVt_PV);
3246         break;
3247     case SVt_PVIV:
3248         if (dtype < SVt_PVIV)
3249             sv_upgrade(dstr, SVt_PVIV);
3250         break;
3251     case SVt_PVNV:
3252         if (dtype < SVt_PVNV)
3253             sv_upgrade(dstr, SVt_PVNV);
3254         break;
3255     case SVt_PVAV:
3256     case SVt_PVHV:
3257     case SVt_PVCV:
3258     case SVt_PVIO:
3259         if (PL_op)
3260             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3261                 PL_op_name[PL_op->op_type]);
3262         else
3263             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3264         break;
3265
3266     case SVt_PVGV:
3267         if (dtype <= SVt_PVGV) {
3268   glob_assign:
3269             if (dtype != SVt_PVGV) {
3270                 char *name = GvNAME(sstr);
3271                 STRLEN len = GvNAMELEN(sstr);
3272                 sv_upgrade(dstr, SVt_PVGV);
3273                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3274                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3275                 GvNAME(dstr) = savepvn(name, len);
3276                 GvNAMELEN(dstr) = len;
3277                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3278             }
3279             /* ahem, death to those who redefine active sort subs */
3280             else if (PL_curstackinfo->si_type == PERLSI_SORT
3281                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3282                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3283                       GvNAME(dstr));
3284
3285 #ifdef GV_SHARED_CHECK
3286                 if (GvSHARED((GV*)dstr)) {
3287                     Perl_croak(aTHX_ PL_no_modify);
3288                 }
3289 #endif
3290
3291             (void)SvOK_off(dstr);
3292             GvINTRO_off(dstr);          /* one-shot flag */
3293             gp_free((GV*)dstr);
3294             GvGP(dstr) = gp_ref(GvGP(sstr));
3295             if (SvTAINTED(sstr))
3296                 SvTAINT(dstr);
3297             if (GvIMPORTED(dstr) != GVf_IMPORTED
3298                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3299             {
3300                 GvIMPORTED_on(dstr);
3301             }
3302             GvMULTI_on(dstr);
3303             return;
3304         }
3305         /* FALL THROUGH */
3306
3307     default:
3308         if (SvGMAGICAL(sstr)) {
3309             mg_get(sstr);
3310             if (SvTYPE(sstr) != stype) {
3311                 stype = SvTYPE(sstr);
3312                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3313                     goto glob_assign;
3314             }
3315         }
3316         if (stype == SVt_PVLV)
3317             (void)SvUPGRADE(dstr, SVt_PVNV);
3318         else
3319             (void)SvUPGRADE(dstr, stype);
3320     }
3321
3322     sflags = SvFLAGS(sstr);
3323
3324     if (sflags & SVf_ROK) {
3325         if (dtype >= SVt_PV) {
3326             if (dtype == SVt_PVGV) {
3327                 SV *sref = SvREFCNT_inc(SvRV(sstr));
3328                 SV *dref = 0;
3329                 int intro = GvINTRO(dstr);
3330
3331 #ifdef GV_SHARED_CHECK
3332                 if (GvSHARED((GV*)dstr)) {
3333                     Perl_croak(aTHX_ PL_no_modify);
3334                 }
3335 #endif
3336
3337                 if (intro) {
3338                     GP *gp;
3339                     gp_free((GV*)dstr);
3340                     GvINTRO_off(dstr);  /* one-shot flag */
3341                     Newz(602,gp, 1, GP);
3342                     GvGP(dstr) = gp_ref(gp);
3343                     GvSV(dstr) = NEWSV(72,0);
3344                     GvLINE(dstr) = CopLINE(PL_curcop);
3345                     GvEGV(dstr) = (GV*)dstr;
3346                 }
3347                 GvMULTI_on(dstr);
3348                 switch (SvTYPE(sref)) {
3349                 case SVt_PVAV:
3350                     if (intro)
3351                         SAVESPTR(GvAV(dstr));
3352                     else
3353                         dref = (SV*)GvAV(dstr);
3354                     GvAV(dstr) = (AV*)sref;
3355                     if (!GvIMPORTED_AV(dstr)
3356                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3357                     {
3358                         GvIMPORTED_AV_on(dstr);
3359                     }
3360                     break;
3361                 case SVt_PVHV:
3362                     if (intro)
3363                         SAVESPTR(GvHV(dstr));
3364                     else
3365                         dref = (SV*)GvHV(dstr);
3366                     GvHV(dstr) = (HV*)sref;
3367                     if (!GvIMPORTED_HV(dstr)
3368                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3369                     {
3370                         GvIMPORTED_HV_on(dstr);
3371                     }
3372                     break;
3373                 case SVt_PVCV:
3374                     if (intro) {
3375                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3376                             SvREFCNT_dec(GvCV(dstr));
3377                             GvCV(dstr) = Nullcv;
3378                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3379                             PL_sub_generation++;
3380                         }
3381                         SAVESPTR(GvCV(dstr));
3382                     }
3383                     else
3384                         dref = (SV*)GvCV(dstr);
3385                     if (GvCV(dstr) != (CV*)sref) {
3386                         CV* cv = GvCV(dstr);
3387                         if (cv) {
3388                             if (!GvCVGEN((GV*)dstr) &&
3389                                 (CvROOT(cv) || CvXSUB(cv)))
3390                             {
3391                                 /* ahem, death to those who redefine
3392                                  * active sort subs */
3393                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3394                                       PL_sortcop == CvSTART(cv))
3395                                     Perl_croak(aTHX_
3396                                     "Can't redefine active sort subroutine %s",
3397                                           GvENAME((GV*)dstr));
3398                                 /* Redefining a sub - warning is mandatory if
3399                                    it was a const and its value changed. */
3400                                 if (ckWARN(WARN_REDEFINE)
3401                                     || (CvCONST(cv)
3402                                         && (!CvCONST((CV*)sref)
3403                                             || sv_cmp(cv_const_sv(cv),
3404                                                       cv_const_sv((CV*)sref)))))
3405                                 {
3406                                     Perl_warner(aTHX_ WARN_REDEFINE,
3407                                         CvCONST(cv)
3408                                         ? "Constant subroutine %s redefined"
3409                                         : "Subroutine %s redefined",
3410                                         GvENAME((GV*)dstr));
3411                                 }
3412                             }
3413                             cv_ckproto(cv, (GV*)dstr,
3414                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
3415                         }
3416                         GvCV(dstr) = (CV*)sref;
3417                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3418                         GvASSUMECV_on(dstr);
3419                         PL_sub_generation++;
3420                     }
3421                     if (!GvIMPORTED_CV(dstr)
3422                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3423                     {
3424                         GvIMPORTED_CV_on(dstr);
3425                     }
3426                     break;
3427                 case SVt_PVIO:
3428                     if (intro)
3429                         SAVESPTR(GvIOp(dstr));
3430                     else
3431                         dref = (SV*)GvIOp(dstr);
3432                     GvIOp(dstr) = (IO*)sref;
3433                     break;
3434                 case SVt_PVFM:
3435                     if (intro)
3436                         SAVESPTR(GvFORM(dstr));
3437                     else
3438                         dref = (SV*)GvFORM(dstr);
3439                     GvFORM(dstr) = (CV*)sref;
3440                     break;
3441                 default:
3442                     if (intro)
3443                         SAVESPTR(GvSV(dstr));
3444                     else
3445                         dref = (SV*)GvSV(dstr);
3446                     GvSV(dstr) = sref;
3447                     if (!GvIMPORTED_SV(dstr)
3448                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3449                     {
3450                         GvIMPORTED_SV_on(dstr);
3451                     }
3452                     break;
3453                 }
3454                 if (dref)
3455                     SvREFCNT_dec(dref);
3456                 if (intro)
3457                     SAVEFREESV(sref);
3458                 if (SvTAINTED(sstr))
3459                     SvTAINT(dstr);
3460                 return;
3461             }
3462             if (SvPVX(dstr)) {
3463                 (void)SvOOK_off(dstr);          /* backoff */
3464                 if (SvLEN(dstr))
3465                     Safefree(SvPVX(dstr));
3466                 SvLEN(dstr)=SvCUR(dstr)=0;
3467             }
3468         }
3469         (void)SvOK_off(dstr);
3470         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3471         SvROK_on(dstr);
3472         if (sflags & SVp_NOK) {
3473             SvNOKp_on(dstr);
3474             /* Only set the public OK flag if the source has public OK.  */
3475             if (sflags & SVf_NOK)
3476                 SvFLAGS(dstr) |= SVf_NOK;
3477             SvNVX(dstr) = SvNVX(sstr);
3478         }
3479         if (sflags & SVp_IOK) {
3480             (void)SvIOKp_on(dstr);
3481             if (sflags & SVf_IOK)
3482                 SvFLAGS(dstr) |= SVf_IOK;
3483             if (sflags & SVf_IVisUV)
3484                 SvIsUV_on(dstr);
3485             SvIVX(dstr) = SvIVX(sstr);
3486         }
3487         if (SvAMAGIC(sstr)) {
3488             SvAMAGIC_on(dstr);
3489         }
3490     }
3491     else if (sflags & SVp_POK) {
3492
3493         /*
3494          * Check to see if we can just swipe the string.  If so, it's a
3495          * possible small lose on short strings, but a big win on long ones.
3496          * It might even be a win on short strings if SvPVX(dstr)
3497          * has to be allocated and SvPVX(sstr) has to be freed.
3498          */
3499
3500         if (SvTEMP(sstr) &&             /* slated for free anyway? */
3501             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
3502             !(sflags & SVf_OOK) &&      /* and not involved in OOK hack? */
3503             SvLEN(sstr)         &&      /* and really is a string */
3504             !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3505         {
3506             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
3507                 if (SvOOK(dstr)) {
3508                     SvFLAGS(dstr) &= ~SVf_OOK;
3509                     Safefree(SvPVX(dstr) - SvIVX(dstr));
3510                 }
3511                 else if (SvLEN(dstr))
3512                     Safefree(SvPVX(dstr));
3513             }
3514             (void)SvPOK_only(dstr);
3515             SvPV_set(dstr, SvPVX(sstr));
3516             SvLEN_set(dstr, SvLEN(sstr));
3517             SvCUR_set(dstr, SvCUR(sstr));
3518
3519             SvTEMP_off(dstr);
3520             (void)SvOK_off(sstr);               /* NOTE: nukes most SvFLAGS on sstr */
3521             SvPV_set(sstr, Nullch);
3522             SvLEN_set(sstr, 0);
3523             SvCUR_set(sstr, 0);
3524             SvTEMP_off(sstr);
3525         }
3526         else {                                  /* have to copy actual string */
3527             STRLEN len = SvCUR(sstr);
3528
3529             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
3530             Move(SvPVX(sstr),SvPVX(dstr),len,char);
3531             SvCUR_set(dstr, len);
3532             *SvEND(dstr) = '\0';
3533             (void)SvPOK_only(dstr);
3534         }
3535         if (sflags & SVf_UTF8)
3536             SvUTF8_on(dstr);
3537         /*SUPPRESS 560*/
3538         if (sflags & SVp_NOK) {
3539             SvNOKp_on(dstr);
3540             if (sflags & SVf_NOK)
3541                 SvFLAGS(dstr) |= SVf_NOK;
3542             SvNVX(dstr) = SvNVX(sstr);
3543         }
3544         if (sflags & SVp_IOK) {
3545             (void)SvIOKp_on(dstr);
3546             if (sflags & SVf_IOK)
3547                 SvFLAGS(dstr) |= SVf_IOK;
3548             if (sflags & SVf_IVisUV)
3549                 SvIsUV_on(dstr);
3550             SvIVX(dstr) = SvIVX(sstr);
3551         }
3552     }
3553     else if (sflags & SVp_IOK) {
3554         if (sflags & SVf_IOK)
3555             (void)SvIOK_only(dstr);
3556         else {
3557             (void)SvOK_off(dstr);
3558             (void)SvIOKp_on(dstr);
3559         }
3560         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3561         if (sflags & SVf_IVisUV)
3562             SvIsUV_on(dstr);
3563         SvIVX(dstr) = SvIVX(sstr);
3564         if (sflags & SVp_NOK) {
3565             if (sflags & SVf_NOK)
3566                 (void)SvNOK_on(dstr);
3567             else
3568                 (void)SvNOKp_on(dstr);
3569             SvNVX(dstr) = SvNVX(sstr);
3570         }
3571     }
3572     else if (sflags & SVp_NOK) {
3573         if (sflags & SVf_NOK)
3574             (void)SvNOK_only(dstr);
3575         else {
3576             (void)SvOK_off(dstr);
3577             SvNOKp_on(dstr);
3578         }
3579         SvNVX(dstr) = SvNVX(sstr);
3580     }
3581     else {
3582         if (dtype == SVt_PVGV) {
3583             if (ckWARN(WARN_MISC))
3584                 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3585         }
3586         else
3587             (void)SvOK_off(dstr);
3588     }
3589     if (SvTAINTED(sstr))
3590         SvTAINT(dstr);
3591 }
3592
3593 /*
3594 =for apidoc sv_setsv_mg
3595
3596 Like C<sv_setsv>, but also handles 'set' magic.
3597
3598 =cut
3599 */
3600
3601 void
3602 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3603 {
3604     sv_setsv(dstr,sstr);
3605     SvSETMAGIC(dstr);
3606 }
3607
3608 /*
3609 =for apidoc sv_setpvn
3610
3611 Copies a string into an SV.  The C<len> parameter indicates the number of
3612 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
3613
3614 =cut
3615 */
3616
3617 void
3618 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3619 {
3620     register char *dptr;
3621
3622     SV_CHECK_THINKFIRST(sv);
3623     if (!ptr) {
3624         (void)SvOK_off(sv);
3625         return;
3626     }
3627     else {
3628         /* len is STRLEN which is unsigned, need to copy to signed */
3629         IV iv = len;
3630         assert(iv >= 0);
3631     }
3632     (void)SvUPGRADE(sv, SVt_PV);
3633
3634     SvGROW(sv, len + 1);
3635     dptr = SvPVX(sv);
3636     Move(ptr,dptr,len,char);
3637     dptr[len] = '\0';
3638     SvCUR_set(sv, len);
3639     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3640     SvTAINT(sv);
3641 }
3642
3643 /*
3644 =for apidoc sv_setpvn_mg
3645
3646 Like C<sv_setpvn>, but also handles 'set' magic.
3647
3648 =cut
3649 */
3650
3651 void
3652 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3653 {
3654     sv_setpvn(sv,ptr,len);
3655     SvSETMAGIC(sv);
3656 }
3657
3658 /*
3659 =for apidoc sv_setpv
3660
3661 Copies a string into an SV.  The string must be null-terminated.  Does not
3662 handle 'set' magic.  See C<sv_setpv_mg>.
3663
3664 =cut
3665 */
3666
3667 void
3668 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3669 {
3670     register STRLEN len;
3671
3672     SV_CHECK_THINKFIRST(sv);
3673     if (!ptr) {
3674         (void)SvOK_off(sv);
3675         return;
3676     }
3677     len = strlen(ptr);
3678     (void)SvUPGRADE(sv, SVt_PV);
3679
3680     SvGROW(sv, len + 1);
3681     Move(ptr,SvPVX(sv),len+1,char);
3682     SvCUR_set(sv, len);
3683     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3684     SvTAINT(sv);
3685 }
3686
3687 /*
3688 =for apidoc sv_setpv_mg
3689
3690 Like C<sv_setpv>, but also handles 'set' magic.
3691
3692 =cut
3693 */
3694
3695 void
3696 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3697 {
3698     sv_setpv(sv,ptr);
3699     SvSETMAGIC(sv);
3700 }
3701
3702 /*
3703 =for apidoc sv_usepvn
3704
3705 Tells an SV to use C<ptr> to find its string value.  Normally the string is
3706 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3707 The C<ptr> should point to memory that was allocated by C<malloc>.  The
3708 string length, C<len>, must be supplied.  This function will realloc the
3709 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3710 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
3711 See C<sv_usepvn_mg>.
3712
3713 =cut
3714 */
3715
3716 void
3717 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3718 {
3719     SV_CHECK_THINKFIRST(sv);
3720     (void)SvUPGRADE(sv, SVt_PV);
3721     if (!ptr) {
3722         (void)SvOK_off(sv);
3723         return;
3724     }
3725     (void)SvOOK_off(sv);
3726     if (SvPVX(sv) && SvLEN(sv))
3727         Safefree(SvPVX(sv));
3728     Renew(ptr, len+1, char);
3729     SvPVX(sv) = ptr;
3730     SvCUR_set(sv, len);
3731     SvLEN_set(sv, len+1);
3732     *SvEND(sv) = '\0';
3733     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3734     SvTAINT(sv);
3735 }
3736
3737 /*
3738 =for apidoc sv_usepvn_mg
3739
3740 Like C<sv_usepvn>, but also handles 'set' magic.
3741
3742 =cut
3743 */
3744
3745 void
3746 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3747 {
3748     sv_usepvn(sv,ptr,len);
3749     SvSETMAGIC(sv);
3750 }
3751
3752 void
3753 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3754 {
3755     if (SvREADONLY(sv)) {
3756         if (SvFAKE(sv)) {
3757             char *pvx = SvPVX(sv);
3758             STRLEN len = SvCUR(sv);
3759             U32 hash   = SvUVX(sv);
3760             SvGROW(sv, len + 1);
3761             Move(pvx,SvPVX(sv),len,char);
3762             *SvEND(sv) = '\0';
3763             SvFAKE_off(sv);
3764             SvREADONLY_off(sv);
3765             unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3766         }
3767         else if (PL_curcop != &PL_compiling)
3768             Perl_croak(aTHX_ PL_no_modify);
3769     }
3770     if (SvROK(sv))
3771         sv_unref_flags(sv, flags);
3772     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3773         sv_unglob(sv);
3774 }
3775
3776 void
3777 Perl_sv_force_normal(pTHX_ register SV *sv)
3778 {
3779     sv_force_normal_flags(sv, 0);
3780 }
3781
3782 /*
3783 =for apidoc sv_chop
3784
3785 Efficient removal of characters from the beginning of the string buffer.
3786 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3787 the string buffer.  The C<ptr> becomes the first character of the adjusted
3788 string.
3789
3790 =cut
3791 */
3792
3793 void
3794 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3795
3796
3797 {
3798     register STRLEN delta;
3799
3800     if (!ptr || !SvPOKp(sv))
3801         return;
3802     SV_CHECK_THINKFIRST(sv);
3803     if (SvTYPE(sv) < SVt_PVIV)
3804         sv_upgrade(sv,SVt_PVIV);
3805
3806     if (!SvOOK(sv)) {
3807         if (!SvLEN(sv)) { /* make copy of shared string */
3808             char *pvx = SvPVX(sv);
3809             STRLEN len = SvCUR(sv);
3810             SvGROW(sv, len + 1);
3811             Move(pvx,SvPVX(sv),len,char);
3812             *SvEND(sv) = '\0';
3813         }
3814         SvIVX(sv) = 0;
3815         SvFLAGS(sv) |= SVf_OOK;
3816     }
3817     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3818     delta = ptr - SvPVX(sv);
3819     SvLEN(sv) -= delta;
3820     SvCUR(sv) -= delta;
3821     SvPVX(sv) += delta;
3822     SvIVX(sv) += delta;
3823 }
3824
3825 /*
3826 =for apidoc sv_catpvn
3827
3828 Concatenates the string onto the end of the string which is in the SV.  The
3829 C<len> indicates number of bytes to copy.  If the SV has the UTF8
3830 status set, then the bytes appended should be valid UTF8.
3831 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
3832
3833 =cut
3834 */
3835
3836 void
3837 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3838 {
3839     STRLEN tlen;
3840     char *junk;
3841
3842     junk = SvPV_force(sv, tlen);
3843     SvGROW(sv, tlen + len + 1);
3844     if (ptr == junk)
3845         ptr = SvPVX(sv);
3846     Move(ptr,SvPVX(sv)+tlen,len,char);
3847     SvCUR(sv) += len;
3848     *SvEND(sv) = '\0';
3849     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3850     SvTAINT(sv);
3851 }
3852
3853 /*
3854 =for apidoc sv_catpvn_mg
3855
3856 Like C<sv_catpvn>, but also handles 'set' magic.
3857
3858 =cut
3859 */
3860
3861 void
3862 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3863 {
3864     sv_catpvn(sv,ptr,len);
3865     SvSETMAGIC(sv);
3866 }
3867
3868 /*
3869 =for apidoc sv_catsv
3870
3871 Concatenates the string from SV C<ssv> onto the end of the string in
3872 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
3873 not 'set' magic.  See C<sv_catsv_mg>.
3874
3875 =cut */
3876
3877 void
3878 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3879 {
3880     char *spv;
3881     STRLEN slen;
3882     if (!ssv)
3883         return;
3884     if ((spv = SvPV(ssv, slen))) {
3885         bool dutf8 = DO_UTF8(dsv);
3886         bool sutf8 = DO_UTF8(ssv);
3887
3888         if (dutf8 == sutf8)
3889             sv_catpvn(dsv,spv,slen);
3890         else {
3891             if (dutf8) {
3892                 /* Not modifying source SV, so taking a temporary copy. */
3893                 SV* csv = sv_2mortal(newSVsv(ssv));
3894                 char *cpv;
3895                 STRLEN clen;
3896
3897                 sv_utf8_upgrade(csv);
3898                 cpv = SvPV(csv,clen);
3899                 sv_catpvn(dsv,cpv,clen);
3900             }
3901             else {
3902                 sv_utf8_upgrade(dsv);
3903                 sv_catpvn(dsv,spv,slen);
3904                 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3905             }
3906         }
3907     }
3908 }
3909
3910 /*
3911 =for apidoc sv_catsv_mg
3912
3913 Like C<sv_catsv>, but also handles 'set' magic.
3914
3915 =cut
3916 */
3917
3918 void
3919 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3920 {
3921     sv_catsv(dsv,ssv);
3922     SvSETMAGIC(dsv);
3923 }
3924
3925 /*
3926 =for apidoc sv_catpv
3927
3928 Concatenates the string onto the end of the string which is in the SV.
3929 If the SV has the UTF8 status set, then the bytes appended should be
3930 valid UTF8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
3931
3932 =cut */
3933
3934 void
3935 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3936 {
3937     register STRLEN len;
3938     STRLEN tlen;
3939     char *junk;
3940
3941     if (!ptr)
3942         return;
3943     junk = SvPV_force(sv, tlen);
3944     len = strlen(ptr);
3945     SvGROW(sv, tlen + len + 1);
3946     if (ptr == junk)
3947         ptr = SvPVX(sv);
3948     Move(ptr,SvPVX(sv)+tlen,len+1,char);
3949     SvCUR(sv) += len;
3950     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3951     SvTAINT(sv);
3952 }
3953
3954 /*
3955 =for apidoc sv_catpv_mg
3956
3957 Like C<sv_catpv>, but also handles 'set' magic.
3958
3959 =cut
3960 */
3961
3962 void
3963 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3964 {
3965     sv_catpv(sv,ptr);
3966     SvSETMAGIC(sv);
3967 }
3968
3969 SV *
3970 Perl_newSV(pTHX_ STRLEN len)
3971 {
3972     register SV *sv;
3973
3974     new_SV(sv);
3975     if (len) {
3976         sv_upgrade(sv, SVt_PV);
3977         SvGROW(sv, len + 1);
3978     }
3979     return sv;
3980 }
3981
3982 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3983
3984 /*
3985 =for apidoc sv_magic
3986
3987 Adds magic to an SV.
3988
3989 =cut
3990 */
3991
3992 void
3993 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3994 {
3995     MAGIC* mg;
3996
3997     if (SvREADONLY(sv)) {
3998         if (PL_curcop != &PL_compiling
3999             /* XXX this used to be !strchr("gBf", how), which seems to
4000              * implicity be equal to !strchr("gBf\0", how), ie \0 matches
4001              * too. I find this suprising, but have hadded PERL_MAGIC_sv
4002              * to the list of things to check - DAPM 19-May-01 */
4003             && how != PERL_MAGIC_regex_global
4004             && how != PERL_MAGIC_bm
4005             && how != PERL_MAGIC_fm
4006             && how != PERL_MAGIC_sv
4007            )
4008         {
4009             Perl_croak(aTHX_ PL_no_modify);
4010         }
4011     }
4012     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4013         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4014             if (how == PERL_MAGIC_taint)
4015                 mg->mg_len |= 1;
4016             return;
4017         }
4018     }
4019     else {
4020         (void)SvUPGRADE(sv, SVt_PVMG);
4021     }
4022     Newz(702,mg, 1, MAGIC);
4023     mg->mg_moremagic = SvMAGIC(sv);
4024     SvMAGIC(sv) = mg;
4025
4026     /* Some magic sontains a reference loop, where the sv and object refer to
4027        each other.  To prevent a avoid a reference loop that would prevent such
4028        objects being freed, we look for such loops and if we find one we avoid
4029        incrementing the object refcount. */
4030     if (!obj || obj == sv ||
4031         how == PERL_MAGIC_arylen ||
4032         how == PERL_MAGIC_qr ||
4033         (SvTYPE(obj) == SVt_PVGV &&
4034             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4035             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4036             GvFORM(obj) == (CV*)sv)))
4037     {
4038         mg->mg_obj = obj;
4039     }
4040     else {
4041         mg->mg_obj = SvREFCNT_inc(obj);
4042         mg->mg_flags |= MGf_REFCOUNTED;
4043     }
4044     mg->mg_type = how;
4045     mg->mg_len = namlen;
4046     if (name) {
4047         if (namlen >= 0)
4048             mg->mg_ptr = savepvn(name, namlen);
4049         else if (namlen == HEf_SVKEY)
4050             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4051     }
4052
4053     switch (how) {
4054     case PERL_MAGIC_sv:
4055         mg->mg_virtual = &PL_vtbl_sv;
4056         break;
4057     case PERL_MAGIC_overload:
4058         mg->mg_virtual = &PL_vtbl_amagic;
4059         break;
4060     case PERL_MAGIC_overload_elem:
4061         mg->mg_virtual = &PL_vtbl_amagicelem;
4062         break;
4063     case PERL_MAGIC_overload_table:
4064         mg->mg_virtual = &PL_vtbl_ovrld;
4065         break;
4066     case PERL_MAGIC_bm:
4067         mg->mg_virtual = &PL_vtbl_bm;
4068         break;
4069     case PERL_MAGIC_regdata:
4070         mg->mg_virtual = &PL_vtbl_regdata;
4071         break;
4072     case PERL_MAGIC_regdatum:
4073         mg->mg_virtual = &PL_vtbl_regdatum;
4074         break;
4075     case PERL_MAGIC_env:
4076         mg->mg_virtual = &PL_vtbl_env;
4077         break;
4078     case PERL_MAGIC_fm:
4079         mg->mg_virtual = &PL_vtbl_fm;
4080         break;
4081     case PERL_MAGIC_envelem:
4082         mg->mg_virtual = &PL_vtbl_envelem;
4083         break;
4084     case PERL_MAGIC_regex_global:
4085         mg->mg_virtual = &PL_vtbl_mglob;
4086         break;
4087     case PERL_MAGIC_isa:
4088         mg->mg_virtual = &PL_vtbl_isa;
4089         break;
4090     case PERL_MAGIC_isaelem:
4091         mg->mg_virtual = &PL_vtbl_isaelem;
4092         break;
4093     case PERL_MAGIC_nkeys:
4094         mg->mg_virtual = &PL_vtbl_nkeys;
4095         break;
4096     case PERL_MAGIC_dbfile:
4097         SvRMAGICAL_on(sv);
4098         mg->mg_virtual = 0;
4099         break;
4100     case PERL_MAGIC_dbline:
4101         mg->mg_virtual = &PL_vtbl_dbline;
4102         break;
4103 #ifdef USE_THREADS
4104     case PERL_MAGIC_mutex:
4105         mg->mg_virtual = &PL_vtbl_mutex;
4106         break;
4107 #endif /* USE_THREADS */
4108 #ifdef USE_LOCALE_COLLATE
4109     case PERL_MAGIC_collxfrm:
4110         mg->mg_virtual = &PL_vtbl_collxfrm;
4111         break;
4112 #endif /* USE_LOCALE_COLLATE */
4113     case PERL_MAGIC_tied:
4114         mg->mg_virtual = &PL_vtbl_pack;
4115         break;
4116     case PERL_MAGIC_tiedelem:
4117     case PERL_MAGIC_tiedscalar:
4118         mg->mg_virtual = &PL_vtbl_packelem;
4119         break;
4120     case PERL_MAGIC_qr:
4121         mg->mg_virtual = &PL_vtbl_regexp;
4122         break;
4123     case PERL_MAGIC_sig:
4124         mg->mg_virtual = &PL_vtbl_sig;
4125         break;
4126     case PERL_MAGIC_sigelem:
4127         mg->mg_virtual = &PL_vtbl_sigelem;
4128         break;
4129     case PERL_MAGIC_taint:
4130         mg->mg_virtual = &PL_vtbl_taint;
4131         mg->mg_len = 1;
4132         break;
4133     case PERL_MAGIC_uvar:
4134         mg->mg_virtual = &PL_vtbl_uvar;
4135         break;
4136     case PERL_MAGIC_vec:
4137         mg->mg_virtual = &PL_vtbl_vec;
4138         break;
4139     case PERL_MAGIC_substr:
4140         mg->mg_virtual = &PL_vtbl_substr;
4141         break;
4142     case PERL_MAGIC_defelem:
4143         mg->mg_virtual = &PL_vtbl_defelem;
4144         break;
4145     case PERL_MAGIC_glob:
4146         mg->mg_virtual = &PL_vtbl_glob;
4147         break;
4148     case PERL_MAGIC_arylen:
4149         mg->mg_virtual = &PL_vtbl_arylen;
4150         break;
4151     case PERL_MAGIC_pos:
4152         mg->mg_virtual = &PL_vtbl_pos;
4153         break;
4154     case PERL_MAGIC_backref:
4155         mg->mg_virtual = &PL_vtbl_backref;
4156         break;
4157     case PERL_MAGIC_ext:
4158         /* Reserved for use by extensions not perl internals.           */
4159         /* Useful for attaching extension internal data to perl vars.   */
4160         /* Note that multiple extensions may clash if magical scalars   */
4161         /* etc holding private data from one are passed to another.     */
4162         SvRMAGICAL_on(sv);
4163         break;
4164     default:
4165         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4166     }
4167     mg_magical(sv);
4168     if (SvGMAGICAL(sv))
4169         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4170 }
4171
4172 /*
4173 =for apidoc sv_unmagic
4174
4175 Removes magic from an SV.
4176
4177 =cut
4178 */
4179
4180 int
4181 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4182 {
4183     MAGIC* mg;
4184     MAGIC** mgp;
4185     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4186         return 0;
4187     mgp = &SvMAGIC(sv);
4188     for (mg = *mgp; mg; mg = *mgp) {
4189         if (mg->mg_type == type) {
4190             MGVTBL* vtbl = mg->mg_virtual;
4191             *mgp = mg->mg_moremagic;
4192             if (vtbl && vtbl->svt_free)
4193                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4194             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4195                 if (mg->mg_len >= 0)
4196                     Safefree(mg->mg_ptr);
4197                 else if (mg->mg_len == HEf_SVKEY)
4198                     SvREFCNT_dec((SV*)mg->mg_ptr);
4199             }
4200             if (mg->mg_flags & MGf_REFCOUNTED)
4201                 SvREFCNT_dec(mg->mg_obj);
4202             Safefree(mg);
4203         }
4204         else
4205             mgp = &mg->mg_moremagic;
4206     }
4207     if (!SvMAGIC(sv)) {
4208         SvMAGICAL_off(sv);
4209         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4210     }
4211
4212     return 0;
4213 }
4214
4215 /*
4216 =for apidoc sv_rvweaken
4217
4218 Weaken a reference.
4219
4220 =cut
4221 */
4222
4223 SV *
4224 Perl_sv_rvweaken(pTHX_ SV *sv)
4225 {
4226     SV *tsv;
4227     if (!SvOK(sv))  /* let undefs pass */
4228         return sv;
4229     if (!SvROK(sv))
4230         Perl_croak(aTHX_ "Can't weaken a nonreference");
4231     else if (SvWEAKREF(sv)) {
4232         if (ckWARN(WARN_MISC))
4233             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4234         return sv;
4235     }
4236     tsv = SvRV(sv);
4237     sv_add_backref(tsv, sv);
4238     SvWEAKREF_on(sv);
4239     SvREFCNT_dec(tsv);
4240     return sv;
4241 }
4242
4243 STATIC void
4244 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4245 {
4246     AV *av;
4247     MAGIC *mg;
4248     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4249         av = (AV*)mg->mg_obj;
4250     else {
4251         av = newAV();
4252         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4253         SvREFCNT_dec(av);           /* for sv_magic */
4254     }
4255     av_push(av,sv);
4256 }
4257
4258 STATIC void
4259 S_sv_del_backref(pTHX_ SV *sv)
4260 {
4261     AV *av;
4262     SV **svp;
4263     I32 i;
4264     SV *tsv = SvRV(sv);
4265     MAGIC *mg;
4266     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4267         Perl_croak(aTHX_ "panic: del_backref");
4268     av = (AV *)mg->mg_obj;
4269     svp = AvARRAY(av);
4270     i = AvFILLp(av);
4271     while (i >= 0) {
4272         if (svp[i] == sv) {
4273             svp[i] = &PL_sv_undef; /* XXX */
4274         }
4275         i--;
4276     }
4277 }
4278
4279 /*
4280 =for apidoc sv_insert
4281
4282 Inserts a string at the specified offset/length within the SV. Similar to
4283 the Perl substr() function.
4284
4285 =cut
4286 */
4287
4288 void
4289 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4290 {
4291     register char *big;
4292     register char *mid;
4293     register char *midend;
4294     register char *bigend;
4295     register I32 i;
4296     STRLEN curlen;
4297
4298
4299     if (!bigstr)
4300         Perl_croak(aTHX_ "Can't modify non-existent substring");
4301     SvPV_force(bigstr, curlen);
4302     (void)SvPOK_only_UTF8(bigstr);
4303     if (offset + len > curlen) {
4304         SvGROW(bigstr, offset+len+1);
4305         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4306         SvCUR_set(bigstr, offset+len);
4307     }
4308
4309     SvTAINT(bigstr);
4310     i = littlelen - len;
4311     if (i > 0) {                        /* string might grow */
4312         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4313         mid = big + offset + len;
4314         midend = bigend = big + SvCUR(bigstr);
4315         bigend += i;
4316         *bigend = '\0';
4317         while (midend > mid)            /* shove everything down */
4318             *--bigend = *--midend;
4319         Move(little,big+offset,littlelen,char);
4320         SvCUR(bigstr) += i;
4321         SvSETMAGIC(bigstr);
4322         return;
4323     }
4324     else if (i == 0) {
4325         Move(little,SvPVX(bigstr)+offset,len,char);
4326         SvSETMAGIC(bigstr);
4327         return;
4328     }
4329
4330     big = SvPVX(bigstr);
4331     mid = big + offset;
4332     midend = mid + len;
4333     bigend = big + SvCUR(bigstr);
4334
4335     if (midend > bigend)
4336         Perl_croak(aTHX_ "panic: sv_insert");
4337
4338     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4339         if (littlelen) {
4340             Move(little, mid, littlelen,char);
4341             mid += littlelen;
4342         }
4343         i = bigend - midend;
4344         if (i > 0) {
4345             Move(midend, mid, i,char);
4346             mid += i;
4347         }
4348         *mid = '\0';
4349         SvCUR_set(bigstr, mid - big);
4350     }
4351     /*SUPPRESS 560*/
4352     else if ((i = mid - big)) { /* faster from front */
4353         midend -= littlelen;
4354         mid = midend;
4355         sv_chop(bigstr,midend-i);
4356         big += i;
4357         while (i--)
4358             *--midend = *--big;
4359         if (littlelen)
4360             Move(little, mid, littlelen,char);
4361     }
4362     else if (littlelen) {
4363         midend -= littlelen;
4364         sv_chop(bigstr,midend);
4365         Move(little,midend,littlelen,char);
4366     }
4367     else {
4368         sv_chop(bigstr,midend);
4369     }
4370     SvSETMAGIC(bigstr);
4371 }
4372
4373 /*
4374 =for apidoc sv_replace
4375
4376 Make the first argument a copy of the second, then delete the original.
4377
4378 =cut
4379 */
4380
4381 void
4382 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4383 {
4384     U32 refcnt = SvREFCNT(sv);
4385     SV_CHECK_THINKFIRST(sv);
4386     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4387         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4388     if (SvMAGICAL(sv)) {
4389         if (SvMAGICAL(nsv))
4390             mg_free(nsv);
4391         else
4392             sv_upgrade(nsv, SVt_PVMG);
4393         SvMAGIC(nsv) = SvMAGIC(sv);
4394         SvFLAGS(nsv) |= SvMAGICAL(sv);
4395         SvMAGICAL_off(sv);
4396         SvMAGIC(sv) = 0;
4397     }
4398     SvREFCNT(sv) = 0;
4399     sv_clear(sv);
4400     assert(!SvREFCNT(sv));
4401     StructCopy(nsv,sv,SV);
4402     SvREFCNT(sv) = refcnt;
4403     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
4404     del_SV(nsv);
4405 }
4406
4407 /*
4408 =for apidoc sv_clear
4409
4410 Clear an SV, making it empty. Does not free the memory used by the SV
4411 itself.
4412
4413 =cut
4414 */
4415
4416 void
4417 Perl_sv_clear(pTHX_ register SV *sv)
4418 {
4419     HV* stash;
4420     assert(sv);
4421     assert(SvREFCNT(sv) == 0);
4422
4423     if (SvOBJECT(sv)) {
4424         if (PL_defstash) {              /* Still have a symbol table? */
4425             dSP;
4426             CV* destructor;
4427             SV tmpref;
4428
4429             Zero(&tmpref, 1, SV);
4430             sv_upgrade(&tmpref, SVt_RV);
4431             SvROK_on(&tmpref);
4432             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
4433             SvREFCNT(&tmpref) = 1;
4434
4435             do {
4436                 stash = SvSTASH(sv);
4437                 destructor = StashHANDLER(stash,DESTROY);
4438                 if (destructor) {
4439                     ENTER;
4440                     PUSHSTACKi(PERLSI_DESTROY);
4441                     SvRV(&tmpref) = SvREFCNT_inc(sv);
4442                     EXTEND(SP, 2);
4443                     PUSHMARK(SP);
4444                     PUSHs(&tmpref);
4445                     PUTBACK;
4446                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4447                     SvREFCNT(sv)--;
4448                     POPSTACK;
4449                     SPAGAIN;
4450                     LEAVE;
4451                 }
4452             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4453
4454             del_XRV(SvANY(&tmpref));
4455
4456             if (SvREFCNT(sv)) {
4457                 if (PL_in_clean_objs)
4458                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4459                           HvNAME(stash));
4460                 /* DESTROY gave object new lease on life */
4461                 return;
4462             }
4463         }
4464
4465         if (SvOBJECT(sv)) {
4466             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
4467             SvOBJECT_off(sv);   /* Curse the object. */
4468             if (SvTYPE(sv) != SVt_PVIO)
4469                 --PL_sv_objcount;       /* XXX Might want something more general */
4470         }
4471     }
4472     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4473         mg_free(sv);
4474     stash = NULL;
4475     switch (SvTYPE(sv)) {
4476     case SVt_PVIO:
4477         if (IoIFP(sv) &&
4478             IoIFP(sv) != PerlIO_stdin() &&
4479             IoIFP(sv) != PerlIO_stdout() &&
4480             IoIFP(sv) != PerlIO_stderr())
4481         {
4482             io_close((IO*)sv, FALSE);
4483         }
4484         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4485             PerlDir_close(IoDIRP(sv));
4486         IoDIRP(sv) = (DIR*)NULL;
4487         Safefree(IoTOP_NAME(sv));
4488         Safefree(IoFMT_NAME(sv));
4489         Safefree(IoBOTTOM_NAME(sv));
4490         /* FALL THROUGH */
4491     case SVt_PVBM:
4492         goto freescalar;
4493     case SVt_PVCV:
4494     case SVt_PVFM:
4495         cv_undef((CV*)sv);
4496         goto freescalar;
4497     case SVt_PVHV:
4498         hv_undef((HV*)sv);
4499         break;
4500     case SVt_PVAV:
4501         av_undef((AV*)sv);
4502         break;
4503     case SVt_PVLV:
4504         SvREFCNT_dec(LvTARG(sv));
4505         goto freescalar;
4506     case SVt_PVGV:
4507         gp_free((GV*)sv);
4508         Safefree(GvNAME(sv));
4509         /* cannot decrease stash refcount yet, as we might recursively delete
4510            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4511            of stash until current sv is completely gone.
4512            -- JohnPC, 27 Mar 1998 */
4513         stash = GvSTASH(sv);
4514         /* FALL THROUGH */
4515     case SVt_PVMG:
4516     case SVt_PVNV:
4517     case SVt_PVIV:
4518       freescalar:
4519         (void)SvOOK_off(sv);
4520         /* FALL THROUGH */
4521     case SVt_PV:
4522     case SVt_RV:
4523         if (SvROK(sv)) {
4524             if (SvWEAKREF(sv))
4525                 sv_del_backref(sv);
4526             else
4527                 SvREFCNT_dec(SvRV(sv));
4528         }
4529         else if (SvPVX(sv) && SvLEN(sv))
4530             Safefree(SvPVX(sv));
4531         else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4532             unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4533             SvFAKE_off(sv);
4534         }
4535         break;
4536 /*
4537     case SVt_NV:
4538     case SVt_IV:
4539     case SVt_NULL:
4540         break;
4541 */
4542     }
4543
4544     switch (SvTYPE(sv)) {
4545     case SVt_NULL:
4546         break;
4547     case SVt_IV:
4548         del_XIV(SvANY(sv));
4549         break;
4550     case SVt_NV:
4551         del_XNV(SvANY(sv));
4552         break;
4553     case SVt_RV:
4554         del_XRV(SvANY(sv));
4555         break;
4556     case SVt_PV:
4557         del_XPV(SvANY(sv));
4558         break;
4559     case SVt_PVIV:
4560         del_XPVIV(SvANY(sv));
4561         break;
4562     case SVt_PVNV:
4563         del_XPVNV(SvANY(sv));
4564         break;
4565     case SVt_PVMG:
4566         del_XPVMG(SvANY(sv));
4567         break;
4568     case SVt_PVLV:
4569         del_XPVLV(SvANY(sv));
4570         break;
4571     case SVt_PVAV:
4572         del_XPVAV(SvANY(sv));
4573         break;
4574     case SVt_PVHV:
4575         del_XPVHV(SvANY(sv));
4576         break;
4577     case SVt_PVCV:
4578         del_XPVCV(SvANY(sv));
4579         break;
4580     case SVt_PVGV:
4581         del_XPVGV(SvANY(sv));
4582         /* code duplication for increased performance. */
4583         SvFLAGS(sv) &= SVf_BREAK;
4584         SvFLAGS(sv) |= SVTYPEMASK;
4585         /* decrease refcount of the stash that owns this GV, if any */
4586         if (stash)
4587             SvREFCNT_dec(stash);
4588         return; /* not break, SvFLAGS reset already happened */
4589     case SVt_PVBM:
4590         del_XPVBM(SvANY(sv));
4591         break;
4592     case SVt_PVFM:
4593         del_XPVFM(SvANY(sv));
4594         break;
4595     case SVt_PVIO:
4596         del_XPVIO(SvANY(sv));
4597         break;
4598     }
4599     SvFLAGS(sv) &= SVf_BREAK;
4600     SvFLAGS(sv) |= SVTYPEMASK;
4601 }
4602
4603 SV *
4604 Perl_sv_newref(pTHX_ SV *sv)
4605 {
4606     if (sv)
4607         ATOMIC_INC(SvREFCNT(sv));
4608     return sv;
4609 }
4610
4611 /*
4612 =for apidoc sv_free
4613
4614 Free the memory used by an SV.
4615
4616 =cut
4617 */
4618
4619 void
4620 Perl_sv_free(pTHX_ SV *sv)
4621 {
4622     int refcount_is_zero;
4623
4624     if (!sv)
4625         return;
4626     if (SvREFCNT(sv) == 0) {
4627         if (SvFLAGS(sv) & SVf_BREAK)
4628             return;
4629         if (PL_in_clean_all) /* All is fair */
4630             return;
4631         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4632             /* make sure SvREFCNT(sv)==0 happens very seldom */
4633             SvREFCNT(sv) = (~(U32)0)/2;
4634             return;
4635         }
4636         if (ckWARN_d(WARN_INTERNAL))
4637             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4638         return;
4639     }
4640     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4641     if (!refcount_is_zero)
4642         return;
4643 #ifdef DEBUGGING
4644     if (SvTEMP(sv)) {
4645         if (ckWARN_d(WARN_DEBUGGING))
4646             Perl_warner(aTHX_ WARN_DEBUGGING,
4647                         "Attempt to free temp prematurely: SV 0x%"UVxf,
4648                         PTR2UV(sv));
4649         return;
4650     }
4651 #endif
4652     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4653         /* make sure SvREFCNT(sv)==0 happens very seldom */
4654         SvREFCNT(sv) = (~(U32)0)/2;
4655         return;
4656     }
4657     sv_clear(sv);
4658     if (! SvREFCNT(sv))
4659         del_SV(sv);
4660 }
4661
4662 /*
4663 =for apidoc sv_len
4664
4665 Returns the length of the string in the SV.  See also C<SvCUR>.
4666
4667 =cut
4668 */
4669
4670 STRLEN
4671 Perl_sv_len(pTHX_ register SV *sv)
4672 {
4673     char *junk;
4674     STRLEN len;
4675
4676     if (!sv)
4677         return 0;
4678
4679     if (SvGMAGICAL(sv))
4680         len = mg_length(sv);
4681     else
4682         junk = SvPV(sv, len);
4683     return len;
4684 }
4685
4686 /*
4687 =for apidoc sv_len_utf8
4688
4689 Returns the number of characters in the string in an SV, counting wide
4690 UTF8 bytes as a single character.
4691
4692 =cut
4693 */
4694
4695 STRLEN
4696 Perl_sv_len_utf8(pTHX_ register SV *sv)
4697 {
4698     if (!sv)
4699         return 0;
4700
4701     if (SvGMAGICAL(sv))
4702         return mg_length(sv);
4703     else
4704     {
4705         STRLEN len;
4706         U8 *s = (U8*)SvPV(sv, len);
4707
4708         return Perl_utf8_length(aTHX_ s, s + len);
4709     }
4710 }
4711
4712 void
4713 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4714 {
4715     U8 *start;
4716     U8 *s;
4717     U8 *send;
4718     I32 uoffset = *offsetp;
4719     STRLEN len;
4720
4721     if (!sv)
4722         return;
4723
4724     start = s = (U8*)SvPV(sv, len);
4725     send = s + len;
4726     while (s < send && uoffset--)
4727         s += UTF8SKIP(s);
4728     if (s >= send)
4729         s = send;
4730     *offsetp = s - start;
4731     if (lenp) {
4732         I32 ulen = *lenp;
4733         start = s;
4734         while (s < send && ulen--)
4735             s += UTF8SKIP(s);
4736         if (s >= send)
4737             s = send;
4738         *lenp = s - start;
4739     }
4740     return;
4741 }
4742
4743 void
4744 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4745 {
4746     U8 *s;
4747     U8 *send;
4748     STRLEN len;
4749
4750     if (!sv)
4751         return;
4752
4753     s = (U8*)SvPV(sv, len);
4754     if (len < *offsetp)
4755         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4756     send = s + *offsetp;
4757     len = 0;
4758     while (s < send) {
4759         STRLEN n;
4760         /* Call utf8n_to_uvchr() to validate the sequence */
4761         utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4762         if (n > 0) {
4763             s += n;
4764             len++;
4765         }
4766         else
4767             break;
4768     }
4769     *offsetp = len;
4770     return;
4771 }
4772
4773 /*
4774 =for apidoc sv_eq
4775
4776 Returns a boolean indicating whether the strings in the two SVs are
4777 identical.
4778
4779 =cut
4780 */
4781
4782 I32
4783 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4784 {
4785     char *pv1;
4786     STRLEN cur1;
4787     char *pv2;
4788     STRLEN cur2;
4789     I32  eq     = 0;
4790     char *tpv   = Nullch;
4791
4792     if (!sv1) {
4793         pv1 = "";
4794         cur1 = 0;
4795     }
4796     else
4797         pv1 = SvPV(sv1, cur1);
4798
4799     if (!sv2){
4800         pv2 = "";
4801         cur2 = 0;
4802     }
4803     else
4804         pv2 = SvPV(sv2, cur2);
4805
4806     /* do not utf8ize the comparands as a side-effect */
4807     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4808         bool is_utf8 = TRUE;
4809         /* UTF-8ness differs */
4810         if (PL_hints & HINT_UTF8_DISTINCT)
4811             return FALSE;
4812
4813         if (SvUTF8(sv1)) {
4814             /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4815             char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4816             if (pv != pv1)
4817                 pv1 = tpv = pv;
4818         }
4819         else {
4820             /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4821             char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4822             if (pv != pv2)
4823                 pv2 = tpv = pv;
4824         }
4825         if (is_utf8) {
4826             /* Downgrade not possible - cannot be eq */
4827             return FALSE;
4828         }
4829     }
4830
4831     if (cur1 == cur2)
4832         eq = memEQ(pv1, pv2, cur1);
4833
4834     if (tpv != Nullch)
4835         Safefree(tpv);
4836
4837     return eq;
4838 }
4839
4840 /*
4841 =for apidoc sv_cmp
4842
4843 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
4844 string in C<sv1> is less than, equal to, or greater than the string in
4845 C<sv2>.
4846
4847 =cut
4848 */
<