sv.c

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